0.pre7.139:
[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 ;;; 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   (unless (legal-fun-name-p name)
58     (error 'simple-type-error
59            :datum name
60            :expected-type '(or symbol list)
61            :format-control "invalid function name: ~S"
62            :format-arguments (list name)))
63   (let ((fdefn (info :function :definition name)))
64     (if (and (null fdefn) create)
65         (setf (info :function :definition name) (make-fdefn name))
66         fdefn)))
67
68 ;;; Return the fdefinition of NAME, including any encapsulations.
69 ;;; The compiler emits calls to this when someone tries to FUNCALL 
70 ;;; something. SETFable.
71 #!-sb-fluid (declaim (inline %coerce-name-to-fun))
72 (defun %coerce-name-to-fun (name)
73   (let ((fdefn (fdefinition-object name nil)))
74     (or (and fdefn (fdefn-fun fdefn))
75         (error 'undefined-function :name name))))
76 (defun (setf %coerce-name-to-fun) (function name)
77   (let ((fdefn (fdefinition-object name t)))
78     (setf (fdefn-fun fdefn) function)))
79
80 (defun %coerce-callable-to-fun (callable)
81   (if (functionp callable)
82       callable
83       (%coerce-name-to-fun callable)))
84 \f
85 ;;;; definition encapsulation
86
87 (defstruct (encapsulation-info (:constructor make-encapsulation-info
88                                              (type definition))
89                                (:copier nil))
90   ;; This is definition's encapsulation type. The encapsulated
91   ;; definition is in the previous encapsulation-info element or
92   ;; installed as the global definition of some function name.
93   type
94   ;; the previous, encapsulated definition. This used to be installed
95   ;; as a global definition for some function name, but it was
96   ;; replaced by an encapsulation of type TYPE.
97   (definition nil :type function))
98
99 ;;; Replace the definition of NAME with a function that binds NAME's
100 ;;; arguments to a variable named ARG-LIST, binds name's definition
101 ;;; to a variable named BASIC-DEFINITION, and evaluates BODY in that
102 ;;; context. TYPE is whatever you would like to associate with this
103 ;;; encapsulation for identification in case you need multiple
104 ;;; encapsulations of the same name.
105 (defun encapsulate (name type body)
106   (let ((fdefn (fdefinition-object name nil)))
107     (unless (and fdefn (fdefn-fun fdefn))
108       (error 'undefined-function :name name))
109     ;; We must bind and close over INFO. Consider the case where we
110     ;; encapsulate (the second) an encapsulated (the first)
111     ;; definition, and later someone unencapsulates the encapsulated
112     ;; (first) definition. We don't want our encapsulation (second) to
113     ;; bind basic-definition to the encapsulated (first) definition
114     ;; when it no longer exists. When unencapsulating, we make sure to
115     ;; clobber the appropriate INFO structure to allow
116     ;; basic-definition to be bound to the next definition instead of
117     ;; an encapsulation that no longer exists.
118     (let ((info (make-encapsulation-info type (fdefn-fun fdefn))))
119       (setf (fdefn-fun fdefn)
120             (lambda (&rest arg-list)
121               (declare (special arg-list))
122               (let ((basic-definition (encapsulation-info-definition info)))
123                 (declare (special basic-definition))
124                 (eval body)))))))
125
126 ;;; This is like FIND-IF, except that we do it on a compiled closure's
127 ;;; environment.
128 (defun find-if-in-closure (test fun)
129   (dotimes (index (1- (get-closure-length fun)))
130     (let ((elt (%closure-index-ref fun index)))
131       (when (funcall test elt)
132         (return elt)))))
133
134 ;;; Find the encapsulation info that has been closed over.
135 (defun encapsulation-info (fun)
136   (and (functionp fun)
137        (= (widetag-of fun) sb!vm:closure-header-widetag)
138        (find-if-in-closure #'encapsulation-info-p fun)))
139
140 ;;; When removing an encapsulation, we must remember that
141 ;;; encapsulating definitions close over a reference to the
142 ;;; encapsulation-info that describes the encapsulating definition.
143 ;;; When you find an info with the target type, the previous info in
144 ;;; the chain has the ensulating definition of that type. We take the
145 ;;; encapsulated definition from the info with the target type, and we
146 ;;; store it in the previous info structure whose encapsulating
147 ;;; definition it describes looks to this previous info structure for
148 ;;; a definition to bind (see ENCAPSULATE). When removing the first
149 ;;; info structure, we do something conceptually equal, but
150 ;;; mechanically it is different.
151 (defun unencapsulate (name type)
152   #!+sb-doc
153   "Removes NAME's most recent encapsulation of the specified TYPE."
154   (let* ((fdefn (fdefinition-object name nil))
155          (encap-info (encapsulation-info (fdefn-fun fdefn))))
156     (declare (type (or encapsulation-info null) encap-info))
157     (cond ((not encap-info)
158            ;; It disappeared on us, so don't worry about it.
159            )
160           ((eq (encapsulation-info-type encap-info) type)
161            ;; It's the first one, so change the fdefn object.
162            (setf (fdefn-fun fdefn)
163                  (encapsulation-info-definition encap-info)))
164           (t
165            ;; It must be an interior one, so find it.
166            (loop
167              (let ((next-info (encapsulation-info
168                                (encapsulation-info-definition encap-info))))
169                (unless next-info
170                  ;; Not there, so don't worry about it.
171                  (return))
172                (when (eq (encapsulation-info-type next-info) type)
173                  ;; This is it, so unlink us.
174                  (setf (encapsulation-info-definition encap-info)
175                        (encapsulation-info-definition next-info))
176                  (return))
177                (setf encap-info next-info))))))
178   t)
179
180 ;;; Does NAME have an encapsulation of the given TYPE?
181 (defun encapsulated-p (name type)
182   (let ((fdefn (fdefinition-object name nil)))
183     (do ((encap-info (encapsulation-info (fdefn-fun fdefn))
184                      (encapsulation-info
185                       (encapsulation-info-definition encap-info))))
186         ((null encap-info) nil)
187       (declare (type (or encapsulation-info null) encap-info))
188       (when (eq (encapsulation-info-type encap-info) type)
189         (return t)))))
190 \f
191 ;;;; FDEFINITION
192
193 ;;; KLUDGE: Er, it looks as though this means that
194 ;;;    (FUNCALL (FDEFINITION 'FOO))
195 ;;; doesn't do the same thing as
196 ;;;    (FUNCALL 'FOO),
197 ;;; and (SYMBOL-FUNCTION 'FOO) isn't in general the same thing
198 ;;; as (FDEFINITION 'FOO). That doesn't look like ANSI behavior to me.
199 ;;; Look e.g. at the ANSI definition of TRACE: "Whenever a traced
200 ;;; function is invoked, information about the call, ..". Try this:
201 ;;;   (DEFUN FOO () (PRINT "foo"))
202 ;;;   (TRACE FOO)
203 ;;;   (FUNCALL 'FOO)
204 ;;;   (FUNCALL (FDEFINITION 'FOO))
205 ;;; What to do? ANSI says TRACE "Might change the definitions of the
206 ;;; functions named by function-names." Might it be OK to just get
207 ;;; punt all this encapsulation stuff and go back to a simple but
208 ;;; correct implementation of TRACE? We'd lose the ability to redefine
209 ;;; a TRACEd function and keep the trace in place, but that seems
210 ;;; tolerable to me. (Is the wrapper stuff needed for anything else
211 ;;; besides TRACE?)
212 ;;;
213 ;;; The only problem I can see with not having a wrapper: If tracing
214 ;;; EQ, EQL, EQUAL, or EQUALP causes its function address to change,
215 ;;; it will mess up the MAKE-HASH-TABLE logic which uses EQ tests
216 ;;; on those function values. But given the ANSI statement about
217 ;;; TRACE causing things to change, that doesn't seem too unreasonable;
218 ;;; and we might even be able to forbid tracing these functions.
219 ;;; -- WHN 2001-11-02
220 (defun fdefinition (name)
221   #!+sb-doc
222   "Return name's global function definition taking care to respect any
223    encapsulations and to return the innermost encapsulated definition.
224    This is SETF'able."
225   (let ((fun (%coerce-name-to-fun name)))
226     (loop
227       (let ((encap-info (encapsulation-info fun)))
228         (if encap-info
229             (setf fun (encapsulation-info-definition encap-info))
230             (return fun))))))
231
232 (defvar *setf-fdefinition-hook* nil
233   #!+sb-doc
234   "This holds functions that (SETF FDEFINITION) invokes before storing the
235    new value. These functions take the function name and the new value.")
236
237 (defun %set-fdefinition (name new-value)
238   #!+sb-doc
239   "Set NAME's global function definition."
240   (declare (type function new-value) (optimize (safety 1)))
241   (let ((fdefn (fdefinition-object name t)))
242     ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running
243     ;; top level forms in the kernel core startup.
244     (when (boundp '*setf-fdefinition-hook*)
245       (dolist (f *setf-fdefinition-hook*)
246         (funcall f name new-value)))
247
248     (let ((encap-info (encapsulation-info (fdefn-fun fdefn))))
249       (cond (encap-info
250              (loop
251                (let ((more-info
252                       (encapsulation-info
253                        (encapsulation-info-definition encap-info))))
254                  (if more-info
255                      (setf encap-info more-info)
256                      (return
257                       (setf (encapsulation-info-definition encap-info)
258                             new-value))))))
259             (t
260              (setf (fdefn-fun fdefn) new-value))))))
261 \f
262 ;;;; FBOUNDP and FMAKUNBOUND
263
264 (defun fboundp (name)
265   #!+sb-doc
266   "Return true if name has a global function definition."
267   (let ((fdefn (fdefinition-object name nil)))
268     (and fdefn (fdefn-fun fdefn) t)))
269
270 (defun fmakunbound (name)
271   #!+sb-doc
272   "Make NAME have no global function definition."
273   (let ((fdefn (fdefinition-object name nil)))
274     (when fdefn
275       (fdefn-makunbound fdefn)))
276   (sb!kernel:undefine-fun-name name)
277   name)