(declare (type fdefn fdefn))
(fdefn-name fdefn))
-(defun fdefn-function (fdefn)
+(defun fdefn-fun (fdefn)
(declare (type fdefn fdefn)
- (values (or function null)))
- (fdefn-function fdefn))
+ (values (or function null)))
+ (fdefn-fun fdefn))
-(defun (setf fdefn-function) (fun fdefn)
+(defun (setf fdefn-fun) (fun fdefn)
(declare (type function fun)
- (type fdefn fdefn)
- (values function))
- (setf (fdefn-function fdefn) fun))
+ (type fdefn fdefn)
+ (values function))
+ (setf (fdefn-fun fdefn) fun))
(defun fdefn-makunbound (fdefn)
(declare (type fdefn fdefn))
(dolist (fdefn *!initial-fdefn-objects*)
(setf (info :function :definition (fdefn-name fdefn)) fdefn)))
+;;; Return the fdefn object for NAME. If it doesn't already exist and
+;;; CREATE is non-NIL, create a new (unbound) one.
(defun fdefinition-object (name create)
- #!+sb-doc
- "Return the fdefn object for NAME. If it doesn't already exist and CREATE
- is non-NIL, create a new (unbound) one."
(declare (values (or fdefn null)))
- (unless (or (symbolp name)
- (and (consp name)
- (eq (car name) 'setf)
- (let ((cdr (cdr name)))
- (and (consp cdr)
- (symbolp (car cdr))
- (null (cdr cdr))))))
- (error 'simple-type-error
- :datum name
- :expected-type '(or symbol list)
- :format-control "invalid function name: ~S"
- :format-arguments (list name)))
+ (legal-fun-name-or-type-error name)
(let ((fdefn (info :function :definition name)))
(if (and (null fdefn) create)
- (setf (info :function :definition name) (make-fdefn name))
- fdefn)))
+ (setf (info :function :definition name) (make-fdefn name))
+ fdefn)))
-;;; FIXME: If the fundamental operation performed when
-;;; funcalling a symbol is %COERCE-NAME-TO-FUNCTION, which expands into
-;;; FDEFINITION-OBJECT, which does (INFO :FUNCTION :DEFINITION NAME),
-;;; that's a horrendously heavyweight way to implement SYMBOL-FUNCTION.
-;;; What compelling reason is there for all this hairiness? The only
-;;; thing I can think of is that it does give a place to store
-;;; SETF functions, but I don't think that's a good enough reason.
-;;; It might even be that the FDEFINITION arrangement saves a little
-;;; space, if the proportion of function-less symbols is high enough,
-;;; but I don't think that's a good enough reason, either.
-;;; I'd really like to wipe out FDEFN stuff root and branch, and
-;;; just store SETF functions in the symbol property list.
-;;;
-;;; One problem with just doing the simple thing: What happens when
-;;; people call symbols which have no function definitions?
-;;; 1. Just hit "undefined function" error -- with no clue as to
-;;; what undefined function it was. (This might actually not be
-;;; too horrible, since the compiler warns you about undefined
-;;; functions and the debugger aims, with incomplete success,
-;;; to show you what form caused an error.)
-;;; 2. various solutions involving closures in the function slot,
-;;; all of which have the drawback of extra memory use and extra
-;;; difficulty in detecting when functions are undefined
-;;; 2a. Have every single symbol have an undefined function closure
-;;; which points back to it to tell you which undefined symbol it
-;;; was. (4 extra words per undefined symbol)
-;;; 2b. Play tricks with FDEFINITION, where the default SYMBOL-FUNCTION
-;;; for any function is an anonymous "undefined function" error
-;;; which doesn't tell you what the problem was, but if FDEFINITION
-;;; is ever called on an undefined symbol, it helpfully changes the
-;;; function definition to point to a closure which knows which
-;;; symbol caused the problem.
-;;; 4. Just don't sweat it except when DEBUG>SPEED, where the calling
-;;; convention gets tweaked to test for the undefined-function
-;;; function at call time and bail out with helpful information
-;;; if it's there.
-;;; 5. Require that the function calling convention be stereotyped
-;;; along the lines of
-;;; mov %ebx, local_immediate_3 ; Point to symbol.
-;;; mov %eax, symbol_function_offset(%eax) ; Point to function.
-;;; call *function_code_pointer(%eax) ; Go.
-;;; That way, it's guaranteed that on entry to a function, %EBX points
-;;; back to the symbol which was used to indirect into the function,
-;;; so the undefined function handler can base its complaint on that.
-;;;
-;;; Another problem with doing the simple thing: people will want to
-;;; indirect through something in order to get to SETF functions, in
-;;; order to be able to redefine them. What will they indirect
-;;; through? This could be done with a hack, making an anonymous
-;;; symbol and linking it to the main symbol's SB!KERNEL:SETF-FUNCTION
-;;; property. The anonymous symbol could even point back to the symbol
-;;; it's the SETF function for, so that if the SETF function was
-;;; undefined at the time a call was made, the debugger could say
-;;; which function caused the problem. It'd probably be cleaner,
-;;; though, to use a new type of primitive object (SYMBOLOID?)
-;;; instead. It could probably be like symbol except that its name
-;;; could be any object and its value points back to the symbol which
-;;; owns it. Then the setf functions for FOO could be on the list (GET
-;;; FOO 'SB!KERNEL:SYMBOLOIDS)
-;;;
-;;; FIXME: Oh, my. Now that I've started thinking about it, I
-;;; appreciate more fully how weird and twisted FDEFNs might be. Look
-;;; at the calling sequence for full calls. It goes and reads the
-;;; address of a function object from its own table of immediate
-;;; values, then jumps into that. Consider how weird that is. Not only
-;;; is it not doing indirection through a symbol (which I'd already
-;;; realized) but it's not doing indirection through
+(defun maybe-clobber-ftype (name)
+ (unless (eq :declared (info :function :where-from name))
+ (clear-info :function :type name)))
-;;; The compiler emits calls to this when someone tries to funcall a symbol.
-(defun %coerce-name-to-function (name)
- #!+sb-doc
- "Returns the definition for name, including any encapsulations. Settable
- with SETF."
+;;; Return the fdefinition of NAME, including any encapsulations.
+;;; The compiler emits calls to this when someone tries to FUNCALL
+;;; something. SETFable.
+#!-sb-fluid (declaim (inline %coerce-name-to-fun))
+(defun %coerce-name-to-fun (name)
(let ((fdefn (fdefinition-object name nil)))
- (or (and fdefn (fdefn-function fdefn))
- (error 'undefined-function :name name))))
+ (or (and fdefn (fdefn-fun fdefn))
+ (error 'undefined-function :name name))))
+(defun (setf %coerce-name-to-fun) (function name)
+ (maybe-clobber-ftype name)
+ (let ((fdefn (fdefinition-object name t)))
+ (setf (fdefn-fun fdefn) function)))
-(defun %coerce-callable-to-function (callable)
+(defun %coerce-callable-to-fun (callable)
(if (functionp callable)
callable
- (%coerce-name-to-function callable)))
-
-;;; This is just another name for %COERCE-NAME-TO-FUNCTION.
-#!-sb-fluid (declaim (inline raw-definition))
-(defun raw-definition (name)
- ;; We know that we are calling %COERCE-NAME-TO-FUNCTION, so don't remind us.
- (declare (optimize (inhibit-warnings 3)))
- (%coerce-name-to-function name))
-(defun (setf raw-definition) (function name)
- (let ((fdefn (fdefinition-object name t)))
- (setf (fdefn-function fdefn) function)))
-
-;;; FIXME: There seems to be no good reason to have both
-;;; %COERCE-NAME-TO-FUNCTION and RAW-DEFINITION names for the same
-;;; thing. And despite what the doc string of %COERCE-NAME-TO-FUNCTION
-;;; says, it's doesn't look settable. Perhaps we could collapse
-;;; %COERCE-TO-FUNCTION, RAW-DEFINITION, and (SETF RAW-DEFINITION)
-;;; into RAW-FDEFINITION and (SETF RAW-FDEFINITION), or
-;;; OUTER-FDEFINITION and (SETF OUTER-FDEFINITION).
+ (%coerce-name-to-fun callable)))
\f
;;;; definition encapsulation
(defstruct (encapsulation-info (:constructor make-encapsulation-info
- (type definition)))
+ (type definition))
+ (:copier nil))
;; This is definition's encapsulation type. The encapsulated
- ;; definition is in the previous encapsulation-info element or
+ ;; definition is in the previous ENCAPSULATION-INFO element or
;; installed as the global definition of some function name.
type
;; the previous, encapsulated definition. This used to be installed
;; replaced by an encapsulation of type TYPE.
(definition nil :type function))
-;;; We must bind and close over info. Consider the case where we
-;;; encapsulate (the second) an encapsulated (the first) definition,
-;;; and later someone unencapsulates the encapsulated (first)
-;;; definition. We don't want our encapsulation (second) to bind
-;;; basic-definition to the encapsulated (first) definition when it no
-;;; longer exists. When unencapsulating, we make sure to clobber the
-;;; appropriate info structure to allow basic-definition to be bound
-;;; to the next definition instead of an encapsulation that no longer
-;;; exists.
+;;; Replace the definition of NAME with a function that binds NAME's
+;;; arguments to a variable named ARG-LIST, binds name's definition
+;;; to a variable named BASIC-DEFINITION, and evaluates BODY in that
+;;; context. TYPE is whatever you would like to associate with this
+;;; encapsulation for identification in case you need multiple
+;;; encapsulations of the same name.
(defun encapsulate (name type body)
- #!+sb-doc
- "Replaces the definition of NAME with a function that binds name's arguments
- a variable named argument-list, binds name's definition to a variable named
- basic-definition, and evaluates BODY in that context. TYPE is
- whatever you would like to associate with this encapsulation for
- identification in case you need multiple encapsuations of the same name."
(let ((fdefn (fdefinition-object name nil)))
- (unless (and fdefn (fdefn-function fdefn))
+ (unless (and fdefn (fdefn-fun fdefn))
(error 'undefined-function :name name))
- (let ((info (make-encapsulation-info type (fdefn-function fdefn))))
- (setf (fdefn-function fdefn)
- #'(lambda (&rest argument-list)
- (declare (special argument-list))
- (let ((basic-definition (encapsulation-info-definition info)))
- (declare (special basic-definition))
- (eval body)))))))
+ (when (typep (fdefn-fun fdefn) 'generic-function)
+ (return-from encapsulate
+ (encapsulate-generic-function (fdefn-fun fdefn) type body)))
+ ;; We must bind and close over INFO. Consider the case where we
+ ;; encapsulate (the second) an encapsulated (the first)
+ ;; definition, and later someone unencapsulates the encapsulated
+ ;; (first) definition. We don't want our encapsulation (second) to
+ ;; bind basic-definition to the encapsulated (first) definition
+ ;; when it no longer exists. When unencapsulating, we make sure to
+ ;; clobber the appropriate INFO structure to allow
+ ;; basic-definition to be bound to the next definition instead of
+ ;; an encapsulation that no longer exists.
+ (let ((info (make-encapsulation-info type (fdefn-fun fdefn))))
+ (setf (fdefn-fun fdefn)
+ (named-lambda encapsulation (&rest arg-list)
+ (declare (special arg-list))
+ (let ((basic-definition (encapsulation-info-definition info)))
+ (declare (special basic-definition))
+ (eval body)))))))
-;;; Finds the encapsulation info that has been closed over.
+;;; This is like FIND-IF, except that we do it on a compiled closure's
+;;; environment.
+(defun find-if-in-closure (test closure)
+ (declare (closure closure))
+ (do-closure-values (value closure)
+ (when (funcall test value)
+ (return value))))
+
+;;; Find the encapsulation info that has been closed over.
(defun encapsulation-info (fun)
- (and (functionp fun)
- (= (get-type fun) sb!vm:closure-header-type)
- (find-if-in-closure #'encapsulation-info-p fun)))
+ (when (closurep fun)
+ (find-if-in-closure #'encapsulation-info-p fun)))
;;; When removing an encapsulation, we must remember that
;;; encapsulating definitions close over a reference to the
-;;; encapsulation-info that describes the encapsulating definition.
+;;; ENCAPSULATION-INFO that describes the encapsulating definition.
;;; When you find an info with the target type, the previous info in
;;; the chain has the ensulating definition of that type. We take the
;;; encapsulated definition from the info with the target type, and we
#!+sb-doc
"Removes NAME's most recent encapsulation of the specified TYPE."
(let* ((fdefn (fdefinition-object name nil))
- (encap-info (encapsulation-info (fdefn-function fdefn))))
+ (encap-info (encapsulation-info (fdefn-fun fdefn))))
(declare (type (or encapsulation-info null) encap-info))
+ (when (and fdefn (typep (fdefn-fun fdefn) 'generic-function))
+ (return-from unencapsulate
+ (unencapsulate-generic-function (fdefn-fun fdefn) type)))
(cond ((not encap-info)
- ;; It disappeared on us, so don't worry about it.
- )
- ((eq (encapsulation-info-type encap-info) type)
- ;; It's the first one, so change the fdefn object.
- (setf (fdefn-function fdefn)
- (encapsulation-info-definition encap-info)))
- (t
- ;; It must be an interior one, so find it.
- (loop
- (let ((next-info (encapsulation-info
- (encapsulation-info-definition encap-info))))
- (unless next-info
- ;; Not there, so don't worry about it.
- (return))
- (when (eq (encapsulation-info-type next-info) type)
- ;; This is it, so unlink us.
- (setf (encapsulation-info-definition encap-info)
- (encapsulation-info-definition next-info))
- (return))
- (setf encap-info next-info))))))
+ ;; It disappeared on us, so don't worry about it.
+ )
+ ((eq (encapsulation-info-type encap-info) type)
+ ;; It's the first one, so change the fdefn object.
+ (setf (fdefn-fun fdefn)
+ (encapsulation-info-definition encap-info)))
+ (t
+ ;; It must be an interior one, so find it.
+ (loop
+ (let ((next-info (encapsulation-info
+ (encapsulation-info-definition encap-info))))
+ (unless next-info
+ ;; Not there, so don't worry about it.
+ (return))
+ (when (eq (encapsulation-info-type next-info) type)
+ ;; This is it, so unlink us.
+ (setf (encapsulation-info-definition encap-info)
+ (encapsulation-info-definition next-info))
+ (return))
+ (setf encap-info next-info))))))
t)
+;;; Does NAME have an encapsulation of the given TYPE?
(defun encapsulated-p (name type)
- #!+sb-doc
- "Returns t if name has an encapsulation of the given type, otherwise nil."
(let ((fdefn (fdefinition-object name nil)))
- (do ((encap-info (encapsulation-info (fdefn-function fdefn))
- (encapsulation-info
- (encapsulation-info-definition encap-info))))
- ((null encap-info) nil)
+ (when (and fdefn (typep (fdefn-fun fdefn) 'generic-function))
+ (return-from encapsulated-p
+ (encapsulated-generic-function-p (fdefn-fun fdefn) type)))
+ (do ((encap-info (encapsulation-info (fdefn-fun fdefn))
+ (encapsulation-info
+ (encapsulation-info-definition encap-info))))
+ ((null encap-info) nil)
(declare (type (or encapsulation-info null) encap-info))
(when (eq (encapsulation-info-type encap-info) type)
- (return t)))))
+ (return t)))))
\f
;;;; FDEFINITION
;;; KLUDGE: Er, it looks as though this means that
;;; (FUNCALL (FDEFINITION 'FOO))
;;; doesn't do the same thing as
-;;; (FUNCALL 'FOO).
-;;; That doesn't look like ANSI behavior to me. Look e.g. at the
-;;; ANSI definition of TRACE: "Whenever a traced function is invoked,
-;;; information about the call, ..". Try this:
+;;; (FUNCALL 'FOO),
+;;; and (SYMBOL-FUNCTION 'FOO) isn't in general the same thing
+;;; as (FDEFINITION 'FOO). That doesn't look like ANSI behavior to me.
+;;; Look e.g. at the ANSI definition of TRACE: "Whenever a traced
+;;; function is invoked, information about the call, ..". Try this:
;;; (DEFUN FOO () (PRINT "foo"))
;;; (TRACE FOO)
;;; (FUNCALL 'FOO)
;;; (FUNCALL (FDEFINITION 'FOO))
-;;; What to do? ANSI says TRACE "Might change the definitions of the functions
-;;; named by function-names." Might it be OK to just get punt all this
-;;; encapsulation stuff and go back to a simple but correct implementation of
-;;; TRACE? We'd lose the ability to redefine a TRACEd function and keep the
-;;; trace in place, but that seems tolerable to me. (Is the wrapper stuff
-;;; needed for anything else besides TRACE?)
+;;; What to do? ANSI says TRACE "Might change the definitions of the
+;;; functions named by function-names." Might it be OK to just get
+;;; punt all this encapsulation stuff and go back to a simple but
+;;; correct implementation of TRACE? We'd lose the ability to redefine
+;;; a TRACEd function and keep the trace in place, but that seems
+;;; tolerable to me. (Is the wrapper stuff needed for anything else
+;;; besides TRACE?)
;;;
;;; The only problem I can see with not having a wrapper: If tracing
;;; EQ, EQL, EQUAL, or EQUALP causes its function address to change,
;;; it will mess up the MAKE-HASH-TABLE logic which uses EQ tests
-;;; on those function values. -- WHN 19990906
+;;; on those function values. But given the ANSI statement about
+;;; TRACE causing things to change, that doesn't seem too unreasonable;
+;;; and we might even be able to forbid tracing these functions.
+;;; -- WHN 2001-11-02
(defun fdefinition (name)
#!+sb-doc
"Return name's global function definition taking care to respect any
encapsulations and to return the innermost encapsulated definition.
This is SETF'able."
- (let ((fun (raw-definition name)))
+ (let ((fun (%coerce-name-to-fun name)))
(loop
- (let ((encap-info (encapsulation-info fun)))
- (if encap-info
- (setf fun (encapsulation-info-definition encap-info))
- (return fun))))))
+ (let ((encap-info (encapsulation-info fun)))
+ (if encap-info
+ (setf fun (encapsulation-info-definition encap-info))
+ (return fun))))))
(defvar *setf-fdefinition-hook* nil
#!+sb-doc
- "This holds functions that (SETF FDEFINITION) invokes before storing the
- new value. These functions take the function name and the new value.")
+ "A list of functions that (SETF FDEFINITION) invokes before storing the
+ new value. The functions take the function name and the new value.")
(defun %set-fdefinition (name new-value)
#!+sb-doc
"Set NAME's global function definition."
(declare (type function new-value) (optimize (safety 1)))
- (let ((fdefn (fdefinition-object name t)))
- ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running top-level
- ;; forms in the kernel core startup.
- (when (boundp '*setf-fdefinition-hook*)
- (dolist (f *setf-fdefinition-hook*)
- (funcall f name new-value)))
+ (with-single-package-locked-error (:symbol name "setting fdefinition of ~A")
+ (maybe-clobber-ftype name)
+
+ ;; Check for hash-table stuff. Woe onto him that mixes encapsulation
+ ;; with this.
+ (when (and (symbolp name) (fboundp name)
+ (boundp '*user-hash-table-tests*))
+ (let ((old (symbol-function name)))
+ (declare (special *user-hash-table-tests*))
+ (dolist (spec *user-hash-table-tests*)
+ (cond ((eq old (second spec))
+ ;; test-function
+ (setf (second spec) new-value))
+ ((eq old (third spec))
+ ;; hash-function
+ (setf (third spec) new-value))))))
- (let ((encap-info (encapsulation-info (fdefn-function fdefn))))
- (cond (encap-info
- (loop
- (let ((more-info
- (encapsulation-info
- (encapsulation-info-definition encap-info))))
- (if more-info
- (setf encap-info more-info)
- (return
- (setf (encapsulation-info-definition encap-info)
- new-value))))))
- (t
- (setf (fdefn-function fdefn) new-value))))))
+ ;; FIXME: This is a good hook to have, but we should probably
+ ;; reserve it for users.
+ (let ((fdefn (fdefinition-object name t)))
+ ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running
+ ;; top level forms in the kernel core startup.
+ (when (boundp '*setf-fdefinition-hook*)
+ (dolist (f *setf-fdefinition-hook*)
+ (declare (type function f))
+ (funcall f name new-value)))
+
+ (let ((encap-info (encapsulation-info (fdefn-fun fdefn))))
+ (cond (encap-info
+ (loop
+ (let ((more-info
+ (encapsulation-info
+ (encapsulation-info-definition encap-info))))
+ (if more-info
+ (setf encap-info more-info)
+ (return
+ (setf (encapsulation-info-definition encap-info)
+ new-value))))))
+ (t
+ (setf (fdefn-fun fdefn) new-value)))))))
\f
;;;; FBOUNDP and FMAKUNBOUND
#!+sb-doc
"Return true if name has a global function definition."
(let ((fdefn (fdefinition-object name nil)))
- (and fdefn (fdefn-function fdefn) t)))
+ (and fdefn (fdefn-fun fdefn) t)))
(defun fmakunbound (name)
#!+sb-doc
- "Make Name have no global function definition."
- (let ((fdefn (fdefinition-object name nil)))
- (when fdefn
- (fdefn-makunbound fdefn)))
- name)
+ "Make NAME have no global function definition."
+ (with-single-package-locked-error
+ (:symbol name "removing the function or macro definition of ~A")
+ (let ((fdefn (fdefinition-object name nil)))
+ (when fdefn
+ (fdefn-makunbound fdefn)))
+ (sb!kernel:undefine-fun-name name)
+ name))
projects / sbcl.git / blobdiff