1 ;;;; This file contains functions that hack on the global function
2 ;;;; namespace (primarily concerned with SETF functions here). Also,
3 ;;;; function encapsulation and routines that set and return
4 ;;;; definitions disregarding whether they might be encapsulated.
6 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; This software is derived from the CMU CL system, which was
10 ;;;; written at Carnegie Mellon University and released into the
11 ;;;; public domain. The software is in the public domain and is
12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
13 ;;;; files for more information.
15 (in-package "SB!IMPL")
17 (sb!int
::/show0
"fdefinition.lisp 22")
19 ;;;; fdefinition (fdefn) objects
21 (defun make-fdefn (name)
24 (defun fdefn-name (fdefn)
25 (declare (type fdefn fdefn
))
28 (defun fdefn-fun (fdefn)
29 (declare (type fdefn fdefn
)
30 (values (or function null
)))
33 (defun (setf fdefn-fun
) (fun fdefn
)
34 (declare (type function fun
)
37 (setf (fdefn-fun fdefn
) fun
))
39 (defun fdefn-makunbound (fdefn)
40 (declare (type fdefn fdefn
))
41 (fdefn-makunbound fdefn
))
43 ;;; This function is called by !COLD-INIT after the globaldb has been
44 ;;; initialized, but before anything else. We need to install these
45 ;;; fdefn objects into the globaldb before any top level forms run, or
46 ;;; we will end up with two different fdefn objects being used for the
47 ;;; same function name. *!INITIAL-FDEFN-OBJECTS* is set up by GENESIS.
48 (defvar *!initial-fdefn-objects
*)
49 (defun !fdefn-cold-init
()
50 (dolist (fdefn *!initial-fdefn-objects
*)
51 (setf (info :function
:definition
(fdefn-name fdefn
)) fdefn
)))
53 ;;; Return the fdefn object for NAME. If it doesn't already exist and
54 ;;; CREATE is non-NIL, create a new (unbound) one.
55 (defun fdefinition-object (name create
)
56 (declare (values (or fdefn null
)))
57 (legal-fun-name-or-type-error name
)
58 (let ((fdefn (info :function
:definition name
)))
59 (if (and (null fdefn
) create
)
60 (setf (info :function
:definition name
) (make-fdefn name
))
63 ;;; Return the fdefinition of NAME, including any encapsulations.
64 ;;; The compiler emits calls to this when someone tries to FUNCALL
65 ;;; something. SETFable.
66 #!-sb-fluid
(declaim (inline %coerce-name-to-fun
))
67 (defun %coerce-name-to-fun
(name)
68 (let ((fdefn (fdefinition-object name nil
)))
69 (or (and fdefn
(fdefn-fun fdefn
))
70 (error 'undefined-function
:name name
))))
71 (defun (setf %coerce-name-to-fun
) (function name
)
72 (let ((fdefn (fdefinition-object name t
)))
73 (setf (fdefn-fun fdefn
) function
)))
75 (defun %coerce-callable-to-fun
(callable)
76 (if (functionp callable
)
78 (%coerce-name-to-fun callable
)))
80 ;;;; definition encapsulation
82 (defstruct (encapsulation-info (:constructor make-encapsulation-info
85 ;; This is definition's encapsulation type. The encapsulated
86 ;; definition is in the previous ENCAPSULATION-INFO element or
87 ;; installed as the global definition of some function name.
89 ;; the previous, encapsulated definition. This used to be installed
90 ;; as a global definition for some function name, but it was
91 ;; replaced by an encapsulation of type TYPE.
92 (definition nil
:type function
))
94 ;;; Replace the definition of NAME with a function that binds NAME's
95 ;;; arguments to a variable named ARG-LIST, binds name's definition
96 ;;; to a variable named BASIC-DEFINITION, and evaluates BODY in that
97 ;;; context. TYPE is whatever you would like to associate with this
98 ;;; encapsulation for identification in case you need multiple
99 ;;; encapsulations of the same name.
100 (defun encapsulate (name type body
)
101 (let ((fdefn (fdefinition-object name nil
)))
102 (unless (and fdefn
(fdefn-fun fdefn
))
103 (error 'undefined-function
:name name
))
104 ;; We must bind and close over INFO. Consider the case where we
105 ;; encapsulate (the second) an encapsulated (the first)
106 ;; definition, and later someone unencapsulates the encapsulated
107 ;; (first) definition. We don't want our encapsulation (second) to
108 ;; bind basic-definition to the encapsulated (first) definition
109 ;; when it no longer exists. When unencapsulating, we make sure to
110 ;; clobber the appropriate INFO structure to allow
111 ;; basic-definition to be bound to the next definition instead of
112 ;; an encapsulation that no longer exists.
113 (let ((info (make-encapsulation-info type
(fdefn-fun fdefn
))))
114 (setf (fdefn-fun fdefn
)
115 (named-lambda encapsulation
(&rest arg-list
)
116 (declare (special arg-list
))
117 (let ((basic-definition (encapsulation-info-definition info
)))
118 (declare (special basic-definition
))
121 ;;; This is like FIND-IF, except that we do it on a compiled closure's
123 (defun find-if-in-closure (test closure
)
124 (declare (closure closure
))
125 (do-closure-values (value closure
)
126 (when (funcall test value
)
129 ;;; Find the encapsulation info that has been closed over.
130 (defun encapsulation-info (fun)
132 (find-if-in-closure #'encapsulation-info-p fun
)))
134 ;;; When removing an encapsulation, we must remember that
135 ;;; encapsulating definitions close over a reference to the
136 ;;; ENCAPSULATION-INFO that describes the encapsulating definition.
137 ;;; When you find an info with the target type, the previous info in
138 ;;; the chain has the ensulating definition of that type. We take the
139 ;;; encapsulated definition from the info with the target type, and we
140 ;;; store it in the previous info structure whose encapsulating
141 ;;; definition it describes looks to this previous info structure for
142 ;;; a definition to bind (see ENCAPSULATE). When removing the first
143 ;;; info structure, we do something conceptually equal, but
144 ;;; mechanically it is different.
145 (defun unencapsulate (name type
)
147 "Removes NAME's most recent encapsulation of the specified TYPE."
148 (let* ((fdefn (fdefinition-object name nil
))
149 (encap-info (encapsulation-info (fdefn-fun fdefn
))))
150 (declare (type (or encapsulation-info null
) encap-info
))
151 (cond ((not encap-info
)
152 ;; It disappeared on us, so don't worry about it.
154 ((eq (encapsulation-info-type encap-info
) type
)
155 ;; It's the first one, so change the fdefn object.
156 (setf (fdefn-fun fdefn
)
157 (encapsulation-info-definition encap-info
)))
159 ;; It must be an interior one, so find it.
161 (let ((next-info (encapsulation-info
162 (encapsulation-info-definition encap-info
))))
164 ;; Not there, so don't worry about it.
166 (when (eq (encapsulation-info-type next-info
) type
)
167 ;; This is it, so unlink us.
168 (setf (encapsulation-info-definition encap-info
)
169 (encapsulation-info-definition next-info
))
171 (setf encap-info next-info
))))))
174 ;;; Does NAME have an encapsulation of the given TYPE?
175 (defun encapsulated-p (name type
)
176 (let ((fdefn (fdefinition-object name nil
)))
177 (do ((encap-info (encapsulation-info (fdefn-fun fdefn
))
179 (encapsulation-info-definition encap-info
))))
180 ((null encap-info
) nil
)
181 (declare (type (or encapsulation-info null
) encap-info
))
182 (when (eq (encapsulation-info-type encap-info
) type
)
187 ;;; KLUDGE: Er, it looks as though this means that
188 ;;; (FUNCALL (FDEFINITION 'FOO))
189 ;;; doesn't do the same thing as
191 ;;; and (SYMBOL-FUNCTION 'FOO) isn't in general the same thing
192 ;;; as (FDEFINITION 'FOO). That doesn't look like ANSI behavior to me.
193 ;;; Look e.g. at the ANSI definition of TRACE: "Whenever a traced
194 ;;; function is invoked, information about the call, ..". Try this:
195 ;;; (DEFUN FOO () (PRINT "foo"))
198 ;;; (FUNCALL (FDEFINITION 'FOO))
199 ;;; What to do? ANSI says TRACE "Might change the definitions of the
200 ;;; functions named by function-names." Might it be OK to just get
201 ;;; punt all this encapsulation stuff and go back to a simple but
202 ;;; correct implementation of TRACE? We'd lose the ability to redefine
203 ;;; a TRACEd function and keep the trace in place, but that seems
204 ;;; tolerable to me. (Is the wrapper stuff needed for anything else
207 ;;; The only problem I can see with not having a wrapper: If tracing
208 ;;; EQ, EQL, EQUAL, or EQUALP causes its function address to change,
209 ;;; it will mess up the MAKE-HASH-TABLE logic which uses EQ tests
210 ;;; on those function values. But given the ANSI statement about
211 ;;; TRACE causing things to change, that doesn't seem too unreasonable;
212 ;;; and we might even be able to forbid tracing these functions.
213 ;;; -- WHN 2001-11-02
214 (defun fdefinition (name)
216 "Return name's global function definition taking care to respect any
217 encapsulations and to return the innermost encapsulated definition.
219 (let ((fun (%coerce-name-to-fun name
)))
221 (let ((encap-info (encapsulation-info fun
)))
223 (setf fun
(encapsulation-info-definition encap-info
))
226 (defvar *setf-fdefinition-hook
* nil
228 "A list of functions that (SETF FDEFINITION) invokes before storing the
229 new value. The functions take the function name and the new value.")
231 (defun %set-fdefinition
(name new-value
)
233 "Set NAME's global function definition."
234 (declare (type function new-value
) (optimize (safety 1)))
235 (with-single-package-locked-error (:symbol name
"setting fdefinition of ~A")
237 ;; Check for hash-table stuff. Woe onto him that mixes encapsulation
239 (when (and (symbolp name
) (fboundp name
)
240 (boundp '*user-hash-table-tests
*))
241 (let ((old (symbol-function name
)))
242 (declare (special *user-hash-table-tests
*))
243 (dolist (spec *user-hash-table-tests
*)
244 (cond ((eq old
(second spec
))
246 (setf (second spec
) new-value
))
247 ((eq old
(third spec
))
249 (setf (third spec
) new-value
))))))
251 ;; FIXME: This is a good hook to have, but we should probably
252 ;; reserve it for users.
253 (let ((fdefn (fdefinition-object name t
)))
254 ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running
255 ;; top level forms in the kernel core startup.
256 (when (boundp '*setf-fdefinition-hook
*)
257 (dolist (f *setf-fdefinition-hook
*)
258 (declare (type function f
))
259 (funcall f name new-value
)))
261 (let ((encap-info (encapsulation-info (fdefn-fun fdefn
))))
266 (encapsulation-info-definition encap-info
))))
268 (setf encap-info more-info
)
270 (setf (encapsulation-info-definition encap-info
)
273 (setf (fdefn-fun fdefn
) new-value
)))))))
275 ;;;; FBOUNDP and FMAKUNBOUND
277 (defun fboundp (name)
279 "Return true if name has a global function definition."
280 (let ((fdefn (fdefinition-object name nil
)))
281 (and fdefn
(fdefn-fun fdefn
) t
)))
283 (defun fmakunbound (name)
285 "Make NAME have no global function definition."
286 (with-single-package-locked-error
287 (:symbol name
"removing the function or macro definition of ~A")
288 (let ((fdefn (fdefinition-object name nil
)))
290 (fdefn-makunbound fdefn
)))
291 (sb!kernel
:undefine-fun-name name
)