[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory cl-net:/tmp/cvs-serv17183

Modified Files:
	functions.lisp 
Log Message:
Add (setf funobj-type) and make-macro-function.


--- /project/movitz/cvsroot/movitz/losp/muerte/functions.lisp	2006/05/02 20:01:46	1.31
+++ /project/movitz/cvsroot/movitz/losp/muerte/functions.lisp	2009/07/19 18:58:33	1.32
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.31 2006/05/02 20:01:46 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.32 2009/07/19 18:58:33 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -79,6 +79,8 @@
 			 (compiled-function
 			  (funobj-name edx))
 			 (t '(unknown)))))
+;;     (when los0::*funbound-counter*
+;;       (incf (gethash function-name los0::*funbound-counter* 0)))
     (with-simple-restart (continue "Return NIL from ~S." function-name)
       (error 'undefined-function-call
 	     :name function-name
@@ -92,7 +94,13 @@
   (with-inline-assembly (:returns :untagged-fixnum-ecx)
     (:xorl :ecx :ecx)
     (:compile-form (:result-mode :eax) funobj)
-    (:movb (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:funobj-type)) :cl)))
+    (:movb (:eax (:offset movitz-funobj funobj-type)) :cl)))
+
+(defun (setf funobj-type) (type funobj)
+  (check-type funobj function)
+  (with-inline-assembly (:returns :untagged-fixnum-ecx)
+    (:compile-two-forms (:eax :untagged-fixnum-ecx) funobj type)
+    (:movb :cl (:eax (:offset movitz-funobj funobj-type)))))
 
 (defun funobj-code-vector (funobj)
   (check-type funobj function)
@@ -490,4 +498,16 @@
 
 (defun fmakunbound (function-name)
   (setf (fdefinition function-name)
-    (load-global-constant unbound-function)))
+    (load-global-constant unbound-function))
+  function-name)
+
+(defun make-macro-function (expander name)
+  "From a regular function, such as a (lambda (form env) ...), make a bona fide macro-function."
+  (let ((macro-function (install-funobj-name name
+                                             (lambda (&edx edx &optional form env (first-extra nil extras-p) &rest more-extras)
+                                               (declare (ignore first-extra more-extras))
+                                               (verify-macroexpand-call edx name extras-p)
+                                               (funcall expander form env)))))
+    (setf (funobj-type macro-function)
+          #.(bt:enum-value 'movitz::movitz-funobj-type :macro-function))
+    macro-function))