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