[movitz-cvs] CVS movitz

[ffjeld]

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv27432

Modified Files:
	parse.lisp 
Log Message:
parse-macro-lambda-list.


--- /project/movitz/cvsroot/movitz/parse.lisp	2007/02/01 19:37:41	1.7
+++ /project/movitz/cvsroot/movitz/parse.lisp	2008/04/21 19:46:12	1.8
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:49:17 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: parse.lisp,v 1.7 2007/02/01 19:37:41 ffjeld Exp $
+;;;; $Id: parse.lisp,v 1.8 2008/04/21 19:46:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -38,6 +38,33 @@
 	(parse-declarations-and-body forms declare-symbol)
       (values body declarations docstring))))
 
+(defun parse-macro-lambda-list (lambda-list)
+  (let* ((whole-var (when (eq '&whole (car lambda-list))
+                      (pop lambda-list)
+                      (pop lambda-list)))
+         (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)))))
+         (ignore-env-var
+          (when (not env-var)
+            (gensym))))
+    (values destructuring-lambda-list
+            whole-var
+            (or env-var
+                ignore-env-var)
+            (when ignore-env-var
+              (list ignore-env-var))
+            (list operator-var))))
+
 (defun unfold-circular-list (list)
   "If LIST is circular (through cdr), return (a copy of) the non-circular portion of LIST, and the index (in LIST) of the cons-cell pointed to by (cdr (last LIST))."
   (flet ((find-cdr (l c end)