X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Finfo-functions.lisp;h=ea876b7c16ab32340cc1edfb0886dc8a0d0d11ce;hb=74cf7a4d01664fbf72a662ba093ad67ca243b524;hp=c0d94220fa43c1ba13a0517240a7487a23fd88fc;hpb=7448b6225fa43ea6a61391990b173c09505ba45d;p=sbcl.git

diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp
index c0d9422..ea876b7 100644
--- a/src/compiler/info-functions.lisp
+++ b/src/compiler/info-functions.lisp
@@ -106,6 +106,7 @@
       (frob :where-from :assumed)
       (frob :inlinep)
       (frob :kind)
+      (frob :macro-function)
       (frob :inline-expansion-designator)
       (frob :source-transform)
       (frob :structure-accessor)
@@ -141,14 +142,11 @@ only."
   (declare (symbol symbol))
   (let* ((fenv (when env (lexenv-funs env)))
          (local-def (cdr (assoc symbol fenv))))
-    (cond (local-def
-           (if (and (consp local-def) (eq (car local-def) 'macro))
-               (cdr local-def)
-               nil))
-          ((eq (info :function :kind symbol) :macro)
-           (values (info :function :macro-function symbol)))
-          (t
-           nil))))
+    (if local-def
+        (if (and (consp local-def) (eq (car local-def) 'macro))
+            (cdr local-def)
+            nil)
+        (values (info :function :macro-function symbol)))))
 
 (defun (setf sb!xc:macro-function) (function symbol &optional environment)
   (declare (symbol symbol) (type function function))
@@ -162,19 +160,20 @@ only."
            symbol environment))
   (when (eq (info :function :kind symbol) :special-form)
     (error "~S names a special form." symbol))
-  (setf (info :function :kind symbol) :macro)
-  (setf (info :function :macro-function symbol) function)
-  ;; This is a nice thing to have in the target SBCL, but in the
-  ;; cross-compilation host it's not nice to mess with
-  ;; (SYMBOL-FUNCTION FOO) where FOO might be a symbol in the
-  ;; cross-compilation host's COMMON-LISP package.
-  #-sb-xc-host
-  (setf (symbol-function symbol)
-        (lambda (&rest args)
-          (declare (ignore args))
-          ;; (ANSI specification of FUNCALL says that this should be
-          ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.)
-          (error 'undefined-function :name symbol)))
+  (with-single-package-locked-error (:symbol symbol "setting the macro-function of ~S")
+    (setf (info :function :kind symbol) :macro)
+    (setf (info :function :macro-function symbol) function)
+    ;; This is a nice thing to have in the target SBCL, but in the
+    ;; cross-compilation host it's not nice to mess with
+    ;; (SYMBOL-FUNCTION FOO) where FOO might be a symbol in the
+    ;; cross-compilation host's COMMON-LISP package.
+    #-sb-xc-host
+    (setf (symbol-function symbol)
+          (lambda (&rest args)
+            (declare (ignore args))
+            ;; (ANSI specification of FUNCALL says that this should be
+            ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.)
+            (error 'undefined-function :name symbol))))
   function)
 
 (defun fun-locally-defined-p (name env)