Enforce absence of warnings in self-hosted make-host-1
[sbcl.git] / src / compiler / info-functions.lisp
blobb51286286bb37ad566f9da55a58f896aff41cd7c
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.)
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.
18 (in-package "SB!C")
20 ;;;; internal utilities defined in terms of INFO
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)))
35 (compiler-error "illegal function name: ~S" name)))
36 (values))
38 ;;; Record a new function definition, and check its legality.
39 (defun proclaim-as-fun-name (name)
41 ;; legal name?
42 (check-fun-name name)
44 ;; KLUDGE: This can happen when eg. compiling a NAMED-LAMBDA, and isn't
45 ;; guarded against elsewhere -- so we want to assert package locks here. The
46 ;; reason we do it only when stomping on existing stuff is because we want
47 ;; to keep
48 ;; (WITHOUT-PACKAGE-LOCKS (DEFUN LOCKED:FOO ...))
49 ;; viable, which requires no compile-time violations in the harmless cases.
50 (with-single-package-locked-error ()
51 (flet ((assert-it ()
52 (assert-symbol-home-package-unlocked name "proclaiming ~S as a function")))
54 (let ((kind (info :function :kind name)))
55 ;; scrubbing old data I: possible collision with a macro
56 (when (and (fboundp name) (eq :macro kind))
57 (assert-it)
58 (compiler-style-warn "~S was previously defined as a macro." name)
59 (setf (info :function :where-from name) :assumed)
60 (clear-info :function :macro-function name))
62 (unless (eq :function kind)
63 (assert-it)
64 (setf (info :function :kind name) :function)))))
66 ;; scrubbing old data II: dangling forward references
68 ;; (This could happen if someone executes PROCLAIM FTYPE at
69 ;; macroexpansion time, which is bad style, or at compile time, e.g.
70 ;; in EVAL-WHEN (:COMPILE) inside something like DEFSTRUCT, in which
71 ;; case it's reasonable style. Either way, NAME is no longer a free
72 ;; function.)
73 (when (boundp '*free-funs*) ; when compiling
74 (remhash name *free-funs*))
76 (values))
78 ;;; This is called to do something about SETF functions that overlap
79 ;;; with SETF macros. Perhaps we should interact with the user to see
80 ;;; whether the macro should be blown away, but for now just give a
81 ;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we
82 ;;; can't assume that they aren't just naming a function (SETF FOO)
83 ;;; for the heck of it. NAME is already known to be well-formed.
84 (defun warn-if-setf-macro (name)
85 ;; Never warn about this situation when running the cross-compiler.
86 ;; SBCL provides expanders/inverses *and* functions for most SETFable things
87 ;; even when CLHS does not specifically state that #'(SETF x) exists.
88 #+sb-xc-host (declare (ignore name))
89 #-sb-xc-host
90 (let ((stem (second name)))
91 (when (info :setf :expander stem)
92 (compiler-style-warn
93 "defining function ~S when ~S already has a SETF macro"
94 name stem)))
95 (values))
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 (&rest types)
102 `(clear-info-values
103 name ',(mapcar (lambda (x)
104 (meta-info-number (meta-info :function x)))
105 types))))
106 ;; Note that this does not clear the :DEFINITION.
107 ;; That's correct, because if we lose the association between a
108 ;; symbol and its #<fdefn> object, it could lead to creation of
109 ;; a non-unique #<fdefn> for a name.
110 (frob :info
111 :type ; Hmm. What if it was proclaimed- shouldn't it stay?
112 :where-from ; Ditto.
113 :inlinep
114 :kind
115 :macro-function
116 :inline-expansion-designator
117 :source-transform
118 :assumed-type)))
119 (values))
121 ;;; part of what happens with DEFUN, also with some PCL stuff: Make
122 ;;; NAME known to be a function definition.
123 (defun become-defined-fun-name (name)
124 (proclaim-as-fun-name name)
125 (when (eq (info :function :where-from name) :assumed)
126 (setf (info :function :where-from name) :defined)
127 (if (info :function :assumed-type name)
128 (clear-info :function :assumed-type name))))
130 ;;; Trivially wrap (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR FUN-NAME)
131 (declaim (ftype (function ((or symbol cons)) list) fun-name-inline-expansion))
132 (defun fun-name-inline-expansion (fun-name)
133 (multiple-value-bind (answer winp)
134 (info :function :inline-expansion-designator fun-name)
135 (when (and (not winp) (symbolp fun-name))
136 (let ((info (info :function :type fun-name)))
137 (when (typep info 'defstruct-description)
138 (let ((spec (assq fun-name (dd-constructors info))))
139 (aver spec)
140 (setq answer `(lambda ,@(structure-ctor-lambda-parts
141 info (cdr spec)))
142 winp t)))))
143 (values answer winp)))
145 ;;;; ANSI Common Lisp functions which are defined in terms of the info
146 ;;;; database
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 environment
152 only."
153 ;; local function definitions (ordinary) can shadow a global macro
154 (typecase env
155 #!+(and sb-fasteval (host-feature sb-xc))
156 (sb!interpreter:basic-env
157 (multiple-value-bind (kind def)
158 (sb!interpreter:find-lexical-fun env symbol)
159 (when def
160 (return-from sb!xc:macro-function (when (eq kind :macro) def)))))
161 (lexenv
162 (let ((def (cdr (assoc symbol (lexenv-funs env)))))
163 (when def
164 (return-from sb!xc:macro-function
165 (when (typep def '(cons (eql macro))) (cdr def)))))))
166 (values (info :function :macro-function symbol)))
168 (defun (setf sb!xc:macro-function) (function symbol &optional environment)
169 (declare (symbol symbol) (type function function))
170 (when environment
171 ;; Note: Technically there could be an ENV optional argument to SETF
172 ;; MACRO-FUNCTION, but since ANSI says that the consequences of
173 ;; supplying a non-nil one are undefined, we don't allow it.
174 ;; (Thus our implementation of this unspecified behavior is to
175 ;; complain. SInce the behavior is unspecified, this is conforming.:-)
176 (error "Non-NIL environment argument in SETF of MACRO-FUNCTION ~S: ~S"
177 symbol environment))
178 (when (eq (info :function :kind symbol) :special-form)
179 (error "~S names a special form." symbol))
180 (with-single-package-locked-error (:symbol symbol "setting the macro-function of ~S")
181 (clear-info :function :type symbol)
182 (setf (info :function :kind symbol) :macro)
183 (setf (info :function :macro-function symbol) function)
184 #-sb-xc-host (install-guard-function symbol `(:macro ,symbol) nil))
185 function)
187 ;; Set (SYMBOL-FUNCTION SYMBOL) to a closure that signals an error,
188 ;; preventing funcall/apply of macros and special operators.
189 #-sb-xc-host
190 (defun install-guard-function (symbol fun-name docstring)
191 (when docstring
192 (setf (random-documentation symbol 'function) docstring))
193 ;; (SETF SYMBOL-FUNCTION) goes out of its way to disallow this closure,
194 ;; but we can trivially replicate its low-level effect.
195 (setf (fdefn-fun (find-or-create-fdefn symbol))
196 (sb!impl::set-closure-name
197 (lambda (&rest args)
198 (declare (ignore args))
199 ;; ANSI specification of FUNCALL says that this should be
200 ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.
201 ;; SPECIAL-FORM-FUNCTION is a subtype of UNDEFINED-FUNCTION.
202 (error (if (eq (info :function :kind symbol) :special-form)
203 'special-form-function
204 'undefined-function)
205 :name symbol))
206 fun-name)))
208 (defun sb!xc:compiler-macro-function (name &optional env)
209 #!+sb-doc
210 "If NAME names a compiler-macro in ENV, return the expansion function, else
211 return NIL. Can be set with SETF when ENV is NIL."
212 (legal-fun-name-or-type-error name)
213 ;; CLHS 3.2.2.1: Creating a lexical binding for the function name
214 ;; not only creates a new local function or macro definition, but
215 ;; also shadows[2] the compiler macro.
216 (unless (fun-locally-defined-p name env)
217 ;; Note: CMU CL used to return NIL here when a NOTINLINE
218 ;; declaration was in force. That's fairly logical, given the
219 ;; specified effect of NOTINLINE declarations on compiler-macro
220 ;; expansion. However, (1) it doesn't seem to be consistent with
221 ;; the ANSI spec for COMPILER-MACRO-FUNCTION, and (2) it would
222 ;; give surprising behavior for (SETF (COMPILER-MACRO-FUNCTION
223 ;; FOO) ...) in the presence of a (PROCLAIM '(NOTINLINE FOO)). So
224 ;; we don't do it.
225 (values (info :function :compiler-macro-function name))))
227 (defun (setf sb!xc:compiler-macro-function) (function name &optional env)
228 (declare (type (or symbol list) name)
229 (type (or function null) function))
230 (when env
231 ;; ANSI says this operation is undefined.
232 (error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL"))
233 (when (eq (info :function :kind name) :special-form)
234 (error "~S names a special form." name))
235 (with-single-package-locked-error
236 (:symbol name "setting the compiler-macro-function of ~A")
237 (setf (info :function :compiler-macro-function name) function)
238 function))
240 ;;;; a subset of DOCUMENTATION functionality for bootstrapping
242 ;;; FDOCUMENTATION is like DOCUMENTATION, but with less functionality,
243 ;;; and implemented with DEFUN instead of DEFGENERIC so that it can
244 ;;; run before CLOS is set up. Supported DOC-TYPE values are
245 ;;; FUNCTION
246 ;;; SETF
247 ;;; STRUCTURE
248 ;;; T
249 ;;; TYPE
250 ;;; VARIABLE
251 ;;; FIXME: Other types end up in INFO :RANDOM-DOCUMENTATION :STUFF. I
252 ;;; should add some code to monitor this and make sure that nothing is
253 ;;; unintentionally being sent to never never land this way.
254 ;;; FIXME: Rename FDOCUMENTATION to BDOCUMENTATION, by analogy with
255 ;;; DEF!STRUCT and so forth. And consider simply saving
256 ;;; all the BDOCUMENTATION entries in a *BDOCUMENTATION* hash table
257 ;;; and slamming them into PCL once PCL gets going.
258 (defun (setf fdocumentation) (string name doc-type)
259 (declare (type (or null string) string))
260 #+sb-xc-host (declare (ignore name doc-type))
261 #-sb-xc-host
262 (let ((info-number
263 (macrolet ((info-number (class type)
264 (meta-info-number (meta-info class type))))
265 (case doc-type
266 (variable (info-number :variable :documentation))
267 (structure
268 (cond ((eq (info :type :kind name) :instance)
269 (info-number :type :documentation))
270 ((info :typed-structure :info name)
271 (info-number :typed-structure :documentation))))
272 (type (info-number :type :documentation))
273 (setf (info-number :setf :documentation))))))
274 (cond (info-number
275 (if string
276 (set-info-value name info-number string)
277 (clear-info-values name (list info-number))))
278 ((eq doc-type 'function)
279 ;; FIXME: this silently loses
280 ;; * (setf (documentation '(a bad name) 'function) "x") => "x"
281 ;; * (documentation '(a bad name) 'function) => NIL
282 ;; which is fine because as noted in pcl/documentation.lsp
283 ;; even for supported doc types an implementation is permitted
284 ;; to discard docs at any time
285 ;; but should a warning be issued just as for an unknown DOC-TYPE?
287 ;; And there's additional weirdness if you do, in this order -
288 ;; * (setf (documentation 'foo 'function) "hi")
289 ;; * (defun foo () "hey" 1)
290 ;; * (documentation 'foo 'function) => "hi" ; should be "hey"
291 ;; CLHS says regarding DEFUN:
292 ;; " Documentation is attached as a documentation string to
293 ;; /name/ (as kind function) and to the /function object/."
294 (cond ((not (legal-fun-name-p name)))
295 ((not (equal (real-function-name name) name))
296 (setf (random-documentation name 'function) string))
298 (setf (%fun-doc (fdefinition name)) string))))
299 ((typep name '(or symbol cons))
300 (setf (random-documentation name doc-type) string))))
301 string)
303 #-sb-xc-host
304 (defun real-function-name (name)
305 ;; Resolve the actual name of the function named by NAME
306 ;; e.g. (setf (name-function 'x) #'car)
307 ;; (real-function-name 'x) => CAR
308 (cond ((not (fboundp name))
309 nil)
310 ((and (symbolp name)
311 (special-operator-p name))
312 (%fun-name (fdefinition name)))
313 ((and (symbolp name)
314 (macro-function name))
315 (let ((name (%fun-name (macro-function name))))
316 (and (consp name)
317 (eq (car name) 'macro-function)
318 (cadr name))))
320 (sb!impl::fun-name (fdefinition name)))))
322 #-sb-xc-host
323 (defun random-documentation (name type)
324 (cdr (assoc type (info :random-documentation :stuff name))))
326 #-sb-xc-host
327 (defun (setf random-documentation) (new-value name type)
328 (let ((pair (assoc type (info :random-documentation :stuff name))))
329 (if pair
330 (setf (cdr pair) new-value)
331 (push (cons type new-value)
332 (info :random-documentation :stuff name))))
333 new-value)
335 ;; Return the number of calls to NAME that IR2 emitted as full calls,
336 ;; not counting calls via #'F that went untracked.
337 ;; Return 0 if the answer is nonzero but a warning was already signaled
338 ;; about any full calls were emitted. This return convention satisfies the
339 ;; intended use of this statistic - to decide whether to generate a warning
340 ;; about failure to inline NAME, which is shown at most once per name
341 ;; to avoid unleashing a flood of identical warnings.
342 (defun emitted-full-call-count (name)
343 (let ((status (car (info :function :emitted-full-calls name))))
344 (and (integerp status)
345 ;; Bit 0 tells whether any call was NOT in the presence of
346 ;; a 'notinline' declaration, thus eligible to be inline.
347 ;; Bit 1 tells whether any warning was emitted yet.
348 (= (logand status 3) #b01)
349 (ash status -2)))) ; the call count as tracked by IR2