[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

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

Modified Files:
	eval.lisp 
Log Message:
Add parse-macro-lambda-list, and have (eval interpreted) macrolet use it.


--- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp	2008/04/17 19:33:48	1.31
+++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp	2008/04/21 19:40:05	1.32
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 19 21:15:12 2001
 ;;;;                
-;;;; $Id: eval.lisp,v 1.31 2008/04/17 19:33:48 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.32 2008/04/21 19:40:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -196,9 +196,37 @@
 			   (apply f a0 a1 evaluated-args)))
 		       f env a0 a1 form))))))
 
-(defun parse-declarations-and-body (forms)
+(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 parse-declarations-and-body (forms &optional (declare 'declare))
   "From the list of FORMS, return first the list of non-declaration forms, ~
 second the list of declaration-specifiers."
+  (assert (eq declare 'declare))
   (do (declarations
        (p forms (cdr p)))
       ((not (and (consp (car p)) (eq 'declare (caar p))))
@@ -206,9 +234,10 @@
     (dolist (d (cdar p))
       (push d declarations))))
 
-(defun parse-docstring-declarations-and-body (forms)
+(defun parse-docstring-declarations-and-body (forms &optional (declare 'declare))
   "From the list of FORMS, return first the list of non-declaration forms, ~
 second the list of declaration-specifiers, third any docstring."
+  (assert (eq declare 'declare))
   (if (or (not (cdr forms))
 	  (not (stringp (car forms))))
       (parse-declarations-and-body forms)
@@ -216,6 +245,14 @@
       (parse-declarations-and-body (cdr forms))
       (car forms))))
 
+(defun compute-function-block-name (function-name)
+  (cond
+   ((symbolp function-name) function-name)
+   ((and (consp function-name)
+	 (symbolp (cadr function-name)))
+    (cadr function-name))
+   (t (error "Unknown kind of function-name: ~S" function-name))))
+
 (defun declared-special-p (var declarations)
   (dolist (d declarations nil)
     (when (and (consp d)
@@ -552,23 +589,32 @@
       (let ((operator (car form)))
 	(when (symbolp operator)
 	  (let ((macrolet-binding (op-env-binding env operator +eval-binding-type-macrolet+)))
-	    (if macrolet-binding
-		(destructuring-bind (lambda-list &body body)
-		    (cddr macrolet-binding)
-		  (let ((expander (lambda (form env)
-				    (eval-form `(destructuring-bind (ignore-operator , at lambda-list)
-						    ',form
-						  (declare (ignore ignore-operator))
-						  , at body)
-					       env))))
-		    (values (funcall *macroexpand-hook* expander form env)
-			    t)))
+	    (if (not macrolet-binding)
 		(let ((macro-function (macro-function operator)))
 		  (if macro-function
 		      (values (funcall *macroexpand-hook* macro-function form env)
 			      t)
 		      (values form
-			      nil)))))))))
+			      nil)))
+		(let ((lambda-list (caddr macrolet-binding)))
+                  (multiple-value-bind (body declarations docstring)
+                      (parse-docstring-declarations-and-body (cdddr macrolet-binding))
+                    (declare (ignore docstring))
+                    (multiple-value-bind (destructuring-lambda-list whole-var env-var ignore-env ignore-operator)
+                        (parse-macro-lambda-list lambda-list)
+                      (let* ((form-var (or whole-var (gensym)))
+                             (expander (lambda (form env)
+                                         (eval-form `(let ((,form-var ',form)
+                                                           (,env-var ',env))
+                                                       (declare (ignore , at ignore-env))
+                                                       (destructuring-bind ,destructuring-lambda-list
+                                                           ,form-var
+                                                         (declare (ignore , at ignore-operator)
+                                                                  , at declarations)
+                                                         , at body))
+                                                    env))))
+                        (values (funcall *macroexpand-hook* expander form env)
+                                t)))))))))))
 
 (defun macroexpand (form &optional env)
   (do ((expanded-at-all-p nil)) (nil)
@@ -589,8 +635,10 @@
   (typecase form
     (boolean t)
     (keyword t)
-    (symbol nil)
-    (cons (eq 'quote (car form)))
+    (symbol
+     (symbol-constant-variable-p form))
+    (cons
+     (eq 'quote (car form)))
     (t t)))
 
 (defun macro-function (symbol &optional environment)