d4cb02ac9dc2218190aafa67e863b2c6c210cae7
[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
45   ;; KLUDGE: This can happen when eg. compiling a NAMED-LAMBDA, and isn't
46   ;; guarded against elsewhere -- so we want to assert package locks here. The
47   ;; reason we do it only when stomping on existing stuff is because we want
48   ;; to keep
49   ;;   (WITHOUT-PACKAGE-LOCKS (DEFUN LOCKED:FOO ...))
50   ;; viable, which requires no compile-time violations in the harmless cases.
51   (with-single-package-locked-error ()
52     (flet ((assert-it ()
53              (assert-symbol-home-package-unlocked name "proclaiming ~S as a function")))
54
55       (let ((kind (info :function :kind name)))
56         ;; scrubbing old data I: possible collision with a macro
57         (when (and (fboundp name) (eq :macro kind))
58           (assert-it)
59           (compiler-style-warn "~S was previously defined as a macro." name)
60           (setf (info :function :where-from name) :assumed)
61           (clear-info :function :macro-function name))
62
63         (unless (eq :function kind)
64           (assert-it)
65           (setf (info :function :kind name) :function)))))
66
67   ;; scrubbing old data II: dangling forward references
68   ;;
69   ;; (This could happen if someone executes PROCLAIM FTYPE at
70   ;; macroexpansion time, which is bad style, or at compile time, e.g.
71   ;; in EVAL-WHEN (:COMPILE) inside something like DEFSTRUCT, in which
72   ;; case it's reasonable style. Either way, NAME is no longer a free
73   ;; function.)
74   (when (boundp '*free-funs*)       ; when compiling
75     (remhash name *free-funs*))
76
77   (note-if-setf-fun-and-macro name)
78
79   (values))
80
81 ;;; This is called to do something about SETF functions that overlap
82 ;;; with SETF macros. Perhaps we should interact with the user to see
83 ;;; whether the macro should be blown away, but for now just give a
84 ;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we
85 ;;; can't assume that they aren't just naming a function (SETF FOO)
86 ;;; for the heck of it. NAME is already known to be well-formed.
87 (defun note-if-setf-fun-and-macro (name)
88   (when (consp name)
89     (when (or (info :setf :inverse name)
90               (info :setf :expander name))
91       (compiler-style-warn
92        "defining as a SETF function a name that already has a SETF macro:~
93        ~%  ~S"
94        name)))
95   (values))
96
97 ;;; Make NAME no longer be a function name: clear everything back to
98 ;;; the default.
99 (defun undefine-fun-name (name)
100   (when name
101     (macrolet ((frob (type &optional val)
102                  `(unless (eq (info :function ,type name) ,val)
103                     (setf (info :function ,type name) ,val))))
104       (frob :info)
105       (frob :type (specifier-type 'function))
106       (frob :where-from :assumed)
107       (frob :inlinep)
108       (frob :kind)
109       (frob :inline-expansion-designator)
110       (frob :source-transform)
111       (frob :structure-accessor)
112       (frob :assumed-type)))
113   (values))
114
115 ;;; part of what happens with DEFUN, also with some PCL stuff: Make
116 ;;; NAME known to be a function definition.
117 (defun become-defined-fun-name (name)
118   (proclaim-as-fun-name name)
119   (when (eq (info :function :where-from name) :assumed)
120     (setf (info :function :where-from name) :defined)
121     (if (info :function :assumed-type name)
122         (setf (info :function :assumed-type name) nil))))
123
124 ;;; Decode any raw (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR FUN-NAME)
125 ;;; value into a lambda expression, or return NIL if there is none.
126 (declaim (ftype (function ((or symbol cons)) list) fun-name-inline-expansion))
127 (defun fun-name-inline-expansion (fun-name)
128   (let ((info (info :function :inline-expansion-designator fun-name)))
129     (if (functionp info)
130         (funcall info)
131         info)))
132 \f
133 ;;;; ANSI Common Lisp functions which are defined in terms of the info
134 ;;;; database
135
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 environment
140 only."
141   (declare (symbol symbol))
142   (let* ((fenv (when env (lexenv-funs 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 (defun (setf sb!xc:macro-function) (function symbol &optional environment)
154   (declare (symbol symbol) (type function function))
155   (when environment
156     ;; Note: Technically there could be an ENV optional argument to SETF
157     ;; MACRO-FUNCTION, but since ANSI says that the consequences of
158     ;; supplying a non-nil one are undefined, we don't allow it.
159     ;; (Thus our implementation of this unspecified behavior is to
160     ;; complain. SInce the behavior is unspecified, this is conforming.:-)
161     (error "Non-NIL environment argument in SETF of MACRO-FUNCTION ~S: ~S"
162            symbol environment))
163   (when (eq (info :function :kind symbol) :special-form)
164     (error "~S names a special form." symbol))
165   (with-single-package-locked-error (:symbol symbol "setting the macro-function of ~S")
166     (setf (info :function :kind symbol) :macro)
167     (setf (info :function :macro-function symbol) function)
168     ;; This is a nice thing to have in the target SBCL, but in the
169     ;; cross-compilation host it's not nice to mess with
170     ;; (SYMBOL-FUNCTION FOO) where FOO might be a symbol in the
171     ;; cross-compilation host's COMMON-LISP package.
172     #-sb-xc-host
173     (setf (symbol-function symbol)
174           (lambda (&rest args)
175             (declare (ignore args))
176             ;; (ANSI specification of FUNCALL says that this should be
177             ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.)
178             (error 'undefined-function :name symbol))))
179   function)
180
181 (defun fun-locally-defined-p (name env)
182   (and env
183        (let ((fun (cdr (assoc name (lexenv-funs env) :test #'equal))))
184          (and fun (not (global-var-p fun))))))
185
186 (defun sb!xc:compiler-macro-function (name &optional env)
187   #!+sb-doc
188   "If NAME names a compiler-macro in ENV, return the expansion function, else
189 return NIL. Can be set with SETF when ENV is NIL."
190   (legal-fun-name-or-type-error name)
191   ;; CLHS 3.2.2.1: Creating a lexical binding for the function name
192   ;; not only creates a new local function or macro definition, but
193   ;; also shadows[2] the compiler macro.
194   (unless (fun-locally-defined-p name env)
195     ;; Note: CMU CL used to return NIL here when a NOTINLINE
196     ;; declaration was in force. That's fairly logical, given the
197     ;; specified effect of NOTINLINE declarations on compiler-macro
198     ;; expansion. However, (1) it doesn't seem to be consistent with
199     ;; the ANSI spec for COMPILER-MACRO-FUNCTION, and (2) it would
200     ;; give surprising behavior for (SETF (COMPILER-MACRO-FUNCTION
201     ;; FOO) ...) in the presence of a (PROCLAIM '(NOTINLINE FOO)). So
202     ;; we don't do it.
203     (values (info :function :compiler-macro-function name))))
204
205 (defun (setf sb!xc:compiler-macro-function) (function name &optional env)
206   (declare (type (or symbol list) name)
207            (type (or function null) function))
208   (when env
209     ;; ANSI says this operation is undefined.
210     (error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL"))
211   (when (eq (info :function :kind name) :special-form)
212     (error "~S names a special form." name))
213   (with-single-package-locked-error
214       (:symbol name "setting the compiler-macro-function of ~A")
215     (setf (info :function :compiler-macro-function name) function)
216     function))
217 \f
218 ;;;; a subset of DOCUMENTATION functionality for bootstrapping
219
220 ;;; FDOCUMENTATION is like DOCUMENTATION, but with less functionality,
221 ;;; and implemented with DEFUN instead of DEFGENERIC so that it can
222 ;;; run before CLOS is set up. Supported DOC-TYPE values are
223 ;;;   FUNCTION
224 ;;;   SETF
225 ;;;   STRUCTURE
226 ;;;   T
227 ;;;   TYPE
228 ;;;   VARIABLE
229 ;;; FIXME: Other types end up in INFO :RANDOM-DOCUMENTATION :STUFF. I
230 ;;; should add some code to monitor this and make sure that nothing is
231 ;;; unintentionally being sent to never never land this way.
232 ;;; FIXME: Rename FDOCUMENTATION to BDOCUMENTATION, by analogy with
233 ;;; DEF!STRUCT and DEF!MACRO and so forth. And consider simply saving
234 ;;; all the BDOCUMENTATION entries in a *BDOCUMENTATION* hash table
235 ;;; and slamming them into PCL once PCL gets going.
236 (defun fdocumentation (x doc-type)
237   (case doc-type
238     (variable
239      (typecase x
240        (symbol (values (info :variable :documentation x)))))
241     ;; FUNCTION is not used at the momemnt, just here for symmetry.
242     (function
243      (cond ((functionp x)
244             (%fun-doc x))
245            ((and (legal-fun-name-p x) (fboundp x))
246             (%fun-doc (or (and (symbolp x) (macro-function x))
247                           (fdefinition x))))))
248     (structure
249      (typecase x
250        (symbol (cond
251                  ((eq (info :type :kind x) :instance)
252                   (values (info :type :documentation x)))
253                  ((info :typed-structure :info x)
254                   (values (info :typed-structure :documentation x)))))))
255     (type
256      (typecase x
257        (structure-class (values (info :type :documentation (class-name x))))
258        (t (and (typep x 'symbol) (values (info :type :documentation x))))))
259     (setf (values (info :setf :documentation x)))
260     ((t)
261      (typecase x
262        (function (%fun-doc x))
263        (package (package-doc-string x))
264        (structure-class (values (info :type :documentation (class-name x))))
265        ((or symbol cons)
266         (random-documentation x doc-type))))
267     (t
268      (when (typep x '(or symbol cons))
269        (random-documentation x doc-type)))))
270
271 (defun (setf fdocumentation) (string name doc-type)
272   (declare (type (or null string) string))
273   (case doc-type
274     (variable (setf (info :variable :documentation name) string))
275     (function
276      ;; KLUDGE: FDEFINITION isn't ready early enough during cold-init, so
277      ;; special case for symbols.
278      (if (symbolp name)
279          (setf (%fun-doc (symbol-function name)) string)
280          (when (legal-fun-name-p name)
281            (setf (%fun-doc (fdefinition name)) string))))
282     (structure (cond
283                  ((eq (info :type :kind name) :instance)
284                   (setf (info :type :documentation name) string))
285                  ((info :typed-structure :info name)
286                   (setf (info :typed-structure :documentation name) string))))
287     (type (setf (info :type :documentation name) string))
288     (setf (setf (info :setf :documentation name) string))
289     (t
290      (when (typep name '(or symbol cons))
291        (setf (random-documentation name doc-type) string))))
292   string)
293
294 (defun random-documentation (name type)
295   (cdr (assoc type (info :random-documentation :stuff name))))
296
297 (defun (setf random-documentation) (new-value name type)
298   (let ((pair (assoc type (info :random-documentation :stuff name))))
299     (if pair
300         (setf (cdr pair) new-value)
301         (push (cons type new-value)
302               (info :random-documentation :stuff name))))
303   new-value)