-;;; cobbled from stuff in describe.lisp.
-(defun function-doc (x)
- (let ((name
- (case (get-type x)
- (#.sb!vm:closure-header-type
- (%function-name (%closure-function x)))
- ((#.sb!vm:function-header-type #.sb!vm:closure-function-header-type)
- (%function-name x))
- (#.sb!vm:funcallable-instance-header-type
- (typecase x
- (byte-function
- (sb!c::byte-function-name x))
- (byte-closure
- (sb!c::byte-function-name (byte-closure-function x)))
- #!+sb-interpreter
- (sb!eval:interpreted-function
- (multiple-value-bind (exp closure-p dname)
- (sb!eval:interpreted-function-lambda-expression x)
- (declare (ignore exp closure-p))
- dname))
- (t ;; funcallable-instance
- (%function-name
- (funcallable-instance-function x))))))))
+;;; a SETFable function to return the associated debug name for FUN
+;;; (i.e., the third value returned from CL:FUNCTION-LAMBDA-EXPRESSION),
+;;; or NIL if there's none
+(defun %fun-name (function)
+ (%simple-fun-name (%fun-fun function)))
+
+(defun %fun-type (function)
+ (%simple-fun-type (%fun-fun function)))
+
+(defun (setf %fun-name) (new-name fun)
+ (aver nil) ; since this is unsafe 'til bug 137 is fixed
+ (let ((widetag (widetag-of fun)))
+ (case widetag
+ (#.sb!vm:simple-fun-header-widetag
+ ;; KLUDGE: The pun that %SIMPLE-FUN-NAME is used for closure
+ ;; functions is left over from CMU CL (modulo various renaming
+ ;; that's gone on since the fork).
+ (setf (%simple-fun-name fun) new-name))
+ (#.sb!vm:closure-header-widetag
+ ;; FIXME: It'd be nice to be able to set %FUN-NAME here on
+ ;; per-closure basis. Instead, we are still using the CMU CL
+ ;; approach of closures being named after their closure
+ ;; function, which doesn't work right e.g. for structure
+ ;; accessors, and might not be quite right for DEFUN
+ ;; in a non-null lexical environment either.
+ ;; When/if weak hash tables become supported
+ ;; again, it'll become easy to fix this, but for now there
+ ;; seems to be no easy way (short of the ugly way of adding a
+ ;; slot to every single closure header), so we don't.
+ ;;
+ ;; Meanwhile, users might encounter this problem by doing DEFUN
+ ;; in a non-null lexical environment, so we try to give a
+ ;; reasonably meaningful user-level "error" message (but only
+ ;; as a warning because this is optional debugging
+ ;; functionality anyway, not some hard ANSI requirement).
+ (warn "can't set name for closure, leaving name unchanged"))
+ (t
+ ;; The other function subtype names are also un-settable
+ ;; but this problem seems less likely to be tickled by
+ ;; user-level code, so we can give a implementor-level
+ ;; "error" (warning) message.
+ (warn "can't set function name ((~S function)=~S), leaving it unchanged"
+ 'widetag-of widetag))))
+ new-name)
+
+(defun %fun-doc (x)
+ ;; FIXME: This business of going through %FUN-NAME and then globaldb
+ ;; is the way CMU CL did it, but it doesn't really seem right.
+ ;; When/if weak hash tables become supported again, using a weak
+ ;; hash table to maintain the object/documentation association would
+ ;; probably be better.
+ (let ((name (%fun-name x)))