-(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)