[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

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

Modified Files:
	defmacro-bootstrap.lisp 
Log Message:
improved defmacro.


--- /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp	2008/04/21 19:38:48	1.4
+++ /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp	2008/04/27 19:37:08	1.5
@@ -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.4 2008/04/21 19:38:48 ffjeld Exp $
+;;;; $Id: defmacro-bootstrap.lisp,v 1.5 2008/04/27 19:37:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -17,9 +17,12 @@
   (`(muerte::defmacro/compile-time ,name ,lambda-list ,macro-body)))
 
 (muerte.cl:defmacro muerte.cl:in-package (name)
-  `(progn
-     (eval-when (:compile-toplevel)
-       (in-package ,(movitz::movitzify-package-name name)))))
+  (let ((movitz-package-name (movitz::movitzify-package-name name)))
+    `(progn
+       (eval-when (:compile-toplevel)
+	 (in-package ,movitz-package-name))
+       (eval-when (:execute)
+	 (set '*package* (find-package ',movitz-package-name))))))
 
 (in-package #:muerte)
 
@@ -37,7 +40,7 @@
     (multiple-value-bind (destructuring-lambda-list whole-var env-var ignore-env ignore-operator)
         (parse-macro-lambda-list lambda-list)
       (let* ((block-name (compute-function-block-name name))
-             (extras (gensym))
+             (extras (gensym "extras-"))
              (form-var (or whole-var
                            (gensym "form-"))))
         (cond
@@ -50,12 +53,13 @@
                                  (block ,block-name
                                    (numargs-case
                                     (2 (&edx edx &optional ,form-var ,env-var)
+				       (declare (ignore , at ignore-env))
                                        (verify-macroexpand-call edx ',name)
                                        (let ()
                                          (declare , at declarations)
                                          , at real-body))
                                     (t (&edx edx &optional ,form-var ,env-var &rest ,extras)
-                                       (declare (ignore ,form-var ,extras))
+                                       (declare (ignore ,form-var ,extras , at ignore-env))
                                        (verify-macroexpand-call edx ',name t))))
                                  :type :macro-function))
           (t `(make-named-function ,name
@@ -65,12 +69,13 @@
                                    (block ,block-name
                                      (numargs-case
                                       (2 (&edx edx ,form-var ,env-var)
+					 (declare (ignore , at ignore-env))
                                          (verify-macroexpand-call edx ',name)
                                          (destructuring-bind ,destructuring-lambda-list
                                              ,form-var
                                            (declare (ignore , at ignore-operator) , at declarations)
                                            , at real-body))
                                       (t (&edx edx &optional ,form-var ,env-var &rest ,extras)
-                                         (declare (ignore ,form-var ,extras))
+                                         (declare (ignore ,form-var ,extras , at ignore-env))
                                          (verify-macroexpand-call edx ',name t))))
                                    :type :macro-function)))))))