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