Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

renamed STANDARD-CL to DOODADS (less presumptuous)

renamed LETT to LET1
    (more obvious meaning, easier to distinguish from LET in speach)
renamed LETWHEN to WHEN-LET
    (it's sort of like (when (let <binding>) ...))
  • Loading branch information...
commit 5887f6203e3f0c2603e1353ec7bc06ee11f98288 1 parent 59ae6a2
@Drakken authored
View
2  README
@@ -13,7 +13,7 @@ There are three ways to load cl-match:
* load the file load.lisp in this directory
* asdf-install :cl-match
* asdf-load the system files in this directory:
- * standard-cl (general-purpose library)
+ * doodads (general-purpose library)
* cl-match (pattern matching)
* pcl-unit-test (unit testing framework)
* cl-match-test (unit tests)
View
2  cl-match.asd
@@ -1,6 +1,6 @@
(asdf:defsystem :cl-match
- :depends-on (:standard-cl)
+ :depends-on (:doodads)
:components (
(:file :match)
))
View
4 standard-cl.asd → doodads.asd
@@ -1,6 +1,6 @@
;; asdf system def for standard-cl
-(defsystem :standard-cl
+(defsystem :doodads
:components (
(module "std"
:serial t
@@ -9,7 +9,7 @@
(:file "base")
(:module :content
:components (
- (:file "standard")
+ (:file "doodads")
(:file "2fix")
(:file "func")))
(:file "syntax")
View
42 match.lisp
@@ -14,10 +14,10 @@
(std:in-defpackage :cl-match (:use :cl :std) (:export :cl-match-pattern)
(:export :ifmatch :letmatch :match :defpattern))
-(use-std-readtable)
+(use-doodads-readtable)
(def all-equal (xs)
- [(not xs) or (lett x0 (car xs) (apply #'andf (mapcar #f[_ equal x0] (cdr xs))))])
+ [(not xs) or (let1 x0 (car xs) (apply #'andf (mapcar #f[_ equal x0] (cdr xs))))])
(defstruct vgt vars gensyms test) ;; a complete test with vars & gensyms
(defstruct conj vars tests gensyms ors whens) ;; a conjunction of subtests
@@ -54,7 +54,7 @@
(defmac with-gensym-conj ((conj gensym expr &rest tests) &body body)
"Create and bind a conj with a gensym, a setft form, and optional tests."
- (lett gensym-is-list [gensym islist]
+ (let1 gensym-is-list [gensym islist]
(if gensym-is-list
(assert [gensym has-length 2] (gensym)
"with-gensym-conj: list gensym must have exactly two elements.")
@@ -67,7 +67,7 @@
(,x (if ,expr-is-big ,gensym-form ,expr))
(,all-tests (list ,@tests)))
(when ,expr-is-big (push `(setft ,,x ,,expr) ,all-tests))
- (lett ,conj (new-conj nil (nreverse ,all-tests) [,expr-is-big and (list ,x)])
+ (let1 ,conj (new-conj nil (nreverse ,all-tests) [,expr-is-big and (list ,x)])
,@body))))))
(def patrn-type (x)
@@ -83,9 +83,9 @@
(def push-test ( test conj) (unless [test eq t] (push test (conj-tests conj))))
(def push-conj (src dest)
- (asrt [dest conj-p] (dest) "dest is not a conj")
+ (asrt (conj-p dest) (dest) "dest is not a conj")
(when src
- (asrt [src conj-p] (src) "src is not a conj")
+ (asrt (conj-p src) (src) "src is not a conj")
(pushlist (conj-vars src) (conj-vars dest)) ; uniq only!
(pushlist (conj-tests src) (conj-tests dest))
(pushlist (conj-gensyms src) (conj-gensyms dest))
@@ -111,7 +111,7 @@
(patrn (if (cdr parts) (cadr parts) '_)))
(assert (not [name is-literal]) (name)
"Literal found in AS pattern. 1st arg must be a name.")
- (lett conj (cond ([name is-wildcard] (new-conj))
+ (let1 conj (cond ([name is-wildcard] (new-conj))
((find name vars) (new-conj nil (list `[,expr eql ,name])))
(t (new-conj (list name) (list `(setft ,name ,expr)))))
(push-conj (patrn-conj expr patrn vars)
@@ -163,7 +163,7 @@
(case (length parts)
(0 (new-conj nil (list nil)))
(1 (patrn-conj expr (car parts) vars old-level))
- (t (lett new-level (case old-level (:top :top) (t :or))
+ (t (let1 new-level (case old-level (:top :top) (t :or))
(eif (not [parts are-all-vals])
(with-gensym x
(new-conj nil (list `(setft ,x ,expr))
@@ -214,7 +214,7 @@
(when f-exists
(push-test (funcall f-exists x name) conj))
(asrt [part-is-atom or (not (cddr part))] (part) "too many items in ~A entry" typestr)
- (lett slot-patrn (if part-is-atom part (if (cdr part) (cadr part) '_))
+ (let1 slot-patrn (if part-is-atom part (if (cdr part) (cadr part) '_))
(unless [slot-patrn is-wildcard]
(when f-bound
(push-test (funcall f-bound x name) conj))
@@ -261,7 +261,7 @@
(patrn-conj `(aref ,array ,@(reverse hi-bak-ns))
(if elt-type `(type ,elt-type ,patrn) patrn) vars)
(asrt [(length patrn) = (car lo-dims)] (lo-dims patrn) "dimension mismatch.")
- (lett conj (new-conj)
+ (let1 conj (new-conj)
(count-list (n p patrn conj)
(push-conj (subarray-conj array (cons n hi-bak-ns) (cdr lo-dims)
p (append (conj-vars conj) vars) elt-type)
@@ -292,7 +292,7 @@
(def type-conj (expr parts vars)
(asrt [parts islist :min-length 1 :max-length 2] (parts) "TYPE pattern takes 1 or 2 args.")
- (lett type (car parts)
+ (let1 type (car parts)
(with-gensym-conj (conj (x "TYPE") expr `(typep ,x ',type))
(when (cdr parts) (push-conj (patrn-conj x (cadr parts) vars) conj))
conj)))
@@ -312,7 +312,7 @@
(asrt (find level '(:top :or)) (level) "misplaced WHEN guard.")
(asrt parts nil "No test in WHEN guard.")
(asrt (not (cddr parts)) (parts) "Too many parts in WHEN guard")
- (lett conj (new-conj nil nil nil nil (list (car parts)))
+ (let1 conj (new-conj nil nil nil nil (list (car parts)))
(when (cdr parts)
(push-conj (patrn-conj expr (cadr parts) vars level)
conj))
@@ -342,17 +342,17 @@
(def patrn-conj (expr patrn vars &optional level)
(eif (atom patrn)
(atom-conj expr patrn vars)
- (lett type-spec (car patrn)
+ (let1 type-spec (car patrn)
(eif [type-spec has-type '(or string keyword)]
(default-conj expr patrn vars level)
(assert [type-spec is-symbol] (type-spec) "Pattern type must be a string or symbol.")
- (lett xformr (get type-spec 'cl-match-pattern)
+ (let1 xformr (get type-spec 'cl-match-pattern)
(eif xformr
(patrn-conj expr (funcall xformr (cdr patrn)) vars level)
(default-conj expr patrn vars level)))))))
(def all-same-vars (unsorted-lists)
- (lett lists (copy-tree unsorted-lists)
+ (let1 lists (copy-tree unsorted-lists)
(mapc #f(sort _ #'string< :key #'symbol-name)
lists)
(all-equal lists)))
@@ -372,7 +372,7 @@
(or-gensyms gensyms)
(or-test test))
(ors-vgt vars ors [whens and `(,when)])
- (lett test
+ (let1 test
(if (no whens)
`(and ,@tests ,or-test)
`(and ,@tests (flet ((,when () (and ,@whens))) ,or-test)))
@@ -385,9 +385,9 @@
(eval-always
(def binding-test (multibindings)
- (lett tests '()
+ (let1 tests '()
(dolist (mb multibindings)
- (lett var (car mb)
+ (let1 var (car mb)
(dolist (expr (cdadr mb)) ;the rest of the bindings
(push `[,var eql ,expr] tests))))
(case (length tests)
@@ -402,7 +402,7 @@
(if [type type= :vals] (length parts)
(and [type type= :or]
[parts are-all-vals]
- (lett nums (mapcar (lambda (part) (length (cdr part))) parts)
+ (let1 nums (mapcar (lambda (part) (length (cdr part))) parts)
(if (reduce #'= nums) (car nums)
(error "OR pattern: VALS must all have the same length."))))))])
@@ -455,7 +455,7 @@
(defmac defpattern (patrn args &body body)
(check-type patrn symbol "DEFPATTERN: 1st arg must a symbol")
`(eval-always
- (setf (get ',patrn 'cl-match-pattern) #f(lett ,args _ ,@body))))
+ (setf (get ',patrn 'cl-match-pattern) #f(let1 ,args _ ,@body))))
#|
@@ -483,7 +483,7 @@
(def not-conj (expr parts vars)
(assert [parts has-length 1] (parts) "NOT pattern must have exactly one part.")
(with-gensym-conj (not-conj (x "NOT") expr)
- (lett patrn-conj (patrn-conj x (car parts) vars)
+ (let1 patrn-conj (patrn-conj x (car parts) vars)
(eif [(conj-ors patrn-conj) or (conj-whens patrn-conj)]
(setf (conj-ors not-conj) (list patrn-conj)) ;; patrn-conj will be negated in OR-VGT
(let* ((tests (append (conj-tests patrn-conj)
View
2  pcl-unit-test.asd
@@ -1,7 +1,7 @@
;;(cl:in-package :cl)
(asdf:defsystem :pcl-unit-test
- :depends-on (:standard-cl)
+ :depends-on (:doodads)
:components (
(:file "pcl-unit-test")
))
View
6 pcl-unit-test.lisp
@@ -7,11 +7,11 @@
(defvar *test-name* nil)
-(use-std-readtable)
+(use-doodads-readtable)
(defmac deftest (name parameters &body body)
`(defun ,name ,parameters
- (lett *test-name* (cons ',name *test-name*)
+ (let1 *test-name* (cons ',name *test-name*)
,@body)))
(def pass-fail (rzult form)
@@ -20,7 +20,7 @@
(defmac all-okay (&body forms)
(with-gensym okay
- `(lett ,okay t
+ `(let1 ,okay t
,@(mapcar (lambda (form) `(unless ,form (setf ,okay nil)))
forms)
,okay)))
View
8 std/base.lisp
@@ -1,4 +1,4 @@
-;; standard-cl: a standard libary for Common Lisp
+;; Doodads: a utility libary for Common Lisp
#|
-------------------------------------------------------------------------
This software is Copyright (c) 2008 Daniel S. Bensen.
@@ -11,7 +11,7 @@ This software is provided "as is" with no express or implied warranty.
(cl:declaim (optimize debug))
-(cl:in-package :standard-cl)
+(cl:in-package :doodads)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro eval-always (&body body)
@@ -53,7 +53,7 @@ This software is provided "as is" with no express or implied warranty.
;;; BINDING
- (defmac lett (x expr &body body)
+ (defmac let1 (x expr &body body)
(if (atom x)
`(let ((,x ,expr)) ,@body)
`(destructuring-bind ,x ,expr ,@body)))
@@ -76,7 +76,7 @@ This software is provided "as is" with no express or implied warranty.
(eq (caar body) 'declare)) (push (pop body) preamble)))
(with-gensym (val "GRETURN-VAL")
(setf body
- (list `(lett gfuncname (symbol-name ',func)
+ (list `(let1 gfuncname (symbol-name ',func)
(declare (ignorable gfuncname))
(macrolet ((greturn (&optional (,val (values)))
`(return-from ,',func ,,val))) ;; C-style return
View
4 std/content/2fix.lisp
@@ -16,7 +16,7 @@ This software is provided "as is" with no express or implied warranty.
;; ^ ^2 ^3 ^4 ^5 ^6 ^7 ^8 def-op= =0 >0 <0 >=0 <=0 !=0))
;;(in-package :2fix)
-(in-package :standard-cl)
+(in-package :doodads)
(defun |read-[2-fix]| (stream char)
(declare (ignore char))
@@ -48,7 +48,7 @@ This software is provided "as is" with no express or implied warranty.
(= (length x) n)
(if (zerop n)
(not x)
- (lett last-cdr (nthcdr (1- n) x)
+ (let1 last-cdr (nthcdr (1- n) x)
(and last-cdr (not (cdr last-cdr)))))))
(defmac def-isseq (isseq seqp)
View
38 std/content/standard.lisp → std/content/doodads.lisp
@@ -1,4 +1,4 @@
-;; standard-cl: a standard libary for Common Lisp
+;; doodads: a utility libary for Common Lisp
#|
-------------------------------------------------------------------------
This software is Copyright (c) 2008 Daniel S. Bensen.
@@ -11,7 +11,7 @@ This software is provided "as is" with no express or implied warranty.
(cl:declaim (optimize debug))
-(cl:in-package :standard-cl)
+(cl:in-package :doodads)
(def gensyms (n) (loop repeat n collect (gensym)))
@@ -29,15 +29,15 @@ This software is provided "as is" with no express or implied warranty.
(defmac letts (plist &body body)
(eif (no plist)
`(progn ,@body)
- (lett bindings (nreverse (2list<-plist plist))
+ (let1 bindings (nreverse (2list<-plist plist))
(assert bindings (bindings) "LETTS: malformed binding list")
- (lett binding (car bindings)
- (setf body `(lett ,(car binding) ,(cadr binding) ,@body))
+ (let1 binding (car bindings)
+ (setf body `(let1 ,(car binding) ,(cadr binding) ,@body))
(dolist (binding (cdr bindings) body)
- (setf body `(lett ,(car binding) ,(cadr binding) ,body)))))))
+ (setf body `(let1 ,(car binding) ,(cadr binding) ,body)))))))
(def external-symbols (&optional (package *package*))
- (lett symbols nil
+ (let1 symbols nil
(do-external-symbols (symbol package (nreverse symbols))
(push symbol symbols))))
@@ -61,7 +61,7 @@ This software is provided "as is" with no express or implied warranty.
(def sethash (key table val) (setf (gethash key table) val))
(defmac for ((var init test incr) &body body)
- `(lett ,var ,init
+ `(let1 ,var ,init
(while ,test
,@body
(setf ,var ,incr))))
@@ -73,7 +73,7 @@ This software is provided "as is" with no express or implied warranty.
(defmac dopairs ((x y list) &body body)
(with-gensym cell
- `(lett ,x (car ,list)
+ `(let1 ,x (car ,list)
(docells (,cell (cdr ,list))
(dolist (,y (cdr ,cell))
,@body
@@ -135,7 +135,7 @@ This software is provided "as is" with no express or implied warranty.
(def orf (&rest vals) (dolist (val vals nil) (when val (return val))))
(def andf (&rest vals)
- (lett rzult t
+ (let1 rzult t
(dolist (val vals rzult) (if val (setf rzult val) (return nil)))))
(def /_ (x y) (floor x y))
@@ -222,11 +222,11 @@ This software is provided "as is" with no express or implied warranty.
(defmac pushwhen (expr place)
(with-gensym val
- `(lett ,val ,expr
+ `(let1 ,val ,expr
(when ,val (push ,val ,place)))))
-(defmac letwhen (var pred &body body)
- `(lett ,var ,pred
+(defmac when-let (var pred &body body)
+ `(let1 ,var ,pred
(when ,var ,@body)))
(defmac setwhen (oldval place newval)
@@ -243,7 +243,7 @@ This software is provided "as is" with no express or implied warranty.
(defmac strcase (expr &rest clauses)
(with-gensym val
- `(lett ,val ,expr
+ `(let1 ,val ,expr
(cond
,@(mapcar (lambda (clause) (if (eq (car clause) t) `(t ,@(cdr clause))
`((string= ,val ,(car clause)) ,@(cdr clause))))
@@ -261,7 +261,7 @@ This software is provided "as is" with no express or implied warranty.
(defun letstruct-testable (testing type- slots expr body)
"Deconstruct a struct. Testing for struct existance is optional."
- (lett prefix (string-or-symbol-name type-)
+ (let1 prefix (string-or-symbol-name type-)
(with-gensym val
(flet ((slotbinding (slot)
(let* ((is-atom (atom slot))
@@ -276,22 +276,22 @@ This software is provided "as is" with no express or implied warranty.
slotexpr1)))
(list slotname slot-expr))))
(if slots
- `(lett ,val ,expr
+ `(let1 ,val ,expr
(let ,(mapcar #'slotbinding slots) ,@body))
- `(lett ,val ,expr ,@body))))))
+ `(let1 ,val ,expr ,@body))))))
(defmac letstruct ((type- . slots) x &body body) (letstruct-testable nil type- slots x body))
(defmac letstruct-if ((type- . slots) x &body body) (letstruct-testable t type- slots x body))
(def |read_case| (case)
- (lett readtable (copy-readtable nil)
+ (let1 readtable (copy-readtable nil)
(setf (readtable-case readtable) case)
(setf *readtable* readtable)))
(def cwd () (truename "."))
(def cd (pathstr)
-;; (lett char0 (char dir 0)
+;; (let1 char0 (char dir 0)
(setf *default-pathname-defaults*
(pathname pathstr)))
;; (if [char0 char= #\/]
View
4 std/content/func.lisp
@@ -1,4 +1,4 @@
-;;; standard-cl: partial application
+;;; doodads partial application
#|
-------------------------------------------------------------------------
This software is Copyright (c) 2008 Daniel S. Bensen.
@@ -9,7 +9,7 @@ This software is provided "as is" with no express or implied warranty.
-------------------------------------------------------------------------
|#
-(cl:in-package :standard-cl)
+(cl:in-package :doodads)
;; #f(func _ arg _)
;; #f[_ op _]
View
4 std/load.lisp
@@ -1,4 +1,4 @@
-;;;load standard-cl
+;;;load Doodads
;;;by Dan Bensen
;;; each file is a list of a pathname and file name
@@ -12,7 +12,7 @@
(main-list `(:serial
(,std "package")
(,std "base")
- ((,content "standard") (,content "2fix") (,content "func"))
+ ((,content "doodads") (,content "2fix") (,content "func"))
(,std "syntax"))))
(labels ((load-file (path name compiling)
(let* ((src (make-pathname :name name :type "lisp" :defaults path))
View
12 std/package.lisp
@@ -1,4 +1,4 @@
-;; standard-cl package
+;; Doodads package
#|
---------------------------------------------------------------
;; This software is Copyright (c) 2008 Daniel S. Bensen.
@@ -10,17 +10,17 @@
|#
(cl:defpackage
- :standard-cl (:use :cl) (:nicknames :std)
+ :doodads (:use :cl) (:nicknames :std)
(:export
;;syntax
- :make-std-readtable :use-std-readtable
+ :make-doodads-readtable :use-doodads-readtable
;;base
:in-defpackage :eval-always :xport
:defmac :macx :with-gensyms :with-gensym
:def :defx :indef :indefx :greturn :gfuncname
:while :until :do-while :do-until
- :lett :letvals
- ;;standard
+ :let1 :letvals
+ ;;doodads
:gensyms :eif :2list<-plist :letts :external-symbols
:no :concat :concstr :ask-yn :ask-yes-no :defparam
:debug-out :echo :prompt
@@ -36,7 +36,7 @@
:is-lc :is-uc :is-letr :lc<-int :uc<-int :int<-letr
:? :flatten :npushlit :pushlist :pushrevlist
:trim-whitespace :trim-linespace
- :pushwhen :letwhen :setwhen :cond-eql :strcase
+ :pushwhen :when-let :setwhen :cond-eql :strcase
:dovector :string-or-symbol-name
:letstruct :letstruct-if
:cwd :cd :quit
View
12 std/syntax.lisp
@@ -1,4 +1,4 @@
-;;; standard-cl: syntax
+;;; doodads syntax
#|
-------------------------------------------------------------------------
This software is Copyright (c) 2008 Daniel S. Bensen.
@@ -9,15 +9,15 @@ This software is provided "as is" with no express or implied warranty.
-------------------------------------------------------------------------
|#
-(in-package :standard-cl)
+(in-package :doodads)
-(def make-std-readtable ()
- (lett table (copy-readtable nil)
+(def make-doodads-readtable ()
+ (let1 table (copy-readtable nil)
(set-macro-character #\[ #'|read-[2-fix]| nil table)
(set-macro-character #\] (get-macro-character #\) nil) nil table)
(set-dispatch-macro-character #\# #\f #'|read-#func| table)
table))
-(defmac use-std-readtable ()
+(defmac use-doodads-readtable ()
'(eval-when (:execute :compile-toplevel)
- (setf *readtable* (make-std-readtable))))
+ (setf *readtable* (make-doodads-readtable))))
Please sign in to comment.
Something went wrong with that request. Please try again.