(frob :where-from :assumed)
(frob :inlinep)
(frob :kind)
+ (frob :macro-function)
(frob :inline-expansion-designator)
(frob :source-transform)
(frob :structure-accessor)
(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))
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)