diff options
| -rw-r--r-- | defun-0.lisp | 5 | ||||
| -rw-r--r-- | defun-1.lisp | 20 | ||||
| -rw-r--r-- | destructuring-bind.lisp | 46 | ||||
| -rw-r--r-- | init.lisp | 3 | ||||
| -rw-r--r-- | list-functions.lisp | 204 |
5 files changed, 149 insertions, 129 deletions
diff --git a/defun-0.lisp b/defun-0.lisp new file mode 100644 index 0000000..5b95711 --- /dev/null +++ b/defun-0.lisp @@ -0,0 +1,5 @@ +(%defmacro* defun args + `(%defun* ,@args)) + +(%defmacro* defmacro args + `(%defmacro* ,@args)) diff --git a/defun-1.lisp b/defun-1.lisp new file mode 100644 index 0000000..a0c2416 --- /dev/null +++ b/defun-1.lisp @@ -0,0 +1,20 @@ +(%defmacro* defun (name lambda-list . body) + (let ((lambda-sym (gensym))) + `(%defun ,name ,lambda-sym + (d-b ,lambda-list nil nil ,lambda-sym + ,@body)))) + +(%defmacro* defmacro (name lambda-list . body) + (let ((arg-sym (gensym)) + (lambda-sym (gensym)) + (whole-sym (gensym)) + (env-sym (gensym))) + `(%defmacro ,name ,arg-sym + (let ((,whole-sym (first ,arg-sym)) + (,lambda-sym (cdr (first ,arg-sym))) + (,env-sym (second ,arg-sym))) + (d-b ,lambda-list ,env-sym ,whole-sym ,lambda-sym + ,@body))))) + + +(export '(defmacro defun)) diff --git a/destructuring-bind.lisp b/destructuring-bind.lisp index 021076d..b819a16 100644 --- a/destructuring-bind.lisp +++ b/destructuring-bind.lisp @@ -1,3 +1,13 @@ +;; D-B may not expand to (but _may_ itself use!) plain list function +;; calls because these are defined in list-functions.lisp by way of +;; DEFUN, which is in turn based on D-B. Because of this, we define our +;; own functions here. +(%defun* %car (list) + (sys::car list)) + +(%defun* %cdr (list) + (sys::cdr list)) + (setq lambda-list-keywords '(&allow-other-keys &aux &body &environment &key &optional &rest &whole)) @@ -32,19 +42,19 @@ (head (cadr lambda-list))) `(let* ((,sym ,expression) ,@(cond ((atom head) - `((,head (car ,sym)))) + `((,head (%car ,sym)))) ((null (cdr head)) - `((,(car head) (car ,sym)))) + `((,(car head) (%car ,sym)))) ((null (cddr head)) `((,(car head) (if (null ,sym) ,(cadr head) - (car ,sym))))) + (%car ,sym))))) (t `((,(car head) (if (null ,sym) ,(cadr head) - (car ,sym))) + (%car ,sym))) (,(caddr head) (not (null ,sym))))))) - (d-b (&optional ,@(cddr lambda-list)) ,environment ,whole-sym (cdr ,sym) + (d-b (&optional ,@(cddr lambda-list)) ,environment ,whole-sym (%cdr ,sym) ,@body))))) ((&rest &body) (if (%member (cadr lambda-list) lambda-list-keywords) @@ -100,8 +110,8 @@ (otherwise (let ((sym (gensym))) `(let ((,sym ,expression)) - (d-b ,(car lambda-list) ,environment ,whole-sym (car ,sym) - (d-b ,(cdr lambda-list) ,environment ,whole-sym (cdr ,sym) + (d-b ,(car lambda-list) ,environment ,whole-sym (%car ,sym) + (d-b ,(cdr lambda-list) ,environment ,whole-sym (%cdr ,sym) ,@body))))))) ((null lambda-list) `(progn ,@body)) @@ -112,26 +122,6 @@ `(d-b ,tree nil nil ,expression ,@body)) -(%defmacro* defun (name lambda-list . body) - (let ((lambda-sym (gensym))) - `(%defun ,name ,lambda-sym - (d-b ,lambda-list nil nil ,lambda-sym - ,@body)))) - -(%defmacro* defmacro (name lambda-list . body) - (let ((arg-sym (gensym)) - (lambda-sym (gensym)) - (whole-sym (gensym)) - (env-sym (gensym))) - `(%defmacro ,name ,arg-sym - (let ((,whole-sym (first ,arg-sym)) - (,lambda-sym (cdr (first ,arg-sym))) - (,env-sym (second ,arg-sym))) - (d-b ,lambda-list ,env-sym ,whole-sym ,lambda-sym - ,@body))))) - - (export '(destructuring-bind lambda-list-keywords &allow-other-keys &aux &body &environment &key &optional &rest - &whole - defmacro defun)) + &whole)) @@ -1,5 +1,8 @@ (in-package :common-lisp) (load "util.lisp") +(load "defun-0.lisp") (load "list-functions.lisp") (load "destructuring-bind.lisp") +(load "defun-1.lisp") +(load "list-functions.lisp") (in-package :common-lisp-user) diff --git a/list-functions.lisp b/list-functions.lisp index 5e700c4..91fd5ad 100644 --- a/list-functions.lisp +++ b/list-functions.lisp @@ -1,137 +1,137 @@ -(%defmacro pushq args +(%defmacro* pushq args (list* 'setq (car (cdr args)) (car args))) -(%defun first args - (car (car args))) +(defun first (list) + (car list)) ;;;;----------------------------------------------------------------- ;;;; THE CxR FUNCTIONS ;;;;----------------------------------------------------------------- -(%defun caaaar args - (car (caaar (first args)))) +(defun caaaar (list) + (car (caaar list))) -(%defun caaadr args - (car (caadr (first args)))) +(defun caaadr (list) + (car (caadr list))) -(%defun caaar args - (car (caar (first args)))) +(defun caaar (list) + (car (caar list))) -(%defun caadar args - (car (cadar (first args)))) +(defun caadar (list) + (car (cadar list))) -(%defun caaddr args - (car (caddr (first args)))) +(defun caaddr (list) + (car (caddr list))) -(%defun caadr args - (car (cadr (first args)))) +(defun caadr (list) + (car (cadr list))) -(%defun caar args - (car (car (first args)))) +(defun caar (list) + (car (car list))) -(%defun cadaar args - (car (cdaar (first args)))) +(defun cadaar (list) + (car (cdaar list))) -(%defun cadadr args - (car (cdadr (first args)))) +(defun cadadr (list) + (car (cdadr list))) -(%defun cadar args - (car (cdar (first args)))) +(defun cadar (list) + (car (cdar list))) -(%defun caddar args - (car (cddar (first args)))) +(defun caddar (list) + (car (cddar list))) -(%defun cadddr args - (car (cdddr (first args)))) +(defun cadddr (list) + (car (cdddr list))) -(%defun caddr args - (car (cddr (first args)))) +(defun caddr (list) + (car (cddr list))) -(%defun cadr args - (car (cdr (first args)))) +(defun cadr (list) + (car (cdr list))) (shadow 'car) (unexport 'sys::car (find-package :sys)) -(%defun car args - (sys::car (first args))) +(defun car (list) + (sys::car list)) -(%defun cdaaar args - (cdr (caaar (first args)))) +(defun cdaaar (list) + (cdr (caaar list))) -(%defun cdaadr args - (cdr (caadr (first args)))) +(defun cdaadr (list) + (cdr (caadr list))) -(%defun cdaar args - (cdr (caar (first args)))) +(defun cdaar (list) + (cdr (caar list))) -(%defun cdadar args - (cdr (cadar (first args)))) +(defun cdadar (list) + (cdr (cadar list))) -(%defun cdaddr args - (cdr (caddr (first args)))) +(defun cdaddr (list) + (cdr (caddr list))) -(%defun cdadr args - (cdr (cadr (first args)))) +(defun cdadr (list) + (cdr (cadr list))) -(%defun cdar args - (cdr (car (first args)))) +(defun cdar (list) + (cdr (car list))) -(%defun cddaar args - (cdr (cdaar (first args)))) +(defun cddaar (list) + (cdr (cdaar list))) -(%defun cddadr args - (cdr (cdadr (first args)))) +(defun cddadr (list) + (cdr (cdadr list))) -(%defun cddar args - (cdr (cdar (first args)))) +(defun cddar (list) + (cdr (cdar list))) -(%defun cdddar args - (cdr (cddar (first args)))) +(defun cdddar (list) + (cdr (cddar list))) -(%defun cddddr args - (cdr (cdddr (first args)))) +(defun cddddr (list) + (cdr (cdddr list))) -(%defun cdddr args - (cdr (cddr (first args)))) +(defun cdddr (list) + (cdr (cddr list))) -(%defun cddr args - (cdr (cdr (first args)))) +(defun cddr (list) + (cdr (cdr list))) (shadow 'cdr) (unexport 'sys::cdr (find-package :sys)) -(%defun cdr args - (sys::cdr (first args))) +(defun cdr (list) + (sys::cdr list)) ;;;;----------------------------------------------------------------- ;;;; SECOND ... TENTH ;;;;----------------------------------------------------------------- -(%defun second args - (cadr (car args))) +(defun second (list) + (cadr list)) -(%defun third args - (caddr (car args))) +(defun third (list) + (caddr list)) -(%defun fourth args - (car (cdddr (car args)))) +(defun fourth (list) + (car (cdddr list))) -(%defun fifth args - (cadr (cdddr (car args)))) +(defun fifth (list) + (cadr (cdddr list))) -(%defun sixth args - (caddr (cdddr (car args)))) +(defun sixth (list) + (caddr (cdddr list))) -(%defun seventh args - (car (cdddr (cdddr (car args))))) +(defun seventh (list) + (car (cdddr (cdddr list)))) -(%defun eigthth args - (cadr (cdddr (cdddr (car args))))) +(defun eigthth (list) + (cadr (cdddr (cdddr list)))) -(%defun ninth args - (caddr (cdddr (cdddr (car args))))) +(defun ninth (list) + (caddr (cdddr (cdddr list)))) -(%defun tenth args - (car (cdddr (cdddr (cdddr (car args)))))) +(defun tenth (list) + (car (cdddr (cdddr (cdddr list))))) ;;;;----------------------------------------------------------------- @@ -139,8 +139,8 @@ ;;;;----------------------------------------------------------------- (shadow 'cons) (unexport 'sys::cons (find-package :sys)) -(%defun cons args - (sys::cons (first args) (second args))) +(defun cons (x y) + (sys::cons x y)) ;;;;----------------------------------------------------------------- @@ -149,17 +149,17 @@ (shadow '(consp listp null atom)) (unexport '(sys::consp sys::listp sys::null sys::atom) (find-package :sys)) -(%defun consp args - (sys::consp (first args))) +(defun consp (x) + (sys::consp x)) -(%defun listp args - (sys::listp (first args))) +(defun listp (x) + (sys::listp x)) -(%defun null args - (sys::null (first args))) +(defun null (x) + (sys::null x)) -(%defun atom args - (sys::atom (first args))) +(defun atom (x) + (sys::atom x)) ;(%deftype cons args '(satisfies consp)) ;(%deftype list args '(satisfies listp)) @@ -170,9 +170,9 @@ ;;;;----------------------------------------------------------------- ;;;; OTHER PREDICATES ;;;;----------------------------------------------------------------- -(%defun endp args - (let ((thing (first args))) - ;;FIXME (check-type thing (first args) list) +(defun endp (list) + (let ((thing list)) + ;;FIXME (check-type thing list) (null thing))) @@ -182,14 +182,16 @@ (shadow '(rplaca rplacd)) (unexport '(sys::rplaca sys::rplacd) (find-package :sys)) -(%defun rplaca args - (sys::rplaca (first args) (second args))) +(defun rplaca (cons new-value) + (sys::rplaca cons new-value)) -(%defun rplacd args - (sys::rplacd (first args) (second args))) +(defun rplacd (cons new-value) + (sys::rplacd cons new-value)) ;;;;----------------------------------------------------------------- -(export '(cons car cdr list* first second third fourth fifth sixth - seventh eigthth ninth tenth atom consp listp null rplaca - rplacd)) +(export '(cons list* first second third fourth fifth sixth seventh + eigthth ninth tenth atom consp listp null rplaca rplacd caaaar + caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar + caddar cadddr caddr cadr car cdaaar cdaadr cdaar cdadar cdaddr + cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr)) |