-(defun %fun-name (fun)
- (case (widetag-of fun)
- (#.sb!vm:closure-header-widetag
- (%simple-fun-name (%closure-fun fun)))
- ((#.sb!vm:simple-fun-header-widetag
- #.sb!vm:closure-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).
- (%simple-fun-name fun))
- (#.sb!vm:funcallable-instance-header-widetag
- (%simple-fun-name
- (funcallable-instance-fun fun)))))
-
-(defun (setf %fun-name) (new-name fun)
- (let ((widetag (widetag-of fun)))
- (case widetag
- ((#.sb!vm:simple-fun-header-widetag
- #.sb!vm:closure-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)))
- (when (and name (typep name '(or symbol cons)))
- (values (info :function :documentation name)))))
+(defun %fun-name (function)
+ (typecase function
+ #!+sb-eval
+ (sb!eval:interpreted-function
+ (sb!eval:interpreted-function-debug-name function))
+ (t
+ (%simple-fun-name (%fun-fun function)))))
+
+(defun (setf %fun-name) (new-value function)
+ (typecase function
+ #!+sb-eval
+ (sb!eval:interpreted-function
+ (setf (sb!eval:interpreted-function-debug-name function) new-value))
+ ;; FIXME: Eliding general funcallable-instances for now.
+ ((or simple-fun closure)
+ (setf (%simple-fun-name (%fun-fun function)) new-value)))
+ new-value)
+
+(defun %fun-doc (function)
+ (typecase function
+ #!+sb-eval
+ (sb!eval:interpreted-function
+ (sb!eval:interpreted-function-documentation function))
+ (t
+ (%simple-fun-doc (%fun-fun function)))))
+
+(defun (setf %fun-doc) (new-value function)
+ (declare (type (or null string) new-value))
+ (typecase function
+ #!+sb-eval
+ (sb!eval:interpreted-function
+ (setf (sb!eval:interpreted-function-documentation function) new-value))
+ ((or simple-fun closure)
+ (setf (%simple-fun-doc (%fun-fun function)) new-value)))
+ new-value)