-(declaim (ftype (function ((or symbol cons)) t) proclaim-as-function-name))
-(defun proclaim-as-function-name (name)
- (check-function-name name)
- (when (fboundp name)
- (ecase (info :function :kind name)
- (:function
- (let ((accessor-for (info :function :accessor-for name)))
- (when accessor-for
- (compiler-style-warning
- "~@<The function ~
- ~2I~_~S ~
- ~I~_was previously defined as a slot accessor for ~
- ~2I~_~S.~:>"
- name
- accessor-for)
- (clear-info :function :accessor-for name))))
- (:macro
- (compiler-style-warning "~S was previously defined as a macro." name)
- (setf (info :function :where-from name) :assumed)
- (clear-info :function :macro-function name))
- ((nil))))
- (setf (info :function :kind name) :function)
- (note-if-setf-function-and-macro name)
- name)
+(defun proclaim-as-fun-name (name)
+
+ ;; legal name?
+ (check-fun-name 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
+ ;;
+ ;; (This could happen if someone executes PROCLAIM FTYPE at
+ ;; macroexpansion time, which is bad style, or at compile time, e.g.
+ ;; 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
+ (remhash name *free-funs*))
+
+ (note-if-setf-fun-and-macro name)
+
+ (values))