[movitz-cvs] CVS update: movitz/special-operators.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv15680

Modified Files:
	special-operators.lisp 
Log Message:
Use newly created movitz-macro-expander-make-function.

Date: Thu Jan 15 11:40:40 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.1.1.1 movitz/special-operators.lisp:1.2
--- movitz/special-operators.lisp:1.1.1.1	Tue Jan 13 06:04:59 2004
+++ movitz/special-operators.lisp	Thu Jan 15 11:40:40 2004
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.1.1.1 2004/01/13 11:04:59 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.2 2004/01/15 16:40:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -344,19 +344,22 @@
 	    (parse-docstring-declarations-and-body cl-macro-body 'cl:declare)
 	  (declare (ignore doc-string))
 	  (setf (movitz-env-get access-fn :setf-expander nil)
-	    (let ((form-formal (or wholevar (gensym)))
-		  (env-formal (or envvar (gensym))))
-	      (if (null cl-lambda-list)
-		  `(lambda (,form-formal ,env-formal)
-		     (declare , at declarations)
-		     (translate-program (block ,access-fn , at cl-body) :cl :muerte.cl))
-		`(lambda (,form-formal ,env-formal)
-		   (declare , at declarations)
-		   (destructuring-bind ,cl-lambda-list
-		       (translate-program (rest ,form-formal) :muerte.cl :cl)
-		     (values-list
-		      (translate-program (multiple-value-list (block ,access-fn , at cl-body))
-					 :cl :muerte.cl)))))))))))
+	    (let* ((form-formal (or wholevar (gensym)))
+		   (env-formal (or envvar (gensym)))
+		   (expander (if (null cl-lambda-list)
+				 `(lambda (,form-formal ,env-formal)
+				    (declare (ignorable ,form-formal ,env-formal)
+					     , at declarations)
+				    (translate-program (block ,access-fn , at cl-body) :cl :muerte.cl))
+			       `(lambda (,form-formal ,env-formal)
+				  (declare (ignorable ,form-formal ,env-formal)
+					   , at declarations)
+				  (destructuring-bind ,cl-lambda-list
+				      (translate-program (rest ,form-formal) :muerte.cl :cl)
+				    (values-list
+				     (translate-program (multiple-value-list (block ,access-fn , at cl-body))
+							:cl :muerte.cl)))))))
+	      (movitz-macro-expander-make-function expander :type :setf)))))))
   (compiler-values ()))
 
 (define-special-operator muerte::defmacro-compile-time (&form form)
@@ -396,9 +399,9 @@
 			  (declare , at declarations)
 			  (translate-program  (block ,name , at cl-body) :cl :muerte.cl)))))))
 	    (setf (movitz-macro-function name)
-	      (if *compiler-compile-macro-expanders*
-		  (compile expander-name expander-lambda)
-		expander-lambda)))))))
+	      (movitz-macro-expander-make-function expander-lambda
+						   :name expander-name
+						   :type :defmacro)))))))
   (compiler-values ()))
 
 (define-special-operator muerte::define-compiler-macro-compile-time (&form form)
@@ -438,9 +441,9 @@
 			      ,form-formal ; declined
 			    (translate-program ,expansion-var :cl :muerte.cl)))))))
 	      (setf (movitz-compiler-macro-function operator-name nil)
-		(if *compiler-compile-macro-expanders*
-		    (compile (make-symbol (format nil "~A-compiler-macro" name)) expander)
-		  expander))))))))
+		(movitz-macro-expander-make-function expander
+						     :name (gensym (format nil "~A-compiler-macro-" name))
+						     :type :compiler-macro))))))))
   (compiler-values ()))
 
 (define-special-operator muerte::with-inline-assembly-case