[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

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

Modified Files:
	eval.lisp 
Log Message:
Add macroexpand, macroexpand-1, and *macroexpand-hook*.


--- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp	2008/03/18 16:24:30	1.22
+++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp	2008/03/19 12:37:22	1.23
@@ -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.22 2008/03/18 16:24:30 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.23 2008/03/19 12:37:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -25,11 +25,15 @@
 (defun eval-form (form env)
   "3.1.2.1 Form Evaluation."
   (check-stack-limit)
-  (typecase form
-    (null nil)
-    (symbol (eval-symbol form env))
-    (cons (eval-cons form env))
-    (t form)))
+  (multiple-value-bind (macro-expansion expanded-p)
+      (macroexpand form env)
+    (if expanded-p
+	(eval-form macro-expansion env)
+	(typecase form
+	  (null nil)
+	  (symbol (eval-symbol form env))
+	  (cons (eval-cons form env))
+	  (t form)))))
 
 (defun env-binding (env var)
   ;; (warn "env: ~S in ~S" var env)
@@ -70,62 +74,58 @@
 
 (defun eval-cons (form env)
   "3.1.2.1.2 Conses as Forms"
-  (let ((macro-function (macro-function (car form))))
-    (if macro-function
-	(eval-form (funcall macro-function form nil)
-		   env)
-	(case (car form)
-	  (quote (cadr form))
-	  (function (eval-function (second form) env))
-	  (if (if (eval-form (second form) env)
-		  (eval-form (third form) env)
-		  (eval-form (fourth form) env)))
-	  (progn (eval-progn (cdr form) env))
-	  (prog1 (prog1 (eval-form (cadr form) env)
-		   (eval-progn (cddr form) env)))
-	  (tagbody (eval-tagbody form env))
-	  ((block)
-	   (catch form
-	     (eval-progn (cddr form)
-			 (cons (list* +eval-binding-type-block+
-				      (cadr form)
-				      form)
-			       env))))
-	  ((return-from)
-	   (let ((b (op-env-binding +eval-binding-type-block+ env  (cadr form))))
-	     (unless b (error "Block ~S is not visible." (cadr form)))
-	     (throw (cdr b)
-	       (eval-form (caddr form) env))))
-	  (go (eval-go form env))
-	  (setq (eval-setq form env))
-	  (setf (eval-setf form env))
-	  ((defvar) (eval-defvar form env))
-	  (let (eval-let (cadr form) (cddr form) env))
-	  ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env))
-	  ((lambda) (eval-function form env)) ; the lambda macro..
-	  ((multiple-value-bind)
-	   (eval-m-v-bind form env))
-	  ((multiple-value-prog1)
-	   (multiple-value-prog1 (eval-form (cadr form) env)
-	     (eval-progn (cddr form) env)))
-	  ((destructuring-bind)
-	   (eval-progn (cdddr form)
-		       (make-destructuring-env (cadr form)
-					       (eval-form (caddr form) env)
-					       env)))
-	  ((catch)
-	   (catch (eval-form (second form) env)
-	     (eval-progn (cddr form) env)))
-	  ((throw)
-	   (throw (eval-form (second form) env)
-	     (eval-form (third form) env)))
-	  ((unwind-protect)
-	   (unwind-protect
-		(eval-form (second form) env)
+  (case (car form)
+    (quote (cadr form))
+    (function (eval-function (second form) env))
+    (if (if (eval-form (second form) env)
+	    (eval-form (third form) env)
+	    (eval-form (fourth form) env)))
+    (progn (eval-progn (cdr form) env))
+    (prog1 (prog1 (eval-form (cadr form) env)
 	     (eval-progn (cddr form) env)))
-	  ((macrolet symbol-macrolet)
-	   (error "Special operator ~S not implemented in ~S." (car form) 'eval))
-	  (t (eval-funcall form env))))))
+    (tagbody (eval-tagbody form env))
+    ((block)
+     (catch form
+       (eval-progn (cddr form)
+		   (cons (list* +eval-binding-type-block+
+				(cadr form)
+				form)
+			 env))))
+    ((return-from)
+     (let ((b (op-env-binding +eval-binding-type-block+ env  (cadr form))))
+       (unless b (error "Block ~S is not visible." (cadr form)))
+       (throw (cdr b)
+	 (eval-form (caddr form) env))))
+    (go (eval-go form env))
+    (setq (eval-setq form env))
+    (setf (eval-setf form env))
+    ((defvar) (eval-defvar form env))
+    (let (eval-let (cadr form) (cddr form) env))
+    ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env))
+    ((lambda) (eval-function form env)) ; the lambda macro..
+    ((multiple-value-bind)
+     (eval-m-v-bind form env))
+    ((multiple-value-prog1)
+     (multiple-value-prog1 (eval-form (cadr form) env)
+       (eval-progn (cddr form) env)))
+    ((destructuring-bind)
+     (eval-progn (cdddr form)
+		 (make-destructuring-env (cadr form)
+					 (eval-form (caddr form) env)
+					 env)))
+    ((catch)
+     (catch (eval-form (second form) env)
+       (eval-progn (cddr form) env)))
+    ((throw)
+     (throw (eval-form (second form) env)
+       (eval-form (third form) env)))
+    ((unwind-protect)
+     (unwind-protect
+	  (eval-form (second form) env)
+       (eval-progn (cddr form) env)))
+    ((macrolet symbol-macrolet)
+     (error "Special operator ~S not implemented in ~S." (car form) 'eval))
+    (t (eval-funcall form env))))
 
 (defun eval-progn (forms env)
   (do ((p forms (cdr p)))
@@ -453,6 +453,24 @@
 	      (setf (symbol-function name) function))
 	    t nil)))
 
+(defun macroexpand-1 (form &optional env)
+  (if (atom form)
+      (values form nil)
+      (let ((macro-function (macro-function (car form))))
+	(if macro-function
+	    (values (funcall *macroexpand-hook* macro-function form env)
+		    t)
+	    (values form
+		    nil)))))
+
+(defun macroexpand (form &optional env)
+  (do ((expanded-at-all-p nil)) (nil)
+    (multiple-value-bind (expansion expanded-p)
+	(macroexpand-1 form env)
+      (when (not expanded-p)
+	(return (values expansion expanded-at-all-p)))
+      (setf form expansion
+	    expanded-at-all-p t))))
 
 (defun proclaim (declaration)
   ;; What do do?