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 ;; This variable properly belongs in 'target-hash-table',
18 ;; but it's compiled after this file is.
19 (!defglobal
*user-hash-table-tests
* nil
)
21 (sb!int
::/show0
"fdefinition.lisp 22")
23 ;;;; fdefinition (fdefn) objects
25 (defun make-fdefn (name)
26 #!-immobile-space
(make-fdefn name
)
27 ;; This is %primitive because it needs pseudo-atomic,
28 ;; otherwise it would just be an alien-funcall.
30 (let ((fdefn (truly-the (values fdefn
)
31 (%primitive sb
!vm
::alloc-immobile-fdefn name
))))
32 (%primitive fdefn-makunbound fdefn
)
35 (defun fdefn-name (fdefn)
36 (declare (type fdefn fdefn
))
39 (defun fdefn-fun (fdefn)
40 (declare (type fdefn fdefn
)
41 (values (or function null
)))
44 (defun (setf fdefn-fun
) (fun fdefn
)
45 (declare (type function fun
)
48 #!+immobile-code
(sb!vm
::%set-fdefn-fun fdefn fun
)
49 #!-immobile-code
(setf (fdefn-fun fdefn
) fun
))
51 (defun fdefn-makunbound (fdefn)
52 (declare (type fdefn fdefn
))
53 (fdefn-makunbound fdefn
))
55 #!-sb-fluid
(declaim (inline symbol-fdefn
))
56 ;; Return SYMBOL's fdefinition, if any, or NIL. SYMBOL must already
57 ;; have been verified to be a symbol by the caller.
58 (defun symbol-fdefn (symbol)
59 (declare (optimize (safety 0)))
60 (info-vector-fdefn (symbol-info-vector symbol
)))
62 ;; Return the fdefn object for NAME, or NIL if there is no fdefn.
63 ;; Signal an error if name isn't valid.
64 ;; Assume that exists-p implies LEGAL-FUN-NAME-P.
66 (declaim (ftype (sfunction ((or symbol list
)) (or fdefn null
)) find-fdefn
))
67 (defun find-fdefn (name)
68 (declare (explicit-check))
69 (when (symbolp name
) ; Don't need LEGAL-FUN-NAME-P check
70 (return-from find-fdefn
(symbol-fdefn name
)))
71 ;; Technically the ALLOW-ATOM argument of NIL isn't needed, but
72 ;; the compiler isn't figuring out not to test SYMBOLP twice in a row.
73 (with-globaldb-name (key1 key2 nil
) name
75 ;; INFO-GETHASH returns NIL or a vector. INFO-VECTOR-FDEFN accepts
76 ;; either. If fdefn isn't found, fall through to the legality test.
77 (awhen (info-vector-fdefn (info-gethash name
*info-environment
*))
78 (return-from find-fdefn it
))
81 (awhen (symbol-info-vector key1
)
82 (multiple-value-bind (data-idx descriptor-idx field-idx
)
83 (info-find-aux-key/packed it key2
)
84 (declare (type index descriptor-idx
)
85 (type (integer 0 #.
+infos-per-word
+) field-idx
))
86 ;; Secondary names must have at least one info, so if a descriptor
87 ;; exists, there's no need to extract the n-infos field.
89 (when (eql (incf field-idx
) +infos-per-word
+)
90 (setq field-idx
0 descriptor-idx
(1+ descriptor-idx
)))
91 (when (eql (packed-info-field it descriptor-idx field-idx
)
93 (return-from find-fdefn
94 (aref it
(1- (the index data-idx
))))))))
95 (when (eq key1
'setf
) ; bypass the legality test
96 (return-from find-fdefn nil
))))
97 (legal-fun-name-or-type-error name
))
99 (declaim (ftype (sfunction (t) fdefn
) find-or-create-fdefn
))
100 (defun find-or-create-fdefn (name)
101 (or (find-fdefn name
)
102 ;; We won't reach here if the name was not legal
103 (let ((fdefn (get-info-value-initializing :function
:definition name
105 (when (typep name
'(cons (eql sb
!pcl
::slot-accessor
)))
106 (sb!pcl
::ensure-accessor name
))
109 ;;; Remove NAME's FTYPE information unless it was explicitly PROCLAIMED.
110 ;;; The NEW-FUNCTION argument is presently unused, but could be used
111 ;;; for checking compatibility of the NEW-FUNCTION against a proclamation.
112 ;;; (We could issue a warning and/or remove the type if incompatible.)
113 (defun maybe-clobber-ftype (name new-function
)
114 (declare (ignore new-function
))
115 (unless (eq :declared
(info :function
:where-from name
))
116 (clear-info :function
:type name
)))
118 ;;; Return the fdefn-fun of NAME's fdefinition including any encapsulations.
119 ;;; LOOKUP-FN, defaulting to FIND-FDEFN, specifies how to lookup the fdefn.
120 ;;; As a special case it can be given as SYMBOL-FDEFN which is slightly quicker.
121 ;;; This is the core of the implementation of the standard FDEFINITION function,
122 ;;; but as we've defined FDEFINITION, that strips encapsulations.
123 (defmacro %coerce-name-to-fun
(name &optional
(lookup-fn 'find-fdefn
)
128 (let ((fdefn (,lookup-fn name
)))
130 (let ((f (fdefn-fun (truly-the fdefn fdefn
))))
131 ;; If STRICTLY-FUNCTIONP is true, we make sure not to return an error
132 ;; trampoline. This extra check ensures that full calls such as
133 ;; (MAPCAR 'OR '()) signal an error that OR isn't a function.
134 ;; This accords with the non-requirement that macros store strictly
135 ;; a function in the symbol that names them. In many implementations,
136 ;; (FUNCTIONP (SYMBOL-FUNCTION 'OR)) => NIL. We want to pretend that.
138 (,@(if strictly-functionp
139 '(unless (macro/special-guard-fun-p f
))
144 ;; Avoid making the initial NAME a value cell,
145 ;; it will cons even if no restarts are reached
146 (restart-case (error 'undefined-function
:name name
)
148 :report
(lambda (stream)
149 (format stream
"Retry using ~s." name
))
152 :report
(lambda (stream)
153 (format stream
"Use specified function"))
154 :interactive read-evaluated-form
155 (when (functionp value
)
157 (the ,(if (eq lookup-fn
'symbol-fdefn
)
163 ;; Return T if FUNCTION is the error-signaling trampoline
164 ;; for a macro or a special operator. Test for this by seeing
165 ;; whether FUNCTION is the same closure as for a known macro.
166 ;; For cold-init to work, this must pick any macro defined before
167 ;; this function is. A safe choice is a macro from this same file.
168 (declaim (inline macro
/special-guard-fun-p
))
169 (defun macro/special-guard-fun-p
(function)
170 ;; When inlined, this is a few instructions shorter than CLOSUREP
171 ;; if we already know that FUNCTION is a function.
172 ;; It will signal a type error if not, which is the right thing to do anyway.
173 ;; (this isn't quite a true predicate)
174 (and (= (fun-subtype function
) sb
!vm
:closure-widetag
)
175 ;; Prior to cold-init fixing up the load-time-value, this compares
176 ;; %closure-fun to 0, which is ok - it returns NIL.
177 (eq (load-time-value (%closure-fun
(symbol-function '%coerce-name-to-fun
))
179 (%closure-fun function
))))
181 ;; Coerce CALLABLE (a function-designator) to a FUNCTION.
182 ;; The compiler emits this when someone tries to FUNCALL something.
183 ;; Extended-function-designators are not accepted,
184 ;; This function declares EXPLICIT-CHECK, and we avoid calling
185 ;; SYMBOL-FUNCTION because that would do another check.
186 ;; It would be great if this could change its error message
187 ;; depending on the input to either:
188 ;; "foo is not a function designator" if not a CALLABLE
189 ;; "foo does not designate a currently defined function"
190 ;; if a symbol does not satisfy FBOUNDP.
191 (defun %coerce-callable-to-fun
(callable)
192 (declare (explicit-check))
195 (symbol (%coerce-name-to-fun callable symbol-fdefn t
))))
198 ;;;; definition encapsulation
200 (defstruct (encapsulation-info (:constructor make-encapsulation-info
203 ;; This is definition's encapsulation type. The encapsulated
204 ;; definition is in the previous ENCAPSULATION-INFO element or
205 ;; installed as the global definition of some function name.
207 ;; the previous, encapsulated definition. This used to be installed
208 ;; as a global definition for some function name, but it was
209 ;; replaced by an encapsulation of type TYPE.
210 (definition nil
:type function
))
212 ;;; Replace the definition of NAME with a function that calls FUNCTION
213 ;;; with the original function and its arguments.
214 ;;; TYPE is whatever you would like to associate with this
215 ;;; encapsulation for identification in case you need multiple
216 ;;; encapsulations of the same name.
217 (defun encapsulate (name type function
)
218 (let* ((fdefn (find-fdefn name
))
219 (underlying-fun (sb!c
:safe-fdefn-fun fdefn
)))
220 (when (typep underlying-fun
'generic-function
)
221 (return-from encapsulate
222 (encapsulate-generic-function underlying-fun type function
)))
223 ;; We must bind and close over INFO. Consider the case where we
224 ;; encapsulate (the second) an encapsulated (the first)
225 ;; definition, and later someone unencapsulates the encapsulated
226 ;; (first) definition. We don't want our encapsulation (second) to
227 ;; bind basic-definition to the encapsulated (first) definition
228 ;; when it no longer exists. When unencapsulating, we make sure to
229 ;; clobber the appropriate INFO structure to allow
230 ;; basic-definition to be bound to the next definition instead of
231 ;; an encapsulation that no longer exists.
232 (let ((info (make-encapsulation-info type underlying-fun
)))
233 (setf (fdefn-fun fdefn
)
234 (named-lambda encapsulation
(&rest args
)
235 (apply function
(encapsulation-info-definition info
)
238 ;;; This is like FIND-IF, except that we do it on a compiled closure's
240 (defun find-if-in-closure (test closure
)
241 (declare (closure closure
))
242 (do-closure-values (value closure
)
243 (when (funcall test value
)
246 ;;; Find the encapsulation info that has been closed over.
247 (defun encapsulation-info (fun)
249 (find-if-in-closure #'encapsulation-info-p fun
)))
251 ;;; When removing an encapsulation, we must remember that
252 ;;; encapsulating definitions close over a reference to the
253 ;;; ENCAPSULATION-INFO that describes the encapsulating definition.
254 ;;; When you find an info with the target type, the previous info in
255 ;;; the chain has the ensulating definition of that type. We take the
256 ;;; encapsulated definition from the info with the target type, and we
257 ;;; store it in the previous info structure whose encapsulating
258 ;;; definition it describes looks to this previous info structure for
259 ;;; a definition to bind (see ENCAPSULATE). When removing the first
260 ;;; info structure, we do something conceptually equal, but
261 ;;; mechanically it is different.
262 (defun unencapsulate (name type
)
263 "Removes NAME's most recent encapsulation of the specified TYPE."
264 (let* ((fdefn (find-fdefn name
))
265 (encap-info (encapsulation-info (fdefn-fun fdefn
))))
266 (declare (type (or encapsulation-info null
) encap-info
))
267 (when (and fdefn
(typep (fdefn-fun fdefn
) 'generic-function
))
268 (return-from unencapsulate
269 (unencapsulate-generic-function (fdefn-fun fdefn
) type
)))
270 (cond ((not encap-info
)
271 ;; It disappeared on us, so don't worry about it.
273 ((eq (encapsulation-info-type encap-info
) type
)
274 ;; It's the first one, so change the fdefn object.
275 (setf (fdefn-fun fdefn
)
276 (encapsulation-info-definition encap-info
)))
278 ;; It must be an interior one, so find it.
280 (let ((next-info (encapsulation-info
281 (encapsulation-info-definition encap-info
))))
283 ;; Not there, so don't worry about it.
285 (when (eq (encapsulation-info-type next-info
) type
)
286 ;; This is it, so unlink us.
287 (setf (encapsulation-info-definition encap-info
)
288 (encapsulation-info-definition next-info
))
290 (setf encap-info next-info
))))))
293 ;;; Does NAME have an encapsulation of the given TYPE?
294 (defun encapsulated-p (name type
)
295 (let ((fdefn (find-fdefn name
)))
296 (when (and fdefn
(typep (fdefn-fun fdefn
) 'generic-function
))
297 (return-from encapsulated-p
298 (encapsulated-generic-function-p (fdefn-fun fdefn
) type
)))
299 (do ((encap-info (encapsulation-info (fdefn-fun fdefn
))
301 (encapsulation-info-definition encap-info
))))
302 ((null encap-info
) nil
)
303 (declare (type (or encapsulation-info null
) encap-info
))
304 (when (eq (encapsulation-info-type encap-info
) type
)
309 ;;; KLUDGE: Er, it looks as though this means that
310 ;;; (FUNCALL (FDEFINITION 'FOO))
311 ;;; doesn't do the same thing as
313 ;;; and (SYMBOL-FUNCTION 'FOO) isn't in general the same thing
314 ;;; as (FDEFINITION 'FOO). That doesn't look like ANSI behavior to me.
315 ;;; Look e.g. at the ANSI definition of TRACE: "Whenever a traced
316 ;;; function is invoked, information about the call, ..". Try this:
317 ;;; (DEFUN FOO () (PRINT "foo"))
320 ;;; (FUNCALL (FDEFINITION 'FOO))
321 ;;; What to do? ANSI says TRACE "Might change the definitions of the
322 ;;; functions named by function-names." Might it be OK to just get
323 ;;; punt all this encapsulation stuff and go back to a simple but
324 ;;; correct implementation of TRACE? We'd lose the ability to redefine
325 ;;; a TRACEd function and keep the trace in place, but that seems
326 ;;; tolerable to me. (Is the wrapper stuff needed for anything else
329 ;;; The only problem I can see with not having a wrapper: If tracing
330 ;;; EQ, EQL, EQUAL, or EQUALP causes its function address to change,
331 ;;; it will mess up the MAKE-HASH-TABLE logic which uses EQ tests
332 ;;; on those function values. But given the ANSI statement about
333 ;;; TRACE causing things to change, that doesn't seem too unreasonable;
334 ;;; and we might even be able to forbid tracing these functions.
335 ;;; -- WHN 2001-11-02
336 (defun fdefinition (name)
337 "Return name's global function definition taking care to respect any
338 encapsulations and to return the innermost encapsulated definition.
340 (declare (explicit-check))
341 (let ((fun (%coerce-name-to-fun name
)))
343 (let ((encap-info (encapsulation-info fun
)))
345 (setf fun
(encapsulation-info-definition encap-info
))
348 (defvar *setf-fdefinition-hook
* nil
349 "A list of functions that (SETF FDEFINITION) invokes before storing the
350 new value. The functions take the function name and the new value.")
352 ;; Reject any "object of implementation-dependent nature" that
353 ;; so happens to be a function in SBCL, but which must not be
354 ;; bound to a function-name by way of (SETF FEDFINITION).
355 (defun err-if-unacceptable-function (object setter
)
356 (when (macro/special-guard-fun-p object
)
357 (error 'simple-reference-error
358 :references
'((:ansi-cl
:function fdefinition
))
359 :format-control
"~S is not acceptable to ~S."
360 :format-arguments
(list object setter
))))
362 (defun %set-fdefinition
(name new-value
)
363 "Set NAME's global function definition."
364 (declare (type function new-value
) (optimize (safety 1)))
365 (declare (explicit-check))
366 (err-if-unacceptable-function new-value
'(setf fdefinition
))
367 (with-single-package-locked-error (:symbol name
"setting fdefinition of ~A")
368 (maybe-clobber-ftype name new-value
)
370 ;; Check for hash-table stuff. Woe onto him that mixes encapsulation
372 (when (and (symbolp name
) (fboundp name
))
373 (let ((old (symbol-function name
)))
374 (dolist (spec *user-hash-table-tests
*)
375 (cond ((eq old
(second spec
))
377 (setf (second spec
) new-value
))
378 ((eq old
(third spec
))
380 (setf (third spec
) new-value
))))))
382 ;; FIXME: This is a good hook to have, but we should probably
383 ;; reserve it for users.
384 (let ((fdefn (find-or-create-fdefn name
)))
385 ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running
386 ;; top level forms in the kernel core startup.
387 (when (boundp '*setf-fdefinition-hook
*)
388 (dolist (f *setf-fdefinition-hook
*)
389 (declare (type function f
))
390 (funcall f name new-value
)))
392 (let ((encap-info (encapsulation-info (fdefn-fun fdefn
))))
397 (encapsulation-info-definition encap-info
))))
399 (setf encap-info more-info
)
401 (setf (encapsulation-info-definition encap-info
)
404 (setf (fdefn-fun fdefn
) new-value
)))))))
406 ;;;; FBOUNDP and FMAKUNBOUND
408 (defun fboundp (name)
409 "Return true if name has a global function definition."
410 (declare (explicit-check))
411 (let ((fdefn (find-fdefn name
)))
412 (and fdefn
(fdefn-fun fdefn
) t
)))
414 ;; Byte index 2 of the fdefn's header is the statically-linked flag
416 (defmacro sb
!vm
::fdefn-has-static-callers
(fdefn)
417 `(sap-ref-8 (int-sap (get-lisp-obj-address ,fdefn
))
418 (- 2 sb
!vm
::other-pointer-lowtag
)))
420 (defun fmakunbound (name)
421 "Make NAME have no global function definition."
422 (declare (explicit-check))
423 (with-single-package-locked-error
424 (:symbol name
"removing the function or macro definition of ~A")
425 (let ((fdefn (find-fdefn name
)))
428 (unless (eql (sb!vm
::fdefn-has-static-callers fdefn
) 0)
429 (sb!vm
::remove-static-links fdefn
))
430 (fdefn-makunbound fdefn
)))
431 (undefine-fun-name name
)