;; 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
;;
;; 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))
;;; 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"
(frob :where-from :assumed)
(frob :inlinep)
(frob :kind)
+ (frob :macro-function)
(frob :inline-expansion-designator)
(frob :source-transform)
+ (frob :structure-accessor)
(frob :assumed-type)))
(values))
(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)
;;; all the BDOCUMENTATION entries in a *BDOCUMENTATION* hash table
;;; and slamming them into PCL once PCL gets going.
(defun fdocumentation (x doc-type)
- (flet ((try-cmucl-random-doc (x doc-type)
- (declare (symbol doc-type))
- (cdr (assoc doc-type
- (values (info :random-documentation :stuff x))))))
- (case doc-type
- (variable
- (typecase x
- (symbol (values (info :variable :documentation x)))))
- (function
- (cond ((functionp x)
- (%fun-doc x))
- ((legal-fun-name-p x)
- ;; FIXME: Is it really right to make
- ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to
- ;; (DOCUMENTATION 'FOO 'FUNCTION)? That's what CMU CL
- ;; did, so we do it, but I'm not sure it's what ANSI wants.
- (values (info :function :documentation
- (fun-name-block-name x))))))
- (structure
- (typecase x
- (symbol (cond
- ((eq (info :type :kind x) :instance)
- (values (info :type :documentation x)))
- ((info :typed-structure :info x)
- (values (info :typed-structure :documentation x)))))))
- (type
- (typecase x
- (structure-class (values (info :type :documentation (class-name x))))
- (t (and (typep x 'symbol) (values (info :type :documentation x))))))
- (setf (values (info :setf :documentation x)))
- ((t)
- (typecase x
- (function (%fun-doc x))
- (package (package-doc-string x))
- (structure-class (values (info :type :documentation (class-name x))))
- (symbol (try-cmucl-random-doc x doc-type))))
- (t
- (typecase x
- ;; FIXME: This code comes from CMU CL, but
- ;; TRY-CMUCL-RANDOM-DOC doesn't seem to be defined anywhere
- ;; in CMU CL. Perhaps it could be defined by analogy with the
- ;; corresponding SETF FDOCUMENTATION code.
- (symbol (try-cmucl-random-doc x doc-type)))))))
+ (case doc-type
+ (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))
+ ((and (legal-fun-name-p x) (fboundp x))
+ (%fun-doc (or (and (symbolp x) (macro-function x))
+ (fdefinition x))))))
+ (structure
+ (typecase x
+ (symbol (cond
+ ((eq (info :type :kind x) :instance)
+ (values (info :type :documentation x)))
+ ((info :typed-structure :info x)
+ (values (info :typed-structure :documentation x)))))))
+ (type
+ (typecase x
+ (structure-class (values (info :type :documentation (class-name x))))
+ (t (and (typep x 'symbol) (values (info :type :documentation x))))))
+ (setf (values (info :setf :documentation x)))
+ ((t)
+ (typecase x
+ (function (%fun-doc x))
+ (package (package-doc-string x))
+ (structure-class (values (info :type :documentation (class-name x))))
+ ((or symbol cons)
+ (random-documentation x doc-type))))
+ (t
+ (when (typep x '(or symbol cons))
+ (random-documentation x doc-type)))))
+
(defun (setf fdocumentation) (string name doc-type)
- ;; FIXME: I think it should be possible to set documentation for
- ;; things (e.g. compiler macros) named (SETF FOO). fndb.lisp
- ;; declares DOC-TYPE to be a SYMBOL, which contradicts that. What
- ;; should be done?
+ (declare (type (or null string) string))
(case doc-type
(variable (setf (info :variable :documentation name) string))
- (function (setf (info :function :documentation name) string))
+ (function
+ ;; 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))
((info :typed-structure :info name)
- (setf (info :typed-structure :documentation name) string))
- (t
- (error "~S is not a structure name." name))))
+ (setf (info :typed-structure :documentation name) string))))
(type (setf (info :type :documentation name) string))
(setf (setf (info :setf :documentation name) string))
(t
- (let ((pair (assoc doc-type (info :random-documentation :stuff name))))
- (if pair
- (setf (cdr pair) string)
- (push (cons doc-type string)
- (info :random-documentation :stuff name))))))
+ (when (typep name '(or symbol cons))
+ (setf (random-documentation name doc-type) string))))
string)
+
+(defun random-documentation (name type)
+ (cdr (assoc type (info :random-documentation :stuff name))))
+
+(defun (setf random-documentation) (new-value name type)
+ (let ((pair (assoc type (info :random-documentation :stuff name))))
+ (if pair
+ (setf (cdr pair) new-value)
+ (push (cons type new-value)
+ (info :random-documentation :stuff name))))
+ new-value)
projects / sbcl.git / blobdiff