From 0d52c58f1e8941c4c08182710abcb327489b8c99 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Sun, 27 Jul 2008 18:19:33 +0200
Subject: Use DEFUN in order to redefine functions used to implement DEFUN
 after it has been defined itself.

---
 defun-0.lisp            |   5 ++
 defun-1.lisp            |  20 +++++
 destructuring-bind.lisp |  46 +++++------
 init.lisp               |   3 +
 list-functions.lisp     | 204 ++++++++++++++++++++++++------------------------
 5 files changed, 149 insertions(+), 129 deletions(-)
 create mode 100644 defun-0.lisp
 create mode 100644 defun-1.lisp

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))
diff --git a/init.lisp b/init.lisp
index 9a51e6b..ab91247 100644
--- a/init.lisp
+++ b/init.lisp
@@ -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))
-- 
cgit v1.2.3