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@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))