X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Finfo-functions.lisp;h=d763505a4fe408c836324c40891da9f2dfb94d4a;hb=69e6aef5e6fb3bd682c7a2cbf774034d2ea58ee8;hp=293b123ef559cf12ab9831088f5c5634a35e6107;hpb=c593dc26733b179db6c12c7085ed76b762ac256b;p=sbcl.git diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index 293b123..d763505 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -41,15 +41,28 @@ ;; legal name? (check-fun-name name) - ;; scrubbing old data I: possible collision with old definition - (when (fboundp name) - (ecase (info :function :kind name) - (:function) ; happy case - ((nil)) ; another happy case - (:macro ; maybe-not-so-good case - (compiler-style-warn "~S was previously defined as a macro." name) - (setf (info :function :where-from name) :assumed) - (clear-info :function :macro-function name)))) + + ;; KLUDGE: This can happen when eg. compiling a NAMED-LAMBDA, and isn't + ;; guarded against elsewhere -- so we want to assert package locks here. The + ;; reason we do it only when stomping on existing stuff is because we want + ;; to keep + ;; (WITHOUT-PACKAGE-LOCKS (DEFUN LOCKED:FOO ...)) + ;; viable, which requires no compile-time violations in the harmless cases. + (with-single-package-locked-error () + (flet ((assert-it () + (assert-symbol-home-package-unlocked name "proclaiming ~S as a function"))) + + (let ((kind (info :function :kind name))) + ;; scrubbing old data I: possible collision with a macro + (when (and (fboundp name) (eq :macro kind)) + (assert-it) + (compiler-style-warn "~S was previously defined as a macro." name) + (setf (info :function :where-from name) :assumed) + (clear-info :function :macro-function name)) + + (unless (eq :function kind) + (assert-it) + (setf (info :function :kind name) :function))))) ;; scrubbing old data II: dangling forward references ;; @@ -58,11 +71,9 @@ ;; in EVAL-WHEN (:COMPILE) inside something like DEFSTRUCT, in which ;; case it's reasonable style. Either way, NAME is no longer a free ;; function.) - (when (boundp '*free-funs*) ; when compiling + (when (boundp '*free-funs*) ; when compiling (remhash name *free-funs*)) - ;; recording the ordinary case - (setf (info :function :kind name) :function) (note-if-setf-fun-and-macro name) (values)) @@ -74,9 +85,10 @@ ;;; can't assume that they aren't just naming a function (SETF FOO) ;;; for the heck of it. NAME is already known to be well-formed. (defun note-if-setf-fun-and-macro (name) - (when (consp name) - (when (or (info :setf :inverse name) - (info :setf :expander name)) + (when (and (consp name) + (eq (car name) 'setf)) + (when (or (info :setf :inverse (second name)) + (info :setf :expander (second name))) (compiler-style-warn "defining as a SETF function a name that already has a SETF macro:~ ~% ~S" @@ -95,6 +107,7 @@ (frob :where-from :assumed) (frob :inlinep) (frob :kind) + (frob :macro-function) (frob :inline-expansion-designator) (frob :source-transform) (frob :structure-accessor) @@ -130,14 +143,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)) @@ -151,19 +161,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) @@ -226,11 +237,13 @@ return NIL. Can be set with SETF when ENV is NIL." (variable (typecase x (symbol (values (info :variable :documentation x))))) + ;; FUNCTION is not used at the momemnt, just here for symmetry. (function (cond ((functionp x) (%fun-doc x)) - ((legal-fun-name-p x) - (values (info :function :documentation x))))) + ((and (legal-fun-name-p x) (fboundp x)) + (%fun-doc (or (and (symbolp x) (macro-function x)) + (fdefinition x)))))) (structure (typecase x (symbol (cond @@ -259,8 +272,12 @@ return NIL. Can be set with SETF when ENV is NIL." (case doc-type (variable (setf (info :variable :documentation name) string)) (function - (when (legal-fun-name-p name) - (setf (info :function :documentation name) string))) + ;; KLUDGE: FDEFINITION isn't ready early enough during cold-init, so + ;; special case for symbols. + (if (symbolp name) + (setf (%fun-doc (symbol-function name)) string) + (when (legal-fun-name-p name) + (setf (%fun-doc (fdefinition name)) string)))) (structure (cond ((eq (info :type :kind name) :instance) (setf (info :type :documentation name) string))