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 #!-sb-fluid
(declaim (inline symbol-fdefn
))
44 ;; Return SYMBOL's fdefinition, if any, or NIL. SYMBOL must already
45 ;; have been verified to be a symbol by the caller.
46 (defun symbol-fdefn (symbol)
47 (declare (optimize (safety 0)))
48 (info-vector-fdefn (symbol-info-vector (uncross symbol
))))
50 ;; Return the fdefn object for NAME, or NIL if there is no fdefn.
51 ;; Signal an error if name isn't valid.
52 ;; Assume that exists-p implies LEGAL-FUN-NAME-P.
54 (declaim (ftype (sfunction ((or symbol list
)) (or fdefn null
)) find-fdefn
))
55 (defun find-fdefn (name0)
56 ;; Since this emulates GET-INFO-VALUE, we have to uncross the name.
57 (let ((name (uncross name0
)))
58 (declare (optimize (safety 0)))
59 (when (symbolp name
) ; Don't need LEGAL-FUN-NAME-P check
60 (return-from find-fdefn
(symbol-fdefn name
)))
61 ;; Technically the ALLOW-ATOM argument of NIL isn't needed, but
62 ;; the compiler isn't figuring out not to test SYMBOLP twice in a row.
63 (with-globaldb-name (key1 key2 nil
) name
65 ;; INFO-GETHASH returns NIL or a vector. INFO-VECTOR-FDEFN accepts
66 ;; either. If fdefn isn't found, fall through to the legality test.
67 (awhen (info-vector-fdefn (info-gethash name
*info-environment
*))
68 (return-from find-fdefn it
))
71 (awhen (symbol-info-vector key1
)
72 (multiple-value-bind (data-idx descriptor-idx field-idx
)
73 (info-find-aux-key/packed it key2
)
74 (declare (type index descriptor-idx
)
75 (type (integer 0 #.
+infos-per-word
+) field-idx
))
76 ;; Secondary names must have at least one info, so if a descriptor
77 ;; exists, there's no need to extract the n-infos field.
79 (when (eql (incf field-idx
) +infos-per-word
+)
80 (setq field-idx
0 descriptor-idx
(1+ descriptor-idx
)))
81 (when (eql (packed-info-field it descriptor-idx field-idx
)
83 (return-from find-fdefn
84 (aref it
(1- (the index data-idx
))))))))
85 (when (eq key1
'setf
) ; bypass the legality test
86 (return-from find-fdefn nil
))))
87 (legal-fun-name-or-type-error name
)))
89 (declaim (ftype (sfunction (t) fdefn
) find-or-create-fdefn
))
90 (defun find-or-create-fdefn (name)
92 ;; We won't reach here if the name was not legal
93 (let ((name (uncross name
)))
94 (get-info-value-initializing :function
:definition name
97 (defun maybe-clobber-ftype (name)
98 (unless (eq :declared
(info :function
:where-from name
))
99 (clear-info :function
:type name
)))
101 ;;; Return the fdefn-fun of NAME's fdefinition including any encapsulations.
102 ;;; LOOKUP-FN, defaulting to FIND-FDEFN, specifies how to lookup the fdefn.
103 ;;; As a special case it can be given as SYMBOL-FDEFN which is slightly quicker.
104 ;;; This is the core of the implementation of the standard FDEFINITION function,
105 ;;; but as we've defined FDEFINITION, that strips encapsulations.
106 (defmacro %coerce-name-to-fun
(name &optional
(lookup-fn 'find-fdefn
))
107 `(let* ((name ,name
) (fdefn (,lookup-fn name
)))
110 (values (sb!sys
:%primitive sb
!c
:safe-fdefn-fun fdefn
)))
111 (error 'undefined-function
:name name
))))
113 ;; Coerce CALLABLE (a function-designator) to a FUNCTION.
114 ;; The compiler emits this when someone tries to FUNCALL something.
115 ;; Extended-function-designators are not accepted,
116 ;; This function is defknowned with 'explicit-check', and we avoid calling
117 ;; SYMBOL-FUNCTION because that would do another check.
118 (defun %coerce-callable-to-fun
(callable)
121 (symbol (%coerce-name-to-fun callable symbol-fdefn
))))
124 ;;;; definition encapsulation
126 (defstruct (encapsulation-info (:constructor make-encapsulation-info
129 ;; This is definition's encapsulation type. The encapsulated
130 ;; definition is in the previous ENCAPSULATION-INFO element or
131 ;; installed as the global definition of some function name.
133 ;; the previous, encapsulated definition. This used to be installed
134 ;; as a global definition for some function name, but it was
135 ;; replaced by an encapsulation of type TYPE.
136 (definition nil
:type function
))
138 ;;; Replace the definition of NAME with a function that calls FUNCTION
139 ;;; with the original function and its arguments.
140 ;;; TYPE is whatever you would like to associate with this
141 ;;; encapsulation for identification in case you need multiple
142 ;;; encapsulations of the same name.
143 (defun encapsulate (name type function
)
144 (let ((fdefn (find-fdefn name
)))
145 (unless (and fdefn
(fdefn-fun fdefn
))
146 (error 'undefined-function
:name name
))
147 (when (typep (fdefn-fun fdefn
) 'generic-function
)
148 (return-from encapsulate
149 (encapsulate-generic-function (fdefn-fun fdefn
) type function
)))
150 ;; We must bind and close over INFO. Consider the case where we
151 ;; encapsulate (the second) an encapsulated (the first)
152 ;; definition, and later someone unencapsulates the encapsulated
153 ;; (first) definition. We don't want our encapsulation (second) to
154 ;; bind basic-definition to the encapsulated (first) definition
155 ;; when it no longer exists. When unencapsulating, we make sure to
156 ;; clobber the appropriate INFO structure to allow
157 ;; basic-definition to be bound to the next definition instead of
158 ;; an encapsulation that no longer exists.
159 (let ((info (make-encapsulation-info type
(fdefn-fun fdefn
))))
160 (setf (fdefn-fun fdefn
)
161 (named-lambda encapsulation
(&rest args
)
162 (apply function
(encapsulation-info-definition info
)
165 ;;; This is like FIND-IF, except that we do it on a compiled closure's
167 (defun find-if-in-closure (test closure
)
168 (declare (closure closure
))
169 (do-closure-values (value closure
)
170 (when (funcall test value
)
173 ;;; Find the encapsulation info that has been closed over.
174 (defun encapsulation-info (fun)
176 (find-if-in-closure #'encapsulation-info-p fun
)))
178 ;;; When removing an encapsulation, we must remember that
179 ;;; encapsulating definitions close over a reference to the
180 ;;; ENCAPSULATION-INFO that describes the encapsulating definition.
181 ;;; When you find an info with the target type, the previous info in
182 ;;; the chain has the ensulating definition of that type. We take the
183 ;;; encapsulated definition from the info with the target type, and we
184 ;;; store it in the previous info structure whose encapsulating
185 ;;; definition it describes looks to this previous info structure for
186 ;;; a definition to bind (see ENCAPSULATE). When removing the first
187 ;;; info structure, we do something conceptually equal, but
188 ;;; mechanically it is different.
189 (defun unencapsulate (name type
)
191 "Removes NAME's most recent encapsulation of the specified TYPE."
192 (let* ((fdefn (find-fdefn name
))
193 (encap-info (encapsulation-info (fdefn-fun fdefn
))))
194 (declare (type (or encapsulation-info null
) encap-info
))
195 (when (and fdefn
(typep (fdefn-fun fdefn
) 'generic-function
))
196 (return-from unencapsulate
197 (unencapsulate-generic-function (fdefn-fun fdefn
) type
)))
198 (cond ((not encap-info
)
199 ;; It disappeared on us, so don't worry about it.
201 ((eq (encapsulation-info-type encap-info
) type
)
202 ;; It's the first one, so change the fdefn object.
203 (setf (fdefn-fun fdefn
)
204 (encapsulation-info-definition encap-info
)))
206 ;; It must be an interior one, so find it.
208 (let ((next-info (encapsulation-info
209 (encapsulation-info-definition encap-info
))))
211 ;; Not there, so don't worry about it.
213 (when (eq (encapsulation-info-type next-info
) type
)
214 ;; This is it, so unlink us.
215 (setf (encapsulation-info-definition encap-info
)
216 (encapsulation-info-definition next-info
))
218 (setf encap-info next-info
))))))
221 ;;; Does NAME have an encapsulation of the given TYPE?
222 (defun encapsulated-p (name type
)
223 (let ((fdefn (find-fdefn name
)))
224 (when (and fdefn
(typep (fdefn-fun fdefn
) 'generic-function
))
225 (return-from encapsulated-p
226 (encapsulated-generic-function-p (fdefn-fun fdefn
) type
)))
227 (do ((encap-info (encapsulation-info (fdefn-fun fdefn
))
229 (encapsulation-info-definition encap-info
))))
230 ((null encap-info
) nil
)
231 (declare (type (or encapsulation-info null
) encap-info
))
232 (when (eq (encapsulation-info-type encap-info
) type
)
237 ;;; KLUDGE: Er, it looks as though this means that
238 ;;; (FUNCALL (FDEFINITION 'FOO))
239 ;;; doesn't do the same thing as
241 ;;; and (SYMBOL-FUNCTION 'FOO) isn't in general the same thing
242 ;;; as (FDEFINITION 'FOO). That doesn't look like ANSI behavior to me.
243 ;;; Look e.g. at the ANSI definition of TRACE: "Whenever a traced
244 ;;; function is invoked, information about the call, ..". Try this:
245 ;;; (DEFUN FOO () (PRINT "foo"))
248 ;;; (FUNCALL (FDEFINITION 'FOO))
249 ;;; What to do? ANSI says TRACE "Might change the definitions of the
250 ;;; functions named by function-names." Might it be OK to just get
251 ;;; punt all this encapsulation stuff and go back to a simple but
252 ;;; correct implementation of TRACE? We'd lose the ability to redefine
253 ;;; a TRACEd function and keep the trace in place, but that seems
254 ;;; tolerable to me. (Is the wrapper stuff needed for anything else
257 ;;; The only problem I can see with not having a wrapper: If tracing
258 ;;; EQ, EQL, EQUAL, or EQUALP causes its function address to change,
259 ;;; it will mess up the MAKE-HASH-TABLE logic which uses EQ tests
260 ;;; on those function values. But given the ANSI statement about
261 ;;; TRACE causing things to change, that doesn't seem too unreasonable;
262 ;;; and we might even be able to forbid tracing these functions.
263 ;;; -- WHN 2001-11-02
264 (defun fdefinition (name)
266 "Return name's global function definition taking care to respect any
267 encapsulations and to return the innermost encapsulated definition.
269 (let ((fun (%coerce-name-to-fun name
)))
271 (let ((encap-info (encapsulation-info fun
)))
273 (setf fun
(encapsulation-info-definition encap-info
))
276 (defvar *setf-fdefinition-hook
* nil
278 "A list of functions that (SETF FDEFINITION) invokes before storing the
279 new value. The functions take the function name and the new value.")
281 ;; Return :MACRO or :SPECIAL if FUNCTION is the error-signaling trampoline
282 ;; for a macro or a special operator respectively. Test for this by seeing
283 ;; whether FUNCTION is the same closure as for a known macro.
284 ;; For cold-init to work, this must pick any macro defined before
285 ;; this function is. A safe choice is a macro from this same file.
286 (defun macro/special-guard-fun-p
(function)
287 (and (closurep function
)
288 ;; Prior to cold-init fixing up the load-time-value, this compares
289 ;; %closure-fun to 0, which is ok - it returns NIL.
291 (%closure-fun
(symbol-function '%coerce-name-to-fun
)) t
)
292 (%closure-fun function
))
293 ;; This is not super-efficient, but every code path that gets
294 ;; here does so with the intent of signaling an error.
295 (car (%fun-name function
))))
297 ;; Reject any "object of implementation-dependent nature" that
298 ;; so happens to be a function in SBCL, but which must not be
299 ;; bound to a function-name by way of (SETF FEDFINITION).
300 (defun err-if-unacceptable-function (object setter
)
301 (when (macro/special-guard-fun-p object
)
302 (error 'simple-reference-error
303 :references
(list '(:ansi-cl
:function fdefinition
))
304 :format-control
"~S is not acceptable to ~S."
305 :format-arguments
(list object setter
))))
307 (defun %set-fdefinition
(name new-value
)
309 "Set NAME's global function definition."
310 (declare (type function new-value
) (optimize (safety 1)))
311 (err-if-unacceptable-function new-value
'(setf fdefinition
))
312 (with-single-package-locked-error (:symbol name
"setting fdefinition of ~A")
313 (maybe-clobber-ftype name
)
315 ;; Check for hash-table stuff. Woe onto him that mixes encapsulation
317 (when (and (symbolp name
) (fboundp name
)
318 (boundp '*user-hash-table-tests
*))
319 (let ((old (symbol-function name
)))
320 (declare (special *user-hash-table-tests
*))
321 (dolist (spec *user-hash-table-tests
*)
322 (cond ((eq old
(second spec
))
324 (setf (second spec
) new-value
))
325 ((eq old
(third spec
))
327 (setf (third spec
) new-value
))))))
329 ;; FIXME: This is a good hook to have, but we should probably
330 ;; reserve it for users.
331 (let ((fdefn (find-or-create-fdefn name
)))
332 ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running
333 ;; top level forms in the kernel core startup.
334 (when (boundp '*setf-fdefinition-hook
*)
335 (dolist (f *setf-fdefinition-hook
*)
336 (declare (type function f
))
337 (funcall f name new-value
)))
339 (let ((encap-info (encapsulation-info (fdefn-fun fdefn
))))
344 (encapsulation-info-definition encap-info
))))
346 (setf encap-info more-info
)
348 (setf (encapsulation-info-definition encap-info
)
351 (setf (fdefn-fun fdefn
) new-value
)))))))
353 ;;;; FBOUNDP and FMAKUNBOUND
355 (defun fboundp (name)
357 "Return true if name has a global function definition."
358 (let ((fdefn (find-fdefn name
)))
359 (and fdefn
(fdefn-fun fdefn
) t
)))
361 (defun fmakunbound (name)
363 "Make NAME have no global function definition."
364 (with-single-package-locked-error
365 (:symbol name
"removing the function or macro definition of ~A")
366 (let ((fdefn (find-fdefn name
)))
368 (fdefn-makunbound fdefn
)))
369 (undefine-fun-name name
)