1.0.16.7: slightly faster LAST
[sbcl.git] / src / compiler / info-functions.lisp
1 ;;;; miscellaneous functions which use INFO
2 ;;;;
3 ;;;; (In CMU CL, these were in globaldb.lisp. They've been moved here
4 ;;;; because references to INFO can't be compiled correctly until
5 ;;;; globaldb initialization is complete, and the SBCL technique for
6 ;;;; initializing the global database in the cross-compiler isn't
7 ;;;; completed until load time.)
8
9 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; more information.
11 ;;;;
12 ;;;; This software is derived from the CMU CL system, which was
13 ;;;; written at Carnegie Mellon University and released into the
14 ;;;; public domain. The software is in the public domain and is
15 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
16 ;;;; files for more information.
17
18 (in-package "SB!C")
19 \f
20 ;;;; internal utilities defined in terms of INFO
21
22 ;;; Check that NAME is a valid function name, returning the name if
23 ;;; OK, and signalling an error if not. In addition to checking for
24 ;;; basic well-formedness, we also check that symbol names are not NIL
25 ;;; or the name of a special form.
26 (defun check-fun-name (name)
27   (typecase name
28     (list
29      (unless (legal-fun-name-p name)
30        (compiler-error "illegal function name: ~S" name)))
31     (symbol
32      (when (eq (info :function :kind name) :special-form)
33        (compiler-error "Special form is an illegal function name: ~S" name)))
34     (t
35      (compiler-error "illegal function name: ~S" name)))
36   (values))
37
38 ;;; Record a new function definition, and check its legality.
39 (defun proclaim-as-fun-name (name)
40
41   ;; legal name?
42   (check-fun-name name)
43
44   ;; scrubbing old data I: possible collision with old definition
45   (when (fboundp name)
46     (ecase (info :function :kind name)
47       (:function) ; happy case
48       ((nil)) ; another happy case
49       (:macro ; maybe-not-so-good case
50        (compiler-style-warn "~S was previously defined as a macro." name)
51        (setf (info :function :where-from name) :assumed)
52        (clear-info :function :macro-function name))))
53
54   ;; scrubbing old data II: dangling forward references
55   ;;
56   ;; (This could happen if someone executes PROCLAIM FTYPE at
57   ;; macroexpansion time, which is bad style, or at compile time, e.g.
58   ;; in EVAL-WHEN (:COMPILE) inside something like DEFSTRUCT, in which
59   ;; case it's reasonable style. Either way, NAME is no longer a free
60   ;; function.)
61   (when (boundp '*free-funs*) ; when compiling
62     (remhash name *free-funs*))
63
64   ;; recording the ordinary case
65   (setf (info :function :kind name) :function)
66   (note-if-setf-fun-and-macro name)
67
68   (values))
69
70 ;;; This is called to do something about SETF functions that overlap
71 ;;; with SETF macros. Perhaps we should interact with the user to see
72 ;;; whether the macro should be blown away, but for now just give a
73 ;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we
74 ;;; can't assume that they aren't just naming a function (SETF FOO)
75 ;;; for the heck of it. NAME is already known to be well-formed.
76 (defun note-if-setf-fun-and-macro (name)
77   (when (consp name)
78     (when (or (info :setf :inverse name)
79               (info :setf :expander name))
80       (compiler-style-warn
81        "defining as a SETF function a name that already has a SETF macro:~
82        ~%  ~S"
83        name)))
84   (values))
85
86 ;;; Make NAME no longer be a function name: clear everything back to
87 ;;; the default.
88 (defun undefine-fun-name (name)
89   (when name
90     (macrolet ((frob (type &optional val)
91                  `(unless (eq (info :function ,type name) ,val)
92                     (setf (info :function ,type name) ,val))))
93       (frob :info)
94       (frob :type (specifier-type 'function))
95       (frob :where-from :assumed)
96       (frob :inlinep)
97       (frob :kind)
98       (frob :inline-expansion-designator)
99       (frob :source-transform)
100       (frob :structure-accessor)
101       (frob :assumed-type)))
102   (values))
103
104 ;;; part of what happens with DEFUN, also with some PCL stuff: Make
105 ;;; NAME known to be a function definition.
106 (defun become-defined-fun-name (name)
107   (proclaim-as-fun-name name)
108   (when (eq (info :function :where-from name) :assumed)
109     (setf (info :function :where-from name) :defined)
110     (if (info :function :assumed-type name)
111         (setf (info :function :assumed-type name) nil))))
112
113 ;;; Decode any raw (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR FUN-NAME)
114 ;;; value into a lambda expression, or return NIL if there is none.
115 (declaim (ftype (function ((or symbol cons)) list) fun-name-inline-expansion))
116 (defun fun-name-inline-expansion (fun-name)
117   (let ((info (info :function :inline-expansion-designator fun-name)))
118     (if (functionp info)
119         (funcall info)
120         info)))
121 \f
122 ;;;; ANSI Common Lisp functions which are defined in terms of the info
123 ;;;; database
124
125 (defun sb!xc:macro-function (symbol &optional env)
126   #!+sb-doc
127   "If SYMBOL names a macro in ENV, returns the expansion function,
128 else returns NIL. If ENV is unspecified or NIL, use the global environment
129 only."
130   (declare (symbol symbol))
131   (let* ((fenv (when env (lexenv-funs env)))
132          (local-def (cdr (assoc symbol fenv))))
133     (cond (local-def
134            (if (and (consp local-def) (eq (car local-def) 'macro))
135                (cdr local-def)
136                nil))
137           ((eq (info :function :kind symbol) :macro)
138            (values (info :function :macro-function symbol)))
139           (t
140            nil))))
141
142 (defun (setf sb!xc:macro-function) (function symbol &optional environment)
143   (declare (symbol symbol) (type function function))
144   (when environment
145     ;; Note: Technically there could be an ENV optional argument to SETF
146     ;; MACRO-FUNCTION, but since ANSI says that the consequences of
147     ;; supplying a non-nil one are undefined, we don't allow it.
148     ;; (Thus our implementation of this unspecified behavior is to
149     ;; complain. SInce the behavior is unspecified, this is conforming.:-)
150     (error "Non-NIL environment argument in SETF of MACRO-FUNCTION ~S: ~S"
151            symbol environment))
152   (when (eq (info :function :kind symbol) :special-form)
153     (error "~S names a special form." symbol))
154   (setf (info :function :kind symbol) :macro)
155   (setf (info :function :macro-function symbol) function)
156   ;; This is a nice thing to have in the target SBCL, but in the
157   ;; cross-compilation host it's not nice to mess with
158   ;; (SYMBOL-FUNCTION FOO) where FOO might be a symbol in the
159   ;; cross-compilation host's COMMON-LISP package.
160   #-sb-xc-host
161   (setf (symbol-function symbol)
162         (lambda (&rest args)
163           (declare (ignore args))
164           ;; (ANSI specification of FUNCALL says that this should be
165           ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.)
166           (error 'undefined-function :name symbol)))
167   function)
168
169 (defun fun-locally-defined-p (name env)
170   (and env
171        (let ((fun (cdr (assoc name (lexenv-funs env) :test #'equal))))
172          (and fun (not (global-var-p fun))))))
173
174 (defun sb!xc:compiler-macro-function (name &optional env)
175   #!+sb-doc
176   "If NAME names a compiler-macro in ENV, return the expansion function, else
177 return NIL. Can be set with SETF when ENV is NIL."
178   (legal-fun-name-or-type-error name)
179   ;; CLHS 3.2.2.1: Creating a lexical binding for the function name
180   ;; not only creates a new local function or macro definition, but
181   ;; also shadows[2] the compiler macro.
182   (unless (fun-locally-defined-p name env)
183     ;; Note: CMU CL used to return NIL here when a NOTINLINE
184     ;; declaration was in force. That's fairly logical, given the
185     ;; specified effect of NOTINLINE declarations on compiler-macro
186     ;; expansion. However, (1) it doesn't seem to be consistent with
187     ;; the ANSI spec for COMPILER-MACRO-FUNCTION, and (2) it would
188     ;; give surprising behavior for (SETF (COMPILER-MACRO-FUNCTION
189     ;; FOO) ...) in the presence of a (PROCLAIM '(NOTINLINE FOO)). So
190     ;; we don't do it.
191     (values (info :function :compiler-macro-function name))))
192
193 (defun (setf sb!xc:compiler-macro-function) (function name &optional env)
194   (declare (type (or symbol list) name)
195            (type (or function null) function))
196   (when env
197     ;; ANSI says this operation is undefined.
198     (error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL"))
199   (when (eq (info :function :kind name) :special-form)
200     (error "~S names a special form." name))
201   (with-single-package-locked-error
202       (:symbol name "setting the compiler-macro-function of ~A")
203     (setf (info :function :compiler-macro-function name) function)
204     function))
205 \f
206 ;;;; a subset of DOCUMENTATION functionality for bootstrapping
207
208 ;;; FDOCUMENTATION is like DOCUMENTATION, but with less functionality,
209 ;;; and implemented with DEFUN instead of DEFGENERIC so that it can
210 ;;; run before CLOS is set up. Supported DOC-TYPE values are
211 ;;;   FUNCTION
212 ;;;   SETF
213 ;;;   STRUCTURE
214 ;;;   T
215 ;;;   TYPE
216 ;;;   VARIABLE
217 ;;; FIXME: Other types end up in INFO :RANDOM-DOCUMENTATION :STUFF. I
218 ;;; should add some code to monitor this and make sure that nothing is
219 ;;; unintentionally being sent to never never land this way.
220 ;;; FIXME: Rename FDOCUMENTATION to BDOCUMENTATION, by analogy with
221 ;;; DEF!STRUCT and DEF!MACRO and so forth. And consider simply saving
222 ;;; all the BDOCUMENTATION entries in a *BDOCUMENTATION* hash table
223 ;;; and slamming them into PCL once PCL gets going.
224 (defun fdocumentation (x doc-type)
225   (flet ((try-cmucl-random-doc (x doc-type)
226            (declare (symbol doc-type))
227            (cdr (assoc doc-type
228                        (values (info :random-documentation :stuff x))))))
229     (case doc-type
230       (variable
231        (typecase x
232          (symbol (values (info :variable :documentation x)))))
233       (function
234        (cond ((functionp x)
235               (%fun-doc x))
236              ((legal-fun-name-p x)
237               ;; FIXME: Is it really right to make
238               ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to
239               ;; (DOCUMENTATION 'FOO 'FUNCTION)? That's what CMU CL
240               ;; did, so we do it, but I'm not sure it's what ANSI wants.
241               (values (info :function :documentation
242                             (fun-name-block-name x))))))
243       (structure
244        (typecase x
245          (symbol (cond
246                    ((eq (info :type :kind x) :instance)
247                     (values (info :type :documentation x)))
248                    ((info :typed-structure :info x)
249                     (values (info :typed-structure :documentation x)))))))
250       (type
251        (typecase x
252          (structure-class (values (info :type :documentation (class-name x))))
253          (t (and (typep x 'symbol) (values (info :type :documentation x))))))
254       (setf (values (info :setf :documentation x)))
255       ((t)
256        (typecase x
257          (function (%fun-doc x))
258          (package (package-doc-string x))
259          (structure-class (values (info :type :documentation (class-name x))))
260          (symbol (try-cmucl-random-doc x doc-type))))
261       (t
262        (typecase x
263          ;; FIXME: This code comes from CMU CL, but
264          ;; TRY-CMUCL-RANDOM-DOC doesn't seem to be defined anywhere
265          ;; in CMU CL. Perhaps it could be defined by analogy with the
266          ;; corresponding SETF FDOCUMENTATION code.
267          (symbol (try-cmucl-random-doc x doc-type)))))))
268 (defun (setf fdocumentation) (string name doc-type)
269   ;; FIXME: I think it should be possible to set documentation for
270   ;; things (e.g. compiler macros) named (SETF FOO). fndb.lisp
271   ;; declares DOC-TYPE to be a SYMBOL, which contradicts that. What
272   ;; should be done?
273   (case doc-type
274     (variable (setf (info :variable :documentation name) string))
275     (function (setf (info :function :documentation name) string))
276     (structure (cond
277                  ((eq (info :type :kind name) :instance)
278                   (setf (info :type :documentation name) string))
279                  ((info :typed-structure :info name)
280                   (setf (info :typed-structure :documentation name) string))
281                  (t
282                   (error "~S is not a structure name." name))))
283     (type (setf (info :type :documentation name) string))
284     (setf (setf (info :setf :documentation name) string))
285     (t
286      (let ((pair (assoc doc-type (info :random-documentation :stuff name))))
287        (if pair
288            (setf (cdr pair) string)
289            (push (cons doc-type string)
290                  (info :random-documentation :stuff name))))))
291   string)