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