[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv23749

Modified Files:
	defmacro-bootstrap.lisp 
Log Message:
Factor out parse-macro-lambda-list from the macroexpander.


--- /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp	2008/04/12 17:11:23	1.3
+++ /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp	2008/04/21 19:38:48	1.4
@@ -7,7 +7,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: defmacro-bootstrap.lisp,v 1.3 2008/04/12 17:11:23 ffjeld Exp $
+;;;; $Id: defmacro-bootstrap.lisp,v 1.4 2008/04/21 19:38:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -33,51 +33,44 @@
 
 (defmacro defmacro/run-time (name lambda-list &body body)
   (multiple-value-bind (real-body declarations docstring)
-      (movitz::parse-docstring-declarations-and-body body 'cl:declare)
-    (let* ((block-name (compute-function-block-name name))
-	   (ignore-var (gensym))
-	   (whole-var (when (eq '&whole (car lambda-list))
-			(list (pop lambda-list)
-			      (pop lambda-list))))
-	   (form-var (gensym "form-"))
-	   (env-var nil)
-	   (operator-var (gensym))
-	   (destructuring-lambda-list
-	    (do ((l lambda-list)
-		 (r nil))
-		((atom l)
-		 (cons operator-var
-		       (nreconc r l)))
-	      (let ((x (pop l)))
-		(if (eq x '&environment)
-		    (setf env-var (pop l))
-		    (push x r))))))
-      (multiple-value-bind (env-var ignore-env)
-	  (if env-var
-	      (values env-var nil)
-	      (let ((e (gensym)))
-		(values e (list e))))
-	(cond
-	  ((and whole-var
-		(null lambda-list))
-	   `(make-named-function ,name
-				 (&edx edx &optional ,form-var ,env-var &rest ,ignore-var)
-				 ((ignore ,ignore-var , at ignore-env))
-				 ,docstring
-				 (block ,block-name
-				   (verify-macroexpand-call edx ',name)
-				   (let ((,(second whole-var) ,form-var))
-				     (declare , at declarations)
-				     , at real-body))
-				 :type :macro-function))
-	  (t `(make-named-function ,name
-				   (&edx edx &optional ,form-var ,env-var &rest ,ignore-var)
-				   ((ignore ,ignore-var , at ignore-env))
-				   ,docstring
-				   (block ,block-name
-				     (verify-macroexpand-call edx ',name)
-				     (destructuring-bind ,(append whole-var destructuring-lambda-list)
-					 ,form-var
-				       (declare (ignore ,operator-var) , at declarations)
-				       , at real-body))
-				   :type :macro-function)))))))
+      (parse-docstring-declarations-and-body body 'cl:declare)
+    (multiple-value-bind (destructuring-lambda-list whole-var env-var ignore-env ignore-operator)
+        (parse-macro-lambda-list lambda-list)
+      (let* ((block-name (compute-function-block-name name))
+             (extras (gensym))
+             (form-var (or whole-var
+                           (gensym "form-"))))
+        (cond
+          ((and (eq whole-var form-var)
+                (null (cdr destructuring-lambda-list)))
+           `(make-named-function ,name
+                                 (&edx edx &optional ,form-var ,env-var &rest ,extras)
+                                 ((ignore , at ignore-env))
+                                 ,docstring
+                                 (block ,block-name
+                                   (numargs-case
+                                    (2 (&edx edx &optional ,form-var ,env-var)
+                                       (verify-macroexpand-call edx ',name)
+                                       (let ()
+                                         (declare , at declarations)
+                                         , at real-body))
+                                    (t (&edx edx &optional ,form-var ,env-var &rest ,extras)
+                                       (declare (ignore ,form-var ,extras))
+                                       (verify-macroexpand-call edx ',name t))))
+                                 :type :macro-function))
+          (t `(make-named-function ,name
+                                   (&edx edx &optional ,form-var ,env-var &rest ,extras)
+                                   ((ignore , at ignore-env ,extras))
+                                   ,docstring
+                                   (block ,block-name
+                                     (numargs-case
+                                      (2 (&edx edx ,form-var ,env-var)
+                                         (verify-macroexpand-call edx ',name)
+                                         (destructuring-bind ,destructuring-lambda-list
+                                             ,form-var
+                                           (declare (ignore , at ignore-operator) , at declarations)
+                                           , at real-body))
+                                      (t (&edx edx &optional ,form-var ,env-var &rest ,extras)
+                                         (declare (ignore ,form-var ,extras))
+                                         (verify-macroexpand-call edx ',name t))))
+                                   :type :macro-function)))))))