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)
104 (meta-info-number (meta-info :function x
)))
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.
111 :type
; Hmm. What if it was proclaimed- shouldn't it stay?
116 :inline-expansion-designator
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
))))
140 (setq answer
`(lambda ,@(structure-ctor-lambda-parts
143 (values answer winp
)))
145 ;;;; ANSI Common Lisp functions which are defined in terms of the info
148 (defun sb!xc
:macro-function
(symbol &optional env
)
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
153 ;; local function definitions (ordinary) can shadow a global macro
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
)
160 (return-from sb
!xc
:macro-function
(when (eq kind
:macro
) def
)))))
162 (let ((def (cdr (assoc symbol
(lexenv-funs env
)))))
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
))
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"
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
))
187 ;; Set (SYMBOL-FUNCTION SYMBOL) to a closure that signals an error,
188 ;; preventing funcall/apply of macros and special operators.
190 (defun install-guard-function (symbol fun-name 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
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
208 (defun sb!xc
:compiler-macro-function
(name &optional env
)
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
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
))
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
)
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
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 DEF!MACRO 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
))
263 (macrolet ((info-number (class type
)
264 (meta-info-number (meta-info class type
))))
266 (variable (info-number :variable
:documentation
))
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
))))))
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 (when (legal-fun-name-p name
)
295 (setf (%fun-doc
(fdefinition name
)) string
)))
296 ((typep name
'(or symbol cons
))
297 (setf (random-documentation name doc-type
) string
))))
301 (defun random-documentation (name type
)
302 (cdr (assoc type
(info :random-documentation
:stuff name
))))
305 (defun (setf random-documentation
) (new-value name type
)
306 (let ((pair (assoc type
(info :random-documentation
:stuff name
))))
308 (setf (cdr pair
) new-value
)
309 (push (cons type new-value
)
310 (info :random-documentation
:stuff name
))))
313 ;; Return the number of calls to NAME that IR2 emitted as full calls,
314 ;; not counting calls via #'F that went untracked.
315 ;; Return 0 if the answer is nonzero but a warning was already signaled
316 ;; about any full calls were emitted. This return convention satisfies the
317 ;; intended use of this statistic - to decide whether to generate a warning
318 ;; about failure to inline NAME, which is shown at most once per name
319 ;; to avoid unleashing a flood of identical warnings.
320 (defun emitted-full-call-count (name)
321 (let ((status (car (info :function
:emitted-full-calls name
))))
322 (and (integerp status
)
323 ;; Bit 0 tells whether any call was NOT in the presence of
324 ;; a 'notinline' declaration, thus eligible to be inline.
325 ;; Bit 1 tells whether any warning was emitted yet.
326 (= (logand status
3) #b01
)
327 (ash status -
2)))) ; the call count as tracked by IR2