Initial revision
[sbcl.git] / src / code / fdefinition.lisp
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.
5
6 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; more information.
8 ;;;;
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.
14
15 (in-package "SB!IMPL")
16
17 (file-comment
18   "$Header$")
19
20 (sb!int::/show0 "fdefinition.lisp 22")
21 \f
22 ;;;; fdefinition (fdefn) objects
23
24 (defun make-fdefn (name)
25   (make-fdefn name))
26
27 (defun fdefn-name (fdefn)
28   (declare (type fdefn fdefn))
29   (fdefn-name fdefn))
30
31 (defun fdefn-function (fdefn)
32   (declare (type fdefn fdefn)
33            (values (or function null)))
34   (fdefn-function fdefn))
35
36 (defun (setf fdefn-function) (fun fdefn)
37   (declare (type function fun)
38            (type fdefn fdefn)
39            (values function))
40   (setf (fdefn-function fdefn) fun))
41
42 (defun fdefn-makunbound (fdefn)
43   (declare (type fdefn fdefn))
44   (fdefn-makunbound fdefn))
45
46 ;;; This function is called by !COLD-INIT after the globaldb has been
47 ;;; initialized, but before anything else. We need to install these
48 ;;; fdefn objects into the globaldb before any top level forms run, or
49 ;;; we will end up with two different fdefn objects being used for the
50 ;;; same function name. *!INITIAL-FDEFN-OBJECTS* is set up by GENESIS.
51 (defvar *!initial-fdefn-objects*)
52 (defun !fdefn-cold-init ()
53   (dolist (fdefn *!initial-fdefn-objects*)
54     (setf (info :function :definition (fdefn-name fdefn)) fdefn)))
55
56 (defun fdefinition-object (name create)
57   #!+sb-doc
58   "Return the fdefn object for NAME. If it doesn't already exist and CREATE
59    is non-NIL, create a new (unbound) one."
60   (declare (values (or fdefn null)))
61   (unless (or (symbolp name)
62               (and (consp name)
63                    (eq (car name) 'setf)
64                    (let ((cdr (cdr name)))
65                      (and (consp cdr)
66                           (symbolp (car cdr))
67                           (null (cdr cdr))))))
68     (error 'simple-type-error
69            :datum name
70            :expected-type '(or symbol list)
71            :format-control "invalid function name: ~S"
72            :format-arguments (list name)))
73   (let ((fdefn (info :function :definition name)))
74     (if (and (null fdefn) create)
75         (setf (info :function :definition name) (make-fdefn name))
76         fdefn)))
77
78 ;;; FIXME: If the fundamental operation performed when
79 ;;; funcalling a symbol is %COERCE-NAME-TO-FUNCTION, which expands into
80 ;;; FDEFINITION-OBJECT, which does (INFO :FUNCTION :DEFINITION NAME),
81 ;;; that's a horrendously heavyweight way to implement SYMBOL-FUNCTION.
82 ;;; What compelling reason is there for all this hairiness? The only
83 ;;; thing I can think of is that it does give a place to store
84 ;;; SETF functions, but I don't think that's a good enough reason.
85 ;;; It might even be that the FDEFINITION arrangement saves a little
86 ;;; space, if the proportion of function-less symbols is high enough,
87 ;;; but I don't think that's a good enough reason, either.
88 ;;; I'd really like to wipe out FDEFN stuff root and branch, and
89 ;;; just store SETF functions in the symbol property list.
90 ;;;
91 ;;; One problem with just doing the simple thing: What happens when
92 ;;; people call symbols which have no function definitions?
93 ;;;   1. Just hit "undefined function" error -- with no clue as to
94 ;;;      what undefined function it was. (This might actually not be
95 ;;;      too horrible, since the compiler warns you about undefined
96 ;;;      functions and the debugger aims, with incomplete success,
97 ;;;      to show you what form caused an error.)
98 ;;;   2. various solutions involving closures in the function slot,
99 ;;;      all of which have the drawback of extra memory use and extra
100 ;;;      difficulty in detecting when functions are undefined
101 ;;;   2a. Have every single symbol have an undefined function closure
102 ;;;       which points back to it to tell you which undefined symbol it
103 ;;;       was. (4 extra words per undefined symbol)
104 ;;;   2b. Play tricks with FDEFINITION, where the default SYMBOL-FUNCTION
105 ;;;       for any function is an anonymous "undefined function" error
106 ;;;       which doesn't tell you what the problem was, but if FDEFINITION
107 ;;;       is ever called on an undefined symbol, it helpfully changes the
108 ;;;       function definition to point to a closure which knows which
109 ;;;       symbol caused the problem.
110 ;;;   4. Just don't sweat it except when DEBUG>SPEED, where the calling
111 ;;;      convention gets tweaked to test for the undefined-function
112 ;;;      function at call time and bail out with helpful information
113 ;;;      if it's there.
114 ;;;   5. Require that the function calling convention be stereotyped
115 ;;;      along the lines of
116 ;;;             mov %ebx, local_immediate_3         ; Point to symbol.
117 ;;;             mov %eax, symbol_function_offset(%eax) ; Point to function.
118 ;;;             call *function_code_pointer(%eax)      ; Go.
119 ;;;      That way, it's guaranteed that on entry to a function, %EBX points
120 ;;;      back to the symbol which was used to indirect into the function,
121 ;;;      so the undefined function handler can base its complaint on that.
122 ;;;
123 ;;; Another problem with doing the simple thing: people will want to indirect
124 ;;; through something in order to get to SETF functions, in order to be able to
125 ;;; redefine them. What will they indirect through? This could be done with a
126 ;;; hack, making an anonymous symbol and linking it to the main symbol's
127 ;;; SB!KERNEL:SETF-FUNCTION property. The anonymous symbol could even point
128 ;;; back to the symbol it's the SETF function for, so that if the SETF function
129 ;;; was undefined at the time a call was made, the debugger could say which
130 ;;; function caused the problem. It'd probably be cleaner, though, to use a new
131 ;;; type of primitive object (SYMBOLOID?) instead. It could probably be like
132 ;;; symbol except that its name could be any object and its value points back
133 ;;; to the symbol which owns it. Then the setf functions for FOO could be on
134 ;;; the list (GET FOO 'SB!KERNEL:SYMBOLOIDS)
135 ;;;
136 ;;; FIXME: Oh, my. Now that I've started thinking about it, I appreciate more
137 ;;; fully how weird and twisted FDEFNs might be. Look at the calling sequence
138 ;;; for full calls. It goes and reads the address of a function object from its
139 ;;; own table of immediate values, then jumps into that. Consider how weird
140 ;;; that is. Not only is it not doing indirection through a symbol (which I'd
141 ;;; already realized) but it's not doing indirection through
142
143 ;;; The compiler emits calls to this when someone tries to funcall a symbol.
144 (defun %coerce-name-to-function (name)
145   #!+sb-doc
146   "Returns the definition for name, including any encapsulations. Settable
147    with SETF."
148   (let ((fdefn (fdefinition-object name nil)))
149     (or (and fdefn (fdefn-function fdefn))
150         (error 'undefined-function :name name))))
151
152 ;;; This is just another name for %COERCE-NAME-TO-FUNCTION.
153 #!-sb-fluid (declaim (inline raw-definition))
154 (defun raw-definition (name)
155   ;; We know that we are calling %COERCE-NAME-TO-FUNCTION, so don't remind us.
156   (declare (optimize (inhibit-warnings 3)))
157   (%coerce-name-to-function name))
158 (defun (setf raw-definition) (function name)
159   (let ((fdefn (fdefinition-object name t)))
160     (setf (fdefn-function fdefn) function)))
161
162 ;;; FIXME: There seems to be no good reason to have both
163 ;;; %COERCE-NAME-TO-FUNCTION and RAW-DEFINITION names for the same
164 ;;; thing. And despite what the doc string of %COERCE-NAME-TO-FUNCTION
165 ;;; says, it's doesn't look settable. Perhaps we could collapse
166 ;;; %COERCE-TO-FUNCTION, RAW-DEFINITION, and (SETF RAW-DEFINITION)
167 ;;; into RAW-FDEFINITION and (SETF RAW-FDEFINITION), or
168 ;;; OUTER-FDEFINITION and (SETF OUTER-FDEFINITION).
169 \f
170 ;;;; definition encapsulation
171
172 (defstruct (encapsulation-info (:constructor make-encapsulation-info
173                                              (type definition)))
174   ;; This is definition's encapsulation type. The encapsulated
175   ;; definition is in the previous encapsulation-info element or
176   ;; installed as the global definition of some function name.
177   type
178   ;; the previous, encapsulated definition. This used to be installed
179   ;; as a global definition for some function name, but it was
180   ;; replaced by an encapsulation of type TYPE.
181   (definition nil :type function))
182
183 ;;; We must bind and close over info. Consider the case where we
184 ;;; encapsulate (the second) an encapsulated (the first) definition,
185 ;;; and later someone unencapsulates the encapsulated (first)
186 ;;; definition. We don't want our encapsulation (second) to bind
187 ;;; basic-definition to the encapsulated (first) definition when it no
188 ;;; longer exists. When unencapsulating, we make sure to clobber the
189 ;;; appropriate info structure to allow basic-definition to be bound
190 ;;; to the next definition instead of an encapsulation that no longer
191 ;;; exists.
192 (defun encapsulate (name type body)
193   #!+sb-doc
194   "Replaces the definition of NAME with a function that binds name's arguments
195    a variable named argument-list, binds name's definition to a variable named
196    basic-definition, and evaluates BODY in that context. TYPE is
197    whatever you would like to associate with this encapsulation for
198    identification in case you need multiple encapsuations of the same name."
199   (let ((fdefn (fdefinition-object name nil)))
200     (unless (and fdefn (fdefn-function fdefn))
201       (error 'undefined-function :name name))
202     (let ((info (make-encapsulation-info type (fdefn-function fdefn))))
203       (setf (fdefn-function fdefn)
204             #'(lambda (&rest argument-list)
205                 (declare (special argument-list))
206                 (let ((basic-definition (encapsulation-info-definition info)))
207                   (declare (special basic-definition))
208                   (eval body)))))))
209
210 ;;; Finds the encapsulation info that has been closed over.
211 (defun encapsulation-info (fun)
212   (and (functionp fun)
213        (= (get-type fun) sb!vm:closure-header-type)
214        (find-if-in-closure #'encapsulation-info-p fun)))
215
216 ;;; When removing an encapsulation, we must remember that
217 ;;; encapsulating definitions close over a reference to the
218 ;;; encapsulation-info that describes the encapsulating definition.
219 ;;; When you find an info with the target type, the previous info in
220 ;;; the chain has the ensulating definition of that type. We take the
221 ;;; encapsulated definition from the info with the target type, and we
222 ;;; store it in the previous info structure whose encapsulating
223 ;;; definition it describes looks to this previous info structure for
224 ;;; a definition to bind (see ENCAPSULATE). When removing the first
225 ;;; info structure, we do something conceptually equal, but
226 ;;; mechanically it is different.
227 (defun unencapsulate (name type)
228   #!+sb-doc
229   "Removes NAME's most recent encapsulation of the specified TYPE."
230   (let* ((fdefn (fdefinition-object name nil))
231          (encap-info (encapsulation-info (fdefn-function fdefn))))
232     (declare (type (or encapsulation-info null) encap-info))
233     (cond ((not encap-info)
234            ;; It disappeared on us, so don't worry about it.
235            )
236           ((eq (encapsulation-info-type encap-info) type)
237            ;; It's the first one, so change the fdefn object.
238            (setf (fdefn-function fdefn)
239                  (encapsulation-info-definition encap-info)))
240           (t
241            ;; It must be an interior one, so find it.
242            (loop
243              (let ((next-info (encapsulation-info
244                                (encapsulation-info-definition encap-info))))
245                (unless next-info
246                  ;; Not there, so don't worry about it.
247                  (return))
248                (when (eq (encapsulation-info-type next-info) type)
249                  ;; This is it, so unlink us.
250                  (setf (encapsulation-info-definition encap-info)
251                        (encapsulation-info-definition next-info))
252                  (return))
253                (setf encap-info next-info))))))
254   t)
255
256 (defun encapsulated-p (name type)
257   #!+sb-doc
258   "Returns t if name has an encapsulation of the given type, otherwise nil."
259   (let ((fdefn (fdefinition-object name nil)))
260     (do ((encap-info (encapsulation-info (fdefn-function fdefn))
261                      (encapsulation-info
262                       (encapsulation-info-definition encap-info))))
263         ((null encap-info) nil)
264       (declare (type (or encapsulation-info null) encap-info))
265       (when (eq (encapsulation-info-type encap-info) type)
266         (return t)))))
267 \f
268 ;;;; FDEFINITION
269
270 ;;; KLUDGE: Er, it looks as though this means that
271 ;;;    (FUNCALL (FDEFINITION 'FOO))
272 ;;; doesn't do the same thing as
273 ;;;    (FUNCALL 'FOO).
274 ;;; That doesn't look like ANSI behavior to me. Look e.g. at the
275 ;;; ANSI definition of TRACE: "Whenever a traced function is invoked,
276 ;;; information about the call, ..". Try this:
277 ;;;   (DEFUN FOO () (PRINT "foo"))
278 ;;;   (TRACE FOO)
279 ;;;   (FUNCALL 'FOO)
280 ;;;   (FUNCALL (FDEFINITION 'FOO))
281 ;;; What to do? ANSI says TRACE "Might change the definitions of the functions
282 ;;; named by function-names." Might it be OK to just get punt all this
283 ;;; encapsulation stuff and go back to a simple but correct implementation of
284 ;;; TRACE? We'd lose the ability to redefine a TRACEd function and keep the
285 ;;; trace in place, but that seems tolerable to me. (Is the wrapper stuff
286 ;;; needed for anything else besides TRACE?)
287 ;;;
288 ;;; The only problem I can see with not having a wrapper: If tracing
289 ;;; EQ, EQL, EQUAL, or EQUALP causes its function address to change,
290 ;;; it will mess up the MAKE-HASH-TABLE logic which uses EQ tests
291 ;;; on those function values. -- WHN 19990906
292 (defun fdefinition (name)
293   #!+sb-doc
294   "Return name's global function definition taking care to respect any
295    encapsulations and to return the innermost encapsulated definition.
296    This is SETF'able."
297   (let ((fun (raw-definition name)))
298     (loop
299       (let ((encap-info (encapsulation-info fun)))
300         (if encap-info
301             (setf fun (encapsulation-info-definition encap-info))
302             (return fun))))))
303
304 (defvar *setf-fdefinition-hook* nil
305   #!+sb-doc
306   "This holds functions that (SETF FDEFINITION) invokes before storing the
307    new value. These functions take the function name and the new value.")
308
309 (defun %set-fdefinition (name new-value)
310   #!+sb-doc
311   "Set NAME's global function definition."
312   (declare (type function new-value) (optimize (safety 1)))
313   (let ((fdefn (fdefinition-object name t)))
314     ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running top-level
315     ;; forms in the kernel core startup.
316     (when (boundp '*setf-fdefinition-hook*)
317       (dolist (f *setf-fdefinition-hook*)
318         (funcall f name new-value)))
319
320     (let ((encap-info (encapsulation-info (fdefn-function fdefn))))
321       (cond (encap-info
322              (loop
323                (let ((more-info
324                       (encapsulation-info
325                        (encapsulation-info-definition encap-info))))
326                  (if more-info
327                      (setf encap-info more-info)
328                      (return
329                       (setf (encapsulation-info-definition encap-info)
330                             new-value))))))
331             (t
332              (setf (fdefn-function fdefn) new-value))))))
333 \f
334 ;;;; FBOUNDP and FMAKUNBOUND
335
336 (defun fboundp (name)
337   #!+sb-doc
338   "Return true if name has a global function definition."
339   (let ((fdefn (fdefinition-object name nil)))
340     (and fdefn (fdefn-function fdefn) t)))
341
342 (defun fmakunbound (name)
343   #!+sb-doc
344   "Make Name have no global function definition."
345   (let ((fdefn (fdefinition-object name nil)))
346     (when fdefn
347       (fdefn-makunbound fdefn)))
348   name)