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 (defun check-variable-name (name &key
23 (context "local variable")
24 (signal-via #'compiler-error
))
25 (unless (legal-variable-name-p name
)
26 (funcall signal-via
"~@<~S~[~; is a keyword and~; is not a symbol and~
27 ~] cannot be used as a ~A.~@:>"
36 ;;; Check that NAME is a valid function name, returning the name if
37 ;;; OK, and signalling an error if not. In addition to checking for
38 ;;; basic well-formedness, we also check that symbol names are not NIL
39 ;;; or the name of a special form.
40 (defun check-fun-name (name)
43 (unless (legal-fun-name-p name
)
44 (compiler-error "~@<Illegal function name: ~S.~@:>" name
)))
46 (when (eq (info :function
:kind name
) :special-form
)
47 (compiler-error "~@<Special form is an illegal function name: ~S.~@:>"
50 (compiler-error "~@<Illegal function name: ~S.~@:>" name
)))
53 ;;; Record a new function definition, and check its legality.
54 (defun proclaim-as-fun-name (name)
59 ;; KLUDGE: This can happen when eg. compiling a NAMED-LAMBDA, and isn't
60 ;; guarded against elsewhere -- so we want to assert package locks here. The
61 ;; reason we do it only when stomping on existing stuff is because we want
63 ;; (WITHOUT-PACKAGE-LOCKS (DEFUN LOCKED:FOO ...))
64 ;; viable, which requires no compile-time violations in the harmless cases.
65 (with-single-package-locked-error ()
67 (assert-symbol-home-package-unlocked name
"proclaiming ~S as a function")))
69 (let ((kind (info :function
:kind name
)))
70 ;; scrubbing old data I: possible collision with a macro
71 (when (and (fboundp name
) (eq :macro kind
))
73 (compiler-style-warn "~S was previously defined as a macro." name
)
74 (setf (info :function
:where-from name
) :assumed
)
75 (clear-info :function
:macro-function name
))
77 (unless (eq :function kind
)
79 (setf (info :function
:kind name
) :function
)))))
81 ;; scrubbing old data II: dangling forward references
83 ;; (This could happen if someone executes PROCLAIM FTYPE at
84 ;; macroexpansion time, which is bad style, or at compile time, e.g.
85 ;; in EVAL-WHEN (:COMPILE) inside something like DEFSTRUCT, in which
86 ;; case it's reasonable style. Either way, NAME is no longer a free
88 (when (boundp '*free-funs
*) ; when compiling
89 (remhash name
*free-funs
*))
93 ;;; This is called to do something about SETF functions that overlap
94 ;;; with SETF macros. Perhaps we should interact with the user to see
95 ;;; whether the macro should be blown away, but for now just give a
96 ;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we
97 ;;; can't assume that they aren't just naming a function (SETF FOO)
98 ;;; for the heck of it. NAME is already known to be well-formed.
99 (defun warn-if-setf-macro (name)
100 ;; Never warn about this situation when running the cross-compiler.
101 ;; SBCL provides expanders/inverses *and* functions for most SETFable things
102 ;; even when CLHS does not specifically state that #'(SETF x) exists.
103 #+sb-xc-host
(declare (ignore name
))
105 (let ((stem (second name
)))
106 (when (info :setf
:expander stem
)
108 "defining function ~S when ~S already has a SETF macro"
112 ;;; Make NAME no longer be a function name: clear everything back to
114 (defun undefine-fun-name (name)
116 (macrolet ((frob (&rest types
)
118 name
',(mapcar (lambda (x)
119 (meta-info-number (meta-info :function x
)))
121 ;; Note that this does not clear the :DEFINITION.
122 ;; That's correct, because if we lose the association between a
123 ;; symbol and its #<fdefn> object, it could lead to creation of
124 ;; a non-unique #<fdefn> for a name.
126 :type
; Hmm. What if it was proclaimed- shouldn't it stay?
131 :inline-expansion-designator
136 ;;; part of what happens with DEFUN, also with some PCL stuff: Make
137 ;;; NAME known to be a function definition.
138 (defun become-defined-fun-name (name)
139 (proclaim-as-fun-name name
)
140 (when (eq (info :function
:where-from name
) :assumed
)
141 (setf (info :function
:where-from name
) :defined
)
142 (if (info :function
:assumed-type name
)
143 (clear-info :function
:assumed-type name
))))
145 ;;; Trivially wrap (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR FUN-NAME)
146 (declaim (ftype (function ((or symbol cons
)) list
) fun-name-inline-expansion
))
147 (defun fun-name-inline-expansion (fun-name)
148 (multiple-value-bind (answer winp
)
149 (info :function
:inline-expansion-designator fun-name
)
150 (when (and (not winp
) (symbolp fun-name
))
151 (let ((info (info :function
:type fun-name
)))
152 (when (typep info
'defstruct-description
)
153 (let ((spec (assq fun-name
(dd-constructors info
))))
155 (setq answer
`(lambda ,@(structure-ctor-lambda-parts
158 (values answer winp
)))
160 ;;;; ANSI Common Lisp functions which are defined in terms of the info
163 (defun sb!xc
:macro-function
(symbol &optional env
)
164 "If SYMBOL names a macro in ENV, returns the expansion function,
165 else returns NIL. If ENV is unspecified or NIL, use the global environment
167 ;; local function definitions (ordinary) can shadow a global macro
169 #!+(and sb-fasteval
(host-feature sb-xc
))
170 (sb!interpreter
:basic-env
171 (multiple-value-bind (kind def
)
172 (sb!interpreter
:find-lexical-fun env symbol
)
174 (return-from sb
!xc
:macro-function
(when (eq kind
:macro
) def
)))))
176 (let ((def (cdr (assoc symbol
(lexenv-funs env
)))))
178 (return-from sb
!xc
:macro-function
179 (when (typep def
'(cons (eql macro
))) (cdr def
)))))))
180 (values (info :function
:macro-function symbol
)))
182 (defun (setf sb
!xc
:macro-function
) (function symbol
&optional environment
)
183 (declare (symbol symbol
) (type function function
))
185 ;; Note: Technically there could be an ENV optional argument to SETF
186 ;; MACRO-FUNCTION, but since ANSI says that the consequences of
187 ;; supplying a non-nil one are undefined, we don't allow it.
188 ;; (Thus our implementation of this unspecified behavior is to
189 ;; complain. SInce the behavior is unspecified, this is conforming.:-)
190 (error "Non-NIL environment argument in SETF of MACRO-FUNCTION ~S: ~S"
192 (when (eq (info :function
:kind symbol
) :special-form
)
193 (error "~S names a special form." symbol
))
194 (with-single-package-locked-error (:symbol symbol
"setting the macro-function of ~S")
195 (clear-info :function
:type symbol
)
196 (setf (info :function
:kind symbol
) :macro
)
197 (setf (info :function
:macro-function symbol
) function
)
198 #-sb-xc-host
(install-guard-function symbol
`(:macro
,symbol
) nil
))
201 ;; Set (SYMBOL-FUNCTION SYMBOL) to a closure that signals an error,
202 ;; preventing funcall/apply of macros and special operators.
204 (defun install-guard-function (symbol fun-name docstring
)
206 (setf (random-documentation symbol
'function
) docstring
))
207 ;; (SETF SYMBOL-FUNCTION) goes out of its way to disallow this closure,
208 ;; but we can trivially replicate its low-level effect.
209 (let ((fdefn (find-or-create-fdefn symbol
))
213 (declare (ignore args
))
214 ;; ANSI specification of FUNCALL says that this should be
215 ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.
216 ;; SPECIAL-FORM-FUNCTION is a subtype of UNDEFINED-FUNCTION.
217 (error (if (eq (info :function
:kind symbol
) :special-form
)
218 'special-form-function
223 ;; For immobile-code, do something slightly different: fmakunbound,
224 ;; then assign the fdefn-fun slot to avoid consing a new closure trampoline.
226 (progn (fdefn-makunbound fdefn
)
227 ;; There is no :SET-TRANS for the primitive object's fdefn-fun slot,
228 ;; nor do we desire the full effect of %SET-FDEFN-FUN.
229 (setf (sap-ref-lispobj (int-sap (get-lisp-obj-address fdefn
))
230 (- (ash sb
!vm
:fdefn-fun-slot sb
!vm
:word-shift
)
231 sb
!vm
:other-pointer-lowtag
))
233 ;; The above would work, but there's no overhead when installing a closure
234 ;; the regular way, so just do that.
236 (setf (fdefn-fun fdefn
) closure
)))
238 (defun sb!xc
:compiler-macro-function
(name &optional env
)
239 "If NAME names a compiler-macro in ENV, return the expansion function, else
240 return NIL. Can be set with SETF when ENV is NIL."
241 (legal-fun-name-or-type-error name
)
242 ;; CLHS 3.2.2.1: Creating a lexical binding for the function name
243 ;; not only creates a new local function or macro definition, but
244 ;; also shadows[2] the compiler macro.
245 (unless (fun-locally-defined-p name env
)
246 ;; Note: CMU CL used to return NIL here when a NOTINLINE
247 ;; declaration was in force. That's fairly logical, given the
248 ;; specified effect of NOTINLINE declarations on compiler-macro
249 ;; expansion. However, (1) it doesn't seem to be consistent with
250 ;; the ANSI spec for COMPILER-MACRO-FUNCTION, and (2) it would
251 ;; give surprising behavior for (SETF (COMPILER-MACRO-FUNCTION
252 ;; FOO) ...) in the presence of a (PROCLAIM '(NOTINLINE FOO)). So
254 (values (info :function
:compiler-macro-function name
))))
256 ;;; FIXME: we don't generate redefinition warnings for these.
257 (defun (setf sb
!xc
:compiler-macro-function
) (function name
&optional env
)
258 (declare (type (or symbol list
) name
)
259 (type (or function null
) function
))
261 ;; ANSI says this operation is undefined.
262 (error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL"))
263 (when (eq (info :function
:kind name
) :special-form
)
264 (error "~S names a special form." name
))
265 (with-single-package-locked-error
266 (:symbol name
"setting the compiler-macro-function of ~A")
267 (setf (info :function
:compiler-macro-function name
) function
)
270 ;;;; a subset of DOCUMENTATION functionality for bootstrapping
272 ;;; FDOCUMENTATION is like DOCUMENTATION, but with less functionality,
273 ;;; and implemented with DEFUN instead of DEFGENERIC so that it can
274 ;;; run before CLOS is set up. Supported DOC-TYPE values are
281 ;;; FIXME: Other types end up in INFO :RANDOM-DOCUMENTATION :STUFF. I
282 ;;; should add some code to monitor this and make sure that nothing is
283 ;;; unintentionally being sent to never never land this way.
284 ;;; FIXME: Rename FDOCUMENTATION to BDOCUMENTATION, by analogy with
285 ;;; DEF!STRUCT and so forth. And consider simply saving
286 ;;; all the BDOCUMENTATION entries in a *BDOCUMENTATION* hash table
287 ;;; and slamming them into PCL once PCL gets going.
288 (defun (setf fdocumentation
) (string name doc-type
)
289 (declare (type (or null string
) string
))
290 #+sb-xc-host
(declare (ignore name doc-type
))
293 (macrolet ((info-number (class type
)
294 (meta-info-number (meta-info class type
))))
296 (variable (info-number :variable
:documentation
))
298 (cond ((eq (info :type
:kind name
) :instance
)
299 (info-number :type
:documentation
))
300 ((info :typed-structure
:info name
)
301 (info-number :typed-structure
:documentation
))))
302 (type (info-number :type
:documentation
))
303 (setf (info-number :setf
:documentation
))))))
306 (set-info-value name info-number string
)
307 (clear-info-values name
(list info-number
))))
308 ((eq doc-type
'function
)
309 ;; FIXME: this silently loses
310 ;; * (setf (documentation '(a bad name) 'function) "x") => "x"
311 ;; * (documentation '(a bad name) 'function) => NIL
312 ;; which is fine because as noted in pcl/documentation.lsp
313 ;; even for supported doc types an implementation is permitted
314 ;; to discard docs at any time
315 ;; but should a warning be issued just as for an unknown DOC-TYPE?
317 ;; And there's additional weirdness if you do, in this order -
318 ;; * (setf (documentation 'foo 'function) "hi")
319 ;; * (defun foo () "hey" 1)
320 ;; * (documentation 'foo 'function) => "hi" ; should be "hey"
321 ;; CLHS says regarding DEFUN:
322 ;; " Documentation is attached as a documentation string to
323 ;; /name/ (as kind function) and to the /function object/."
324 (cond ((not (legal-fun-name-p name
)))
325 ((not (equal (real-function-name name
) name
))
326 (setf (random-documentation name
'function
) string
))
328 (setf (%fun-doc
(fdefinition name
)) string
))))
329 ((typep name
'(or symbol cons
))
330 (setf (random-documentation name doc-type
) string
))))
334 (defun real-function-name (name)
335 ;; Resolve the actual name of the function named by NAME
336 ;; e.g. (setf (name-function 'x) #'car)
337 ;; (real-function-name 'x) => CAR
338 (cond ((not (fboundp name
))
341 (macro-function name
))
342 (let ((name (%fun-name
(macro-function name
))))
344 (eq (car name
) 'macro-function
)
347 (%fun-name
(fdefinition name
)))))
350 (defun random-documentation (name type
)
351 (cdr (assoc type
(info :random-documentation
:stuff name
))))
354 (defun (setf random-documentation
) (new-value name type
)
355 (let ((pair (assoc type
(info :random-documentation
:stuff name
))))
357 (setf (cdr pair
) new-value
)
358 (push (cons type new-value
)
359 (info :random-documentation
:stuff name
))))
362 ;; Return the number of calls to NAME that IR2 emitted as full calls,
363 ;; not counting calls via #'F that went untracked.
364 ;; Return 0 if the answer is nonzero but a warning was already signaled
365 ;; about any full calls were emitted. This return convention satisfies the
366 ;; intended use of this statistic - to decide whether to generate a warning
367 ;; about failure to inline NAME, which is shown at most once per name
368 ;; to avoid unleashing a flood of identical warnings.
369 (defun emitted-full-call-count (name)
370 (let ((status (car (info :function
:emitted-full-calls name
))))
371 (and (integerp status
)
372 ;; Bit 0 tells whether any call was NOT in the presence of
373 ;; a 'notinline' declaration, thus eligible to be inline.
374 ;; Bit 1 tells whether any warning was emitted yet.
375 (= (logand status
3) #b01
)
376 (ash status -
2)))) ; the call count as tracked by IR2