From d2370aa9d420b1e466e58f00dbda0309ade6ced9 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Sun, 27 Jul 2008 12:34:26 +0200
Subject: D-B: Fix &OPTIONAL handling.

---
 destructuring-bind.lisp | 18 +++++++++---------
 list-functions.lisp     | 20 +++++++++++++++++---
 util.lisp               | 15 +++++++--------
 3 files changed, 33 insertions(+), 20 deletions(-)

diff --git a/destructuring-bind.lisp b/destructuring-bind.lisp
index 161390d..7be7e41 100644
--- a/destructuring-bind.lisp
+++ b/destructuring-bind.lisp
@@ -17,7 +17,7 @@
                      ,@body)))
                (&aux
                 (if (or (endp (cdr lambda-list))
-                        (member (cadr lambda-list) lambda-list-keywords))
+                        (%member (cadr lambda-list) lambda-list-keywords))
                     `(d-b ,(cdr lambda-list) ,environment ,whole-sym ,expression
                        ,@body)
                     `(let (,(cadr lambda-list))
@@ -25,29 +25,29 @@
                          ,@body))))
                (&optional
                 (if (or (endp (cdr lambda-list))
-                        (member (cadr lambda-list) lambda-list-keywords))
+                        (%member (cadr lambda-list) lambda-list-keywords))
                     `(d-b ,(cdr lambda-list) ,environment ,whole-sym ,expression
                        ,@body)
                     (let ((sym (gensym))
-                          (head (car lambda-list)))
+                          (head (cadr lambda-list)))
                       `(let* ((,sym ,expression)
                               ,@(cond ((atom head)
-                                       `((,head (cadr ,sym))))
+                                       `((,head (car ,sym))))
                                       ((null (cdr head))
-                                       `((,(car head) (cadr ,sym))))
+                                       `((,(car head) (car ,sym))))
                                       ((null (cddr head))
                                        `((,(car head) (if (null ,sym)
                                                           ,(cadr head)
-                                                          (cadr ,sym)))))
+                                                          (car ,sym)))))
                                       (t
                                        `((,(car head) (if (null ,sym)
                                                           ,(cadr head)
-                                                          (cadr ,sym)))
+                                                          (car ,sym)))
                                          (,(caddr head) (not (null ,sym)))))))
                          (d-b (&optional ,@(cddr lambda-list)) ,environment ,whole-sym (cdr ,sym)
                            ,@body)))))
                ((&rest &body)
-                (if (member (cadr lambda-list) lambda-list-keywords)
+                (if (%member (cadr lambda-list) lambda-list-keywords)
                     `(d-b ,(cdr lambda-list) ,environment ,whole-sym ,expression
                        ,@body)
                     (let ((sym (gensym)))
@@ -64,7 +64,7 @@
                    ,@body))
                (&key
                 (if (or (endp (cdr lambda-list))
-                        (member (cadr lambda-list) lambda-list-keywords))
+                        (%member (cadr lambda-list) lambda-list-keywords))
                     `(d-b ,(cdr lambda-list) ,environment ,whole-sym ,expression
                        ,@body)
                     (let* ((sym (gensym))
diff --git a/list-functions.lisp b/list-functions.lisp
index 464a9a4..5e700c4 100644
--- a/list-functions.lisp
+++ b/list-functions.lisp
@@ -146,8 +146,8 @@
 ;;;;-----------------------------------------------------------------
 ;;;; TYPE PREDICATES
 ;;;;-----------------------------------------------------------------
-(shadow '(consp listp null))
-(unexport '(sys::consp sys::listp sys::null) (find-package :sys))
+(shadow '(consp listp null atom))
+(unexport '(sys::consp sys::listp sys::null sys::atom) (find-package :sys))
 
 (%defun consp args
   (sys::consp (first args)))
@@ -158,9 +158,22 @@
 (%defun null args
   (sys::null (first args)))
 
+(%defun atom args
+  (sys::atom (first args)))
+
 ;(%deftype cons args '(satisfies consp))
 ;(%deftype list args '(satisfies listp))
 ;(%deftype null args '(satisfies null))
+;(%deftype atom args '(satisfies atom))
+
+
+;;;;-----------------------------------------------------------------
+;;;; OTHER PREDICATES
+;;;;-----------------------------------------------------------------
+(%defun endp args
+  (let ((thing (first args)))
+    ;;FIXME (check-type thing (first args) list)
+    (null thing)))
 
 
 ;;;;-----------------------------------------------------------------
@@ -178,4 +191,5 @@
 
 ;;;;-----------------------------------------------------------------
 (export '(cons car cdr list* first second third fourth fifth sixth
-          seventh eigthth ninth tenth consp listp null rplaca rplacd))
+          seventh eigthth ninth tenth atom consp listp null rplaca
+          rplacd))
diff --git a/util.lisp b/util.lisp
index 08c7d1c..63777ea 100644
--- a/util.lisp
+++ b/util.lisp
@@ -187,13 +187,12 @@
         expansion-1
         (macroexpand expansion-2))))
 
-(%defun* macroexpand-all (object . rest)
-  (let* ((env (if rest (car rest) nil)))
-    (if (consp object)
-        (let ((expansion (macroexpand object env)))
-          (cons (macroexpand-all (car expansion))
-                (macroexpand-all (cdr expansion))))
-        object)))
-
 (%defmacro* unless (test . body)
   `(if (not ,test) (progn ,@body) nil))
+
+(%defmacro* when (test . body)
+  `(if ,test (progn ,@body) nil))
+
+
+(export '(and or not let* list* case cond append reverse macroexpand
+          otherwise unless when))
-- 
cgit v1.2.3