1 ;;;; miscellaneous functions which use INFO
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.
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.
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)
29 (unless (legal-fun-name-p name
)
30 (compiler-error "illegal function name: ~S" name
)))
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
)))
38 ;;; Record a new function definition, and check its legality.
39 (defun proclaim-as-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
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 ()
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
))
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
)
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
73 (when (boundp '*free-funs
*) ; when compiling
74 (remhash name
*free-funs
*))
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
))
90 (let ((stem (second name
)))
91 (when (or (info :setf
:inverse stem
) (info :setf
:expander stem
))
93 "defining function ~S when ~S already has a SETF macro"
97 ;;; Make NAME no longer be a function name: clear everything back to
99 (defun undefine-fun-name (name)
101 (macrolet ((frob (&rest types
)
103 name
',(mapcar (lambda (x)
105 (meta-info-or-lose :function x
)))
107 ;; Note that this does not clear the :DEFINITION.
108 ;; That's correct, because if we lose the association between a
109 ;; symbol and its #<fdefn> object, it could lead to creation of
110 ;; a non-unique #<fdefn> for a name.
117 :inline-expansion-designator
122 ;;; part of what happens with DEFUN, also with some PCL stuff: Make
123 ;;; NAME known to be a function definition.
124 (defun become-defined-fun-name (name)
125 (proclaim-as-fun-name name
)
126 (when (eq (info :function
:where-from name
) :assumed
)
127 (setf (info :function
:where-from name
) :defined
)
128 (if (info :function
:assumed-type name
)
129 (clear-info :function
:assumed-type name
))))
131 ;;; Trivially wrap (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR FUN-NAME)
132 (declaim (ftype (function ((or symbol cons
)) list
) fun-name-inline-expansion
))
133 (defun fun-name-inline-expansion (fun-name)
134 (info :function
:inline-expansion-designator fun-name
))
136 ;;;; ANSI Common Lisp functions which are defined in terms of the info
139 (defun sb!xc
:macro-function
(symbol &optional env
)
141 "If SYMBOL names a macro in ENV, returns the expansion function,
142 else returns NIL. If ENV is unspecified or NIL, use the global environment
144 (declare (symbol symbol
))
145 (let* ((fenv (when env
(lexenv-funs env
)))
146 (local-def (cdr (assoc symbol fenv
))))
148 (if (and (consp local-def
) (eq (car local-def
) 'macro
))
151 (values (info :function
:macro-function symbol
)))))
153 (defun (setf sb
!xc
:macro-function
) (function symbol
&optional environment
)
154 (declare (symbol symbol
) (type function function
))
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"
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 (clear-info :function
:type symbol
)
167 (setf (info :function
:kind symbol
) :macro
)
168 (setf (info :function
:macro-function symbol
) function
)
169 (install-guard-function symbol
`(:macro
,symbol
) nil
))
172 ;; Set (SYMBOL-FUNCTION SYMBOL) to a closure that signals an error,
173 ;; preventing funcall/apply of macros and special operators.
174 (defun install-guard-function (symbol fun-name docstring
)
175 #+sb-xc-host
(declare (ignore fun-name
))
177 (setf (random-documentation symbol
'function
) docstring
))
179 ;; (SETF SYMBOL-FUNCTION) goes out of its way to disallow this closure,
180 ;; but we can trivially replicate its low-level effect.
181 (setf (fdefn-fun (find-or-create-fdefn symbol
))
182 (sb!impl
::set-closure-name
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 ;; SPECIAL-FORM-FUNCTION is a subtype of UNDEFINED-FUNCTION.
188 (error (if (eq (info :function
:kind symbol
) :special-form
)
189 'special-form-function
194 (defun fun-locally-defined-p (name env
)
196 (let ((fun (cdr (assoc name
(lexenv-funs env
) :test
#'equal
))))
197 (and fun
(not (global-var-p fun
))))))
199 (defun sb!xc
:compiler-macro-function
(name &optional env
)
201 "If NAME names a compiler-macro in ENV, return the expansion function, else
202 return NIL. Can be set with SETF when ENV is NIL."
203 (legal-fun-name-or-type-error name
)
204 ;; CLHS 3.2.2.1: Creating a lexical binding for the function name
205 ;; not only creates a new local function or macro definition, but
206 ;; also shadows[2] the compiler macro.
207 (unless (fun-locally-defined-p name env
)
208 ;; Note: CMU CL used to return NIL here when a NOTINLINE
209 ;; declaration was in force. That's fairly logical, given the
210 ;; specified effect of NOTINLINE declarations on compiler-macro
211 ;; expansion. However, (1) it doesn't seem to be consistent with
212 ;; the ANSI spec for COMPILER-MACRO-FUNCTION, and (2) it would
213 ;; give surprising behavior for (SETF (COMPILER-MACRO-FUNCTION
214 ;; FOO) ...) in the presence of a (PROCLAIM '(NOTINLINE FOO)). So
216 (values (info :function
:compiler-macro-function name
))))
218 (defun (setf sb
!xc
:compiler-macro-function
) (function name
&optional env
)
219 (declare (type (or symbol list
) name
)
220 (type (or function null
) function
))
222 ;; ANSI says this operation is undefined.
223 (error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL"))
224 (when (eq (info :function
:kind name
) :special-form
)
225 (error "~S names a special form." name
))
226 (with-single-package-locked-error
227 (:symbol name
"setting the compiler-macro-function of ~A")
228 (setf (info :function
:compiler-macro-function name
) function
)
231 ;;;; a subset of DOCUMENTATION functionality for bootstrapping
233 ;;; FDOCUMENTATION is like DOCUMENTATION, but with less functionality,
234 ;;; and implemented with DEFUN instead of DEFGENERIC so that it can
235 ;;; run before CLOS is set up. Supported DOC-TYPE values are
242 ;;; FIXME: Other types end up in INFO :RANDOM-DOCUMENTATION :STUFF. I
243 ;;; should add some code to monitor this and make sure that nothing is
244 ;;; unintentionally being sent to never never land this way.
245 ;;; FIXME: Rename FDOCUMENTATION to BDOCUMENTATION, by analogy with
246 ;;; DEF!STRUCT and DEF!MACRO and so forth. And consider simply saving
247 ;;; all the BDOCUMENTATION entries in a *BDOCUMENTATION* hash table
248 ;;; and slamming them into PCL once PCL gets going.
249 (defun fdocumentation (x doc-type
)
253 (symbol (values (info :variable
:documentation x
)))))
254 ;; FUNCTION is not used at the momemnt, just here for symmetry.
258 ((and (legal-fun-name-p x
) (fboundp x
))
259 (%fun-doc
(or (and (symbolp x
) (macro-function x
))
264 ((eq (info :type
:kind x
) :instance
)
265 (values (info :type
:documentation x
)))
266 ((info :typed-structure
:info x
)
267 (values (info :typed-structure
:documentation x
)))))))
270 (structure-class (values (info :type
:documentation
(class-name x
))))
271 (t (and (typep x
'symbol
) (values (info :type
:documentation x
))))))
272 (setf (values (info :setf
:documentation x
)))
275 (function (%fun-doc x
))
276 (package (package-doc-string x
))
277 (structure-class (values (info :type
:documentation
(class-name x
))))
279 (random-documentation x doc-type
))))
281 (when (typep x
'(or symbol cons
))
282 (random-documentation x doc-type
)))))
284 (defun (setf fdocumentation
) (string name doc-type
)
285 (declare (type (or null string
) string
))
287 (macrolet ((info-number (class type
)
288 (meta-info-number (meta-info-or-lose class type
))))
290 (variable (info-number :variable
:documentation
))
292 (cond ((eq (info :type
:kind name
) :instance
)
293 (info-number :type
:documentation
))
294 ((info :typed-structure
:info name
)
295 (info-number :typed-structure
:documentation
))))
296 (type (info-number :type
:documentation
))
297 (setf (info-number :setf
:documentation
))))))
300 (set-info-value name info-number string
)
301 (clear-info-values name
(list info-number
))))
302 ((eq doc-type
'function
)
303 ;; FIXME: this silently loses
304 ;; * (setf (documentation '(a bad name) 'function) "x") => "x"
305 ;; * (documentation '(a bad name) 'function) => NIL
306 ;; which is fine because as noted in pcl/documentation.lsp
307 ;; even for supported doc types an implementation is permitted
308 ;; to discard docs at any time
309 ;; but should a warning be issued just as for an unknown DOC-TYPE?
311 ;; And there's additional weirdness if you do, in this order -
312 ;; * (setf (documentation 'foo 'function) "hi")
313 ;; * (defun foo () "hey" 1)
314 ;; * (documentation 'foo 'function) => "hi" ; should be "hey"
315 ;; CLHS says regarding DEFUN:
316 ;; " Documentation is attached as a documentation string to
317 ;; /name/ (as kind function) and to the /function object/."
318 (when (legal-fun-name-p name
)
319 (setf (%fun-doc
(fdefinition name
)) string
)))
320 ((typep name
'(or symbol cons
))
321 (setf (random-documentation name doc-type
) string
))))
324 (defun random-documentation (name type
)
325 (cdr (assoc type
(info :random-documentation
:stuff name
))))
327 (defun (setf random-documentation
) (new-value name type
)
328 (let ((pair (assoc type
(info :random-documentation
:stuff name
))))
330 (setf (cdr pair
) new-value
)
331 (push (cons type new-value
)
332 (info :random-documentation
:stuff name
))))
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