[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

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

Modified Files:
	defmacro-bootstrap.lisp 
Log Message:
Fix handling of &whole in defmacro/run-time.


--- /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp	2008/04/12 16:23:28	1.2
+++ /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp	2008/04/12 17:11:23	1.3
@@ -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.2 2008/04/12 16:23:28 ffjeld Exp $
+;;;; $Id: defmacro-bootstrap.lisp,v 1.3 2008/04/12 17:11:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -36,6 +36,9 @@
       (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))
@@ -54,14 +57,27 @@
 	      (values env-var nil)
 	      (let ((e (gensym)))
 		(values e (list e))))
-	`(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 ,destructuring-lambda-list
-				    ,form-var
-				  (declare (ignore ,operator-var) , at declarations)
-				  , at real-body))
-			      :type :macro-function)))))
+	(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)))))))