[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

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

Modified Files:
	basic-macros.lisp 
Log Message:
Have macros in the run-time.


--- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp	2007/03/26 21:11:40	1.70
+++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp	2008/03/15 20:57:16	1.71
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: basic-macros.lisp,v 1.70 2007/03/26 21:11:40 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.71 2008/03/15 20:57:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -28,29 +28,59 @@
 
 (in-package muerte)
 
-(defmacro defmacro (name lambda-list &body macro-body)
+(defmacro defmacro/cross-compilation (name lambda-list &body body)
   `(progn
-     (defmacro-compile-time ,name ,lambda-list ,macro-body)
-     #+ignore
-     (eval-when (:compile-toplevel)
-       (let ((name (intern (symbol-name ',name))))
-	 (when (eq (symbol-package name)
-		   (find-package 'muerte.common-lisp))
-	   ;; (warn "setting ~S" name)
-	   (setf (movitz:movitz-env-get name 'macro-expansion)
-	     (list* 'lambda ',lambda-list
-		    ',macro-body)))))
+     (defmacro-compile-time ,name ,lambda-list ,body)
      ',name))
 
+(defmacro defmacro (name lambda-list &body body)
+  `(defmacro/cross-compilation ,name ,lambda-list , at body))
+
+(defmacro defmacro/runtime (name lambda-list &body body)
+  (multiple-value-bind (real-body declarations docstring)
+      (movitz::parse-docstring-declarations-and-body body 'cl:declare)
+    (let* ((block-name (compute-function-block-name name))
+	   (ignore-var (gensym))
+	   (form-var (gensym "form-"))
+	   (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))))))
+      (multiple-value-bind (env-var ignore-env)
+	  (if env-var
+	      (values env-var nil)
+	      (let ((e (gensym)))
+		(values e (list e))))
+	`(make-named-function ,name
+			      (&edx edx &optional ,form-var ,env-var &rest ,ignore-var)
+			      ((ignore ,ignore-var , at ignore-env))
+			      ,docstring
+			      (block ,block-name
+				(verify-macroexpand-call edx ',name)
+				(destructuring-bind ,destructuring-lambda-list
+				    ,form-var
+				  (declare (ignore ,operator-var) , at declarations)
+				  , at real-body))
+			      :type :macro-function)))))
+
 (defmacro defun (function-name lambda-list &body body)
   "Define a function."
-;;;  (warn "defun ~S.." function-name)
   (multiple-value-bind (real-body declarations docstring)
       (movitz::parse-docstring-declarations-and-body body 'cl:declare)
     (let ((block-name (compute-function-block-name function-name)))
       `(progn
-	 (make-named-function ,function-name ,lambda-list
-			      ,declarations ,docstring
+	 (make-named-function ,function-name
+			      ,lambda-list
+			      ,declarations
+			      ,docstring
 			      (block ,block-name , at real-body))
 	 ',function-name))))
 
@@ -1078,7 +1108,7 @@
        (:halt)
        (:jmp ',infinite-loop-label))))
 
-(defmacro function-name-or-nil ()
+(define-compiler-macro function-name-or-nil ()
   (let ((function-name-not-found-label (gensym)))
     `(with-inline-assembly (:returns :eax)
        (:movl :edi :eax)