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 (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
)
149 "If SYMBOL names a macro in ENV, returns the expansion function,
150 else returns NIL. If ENV is unspecified or NIL, use the global environment
152 ;; local function definitions (ordinary) can shadow a global macro
154 #!+(and sb-fasteval
(host-feature sb-xc
))
155 (sb!interpreter
:basic-env
156 (multiple-value-bind (kind def
)
157 (sb!interpreter
:find-lexical-fun env symbol
)
159 (return-from sb
!xc
:macro-function
(when (eq kind
:macro
) def
)))))
161 (let ((def (cdr (assoc symbol
(lexenv-funs env
)))))
163 (return-from sb
!xc
:macro-function
164 (when (typep def
'(cons (eql macro
))) (cdr def
)))))))
165 (values (info :function
:macro-function symbol
)))
167 (defun (setf sb
!xc
:macro-function
) (function symbol
&optional environment
)
168 (declare (symbol symbol
) (type function function
))
170 ;; Note: Technically there could be an ENV optional argument to SETF
171 ;; MACRO-FUNCTION, but since ANSI says that the consequences of
172 ;; supplying a non-nil one are undefined, we don't allow it.
173 ;; (Thus our implementation of this unspecified behavior is to
174 ;; complain. SInce the behavior is unspecified, this is conforming.:-)
175 (error "Non-NIL environment argument in SETF of MACRO-FUNCTION ~S: ~S"
177 (when (eq (info :function
:kind symbol
) :special-form
)
178 (error "~S names a special form." symbol
))
179 (with-single-package-locked-error (:symbol symbol
"setting the macro-function of ~S")
180 (clear-info :function
:type symbol
)
181 (setf (info :function
:kind symbol
) :macro
)
182 (setf (info :function
:macro-function symbol
) function
)
183 #-sb-xc-host
(install-guard-function symbol
`(:macro
,symbol
) nil
))
186 ;; Set (SYMBOL-FUNCTION SYMBOL) to a closure that signals an error,
187 ;; preventing funcall/apply of macros and special operators.
189 (defun install-guard-function (symbol fun-name docstring
)
191 (setf (random-documentation symbol
'function
) docstring
))
192 ;; (SETF SYMBOL-FUNCTION) goes out of its way to disallow this closure,
193 ;; but we can trivially replicate its low-level effect.
194 (let ((fdefn (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
207 ;; For immobile-code, do something slightly different: fmakunbound,
208 ;; then assign the fdefn-fun slot to avoid consing a new closure trampoline.
210 (progn (fdefn-makunbound fdefn
)
211 ;; There is no :SET-TRANS for the primitive object's fdefn-fun slot,
212 ;; nor do we desire the full effect of %SET-FDEFN-FUN.
213 (setf (sap-ref-lispobj (int-sap (get-lisp-obj-address fdefn
))
214 (- (ash sb
!vm
:fdefn-fun-slot sb
!vm
:word-shift
)
215 sb
!vm
:other-pointer-lowtag
))
217 ;; The above would work, but there's no overhead when installing a closure
218 ;; the regular way, so just do that.
220 (setf (fdefn-fun fdefn
) closure
)))
222 (defun sb!xc
:compiler-macro-function
(name &optional env
)
223 "If NAME names a compiler-macro in ENV, return the expansion function, else
224 return NIL. Can be set with SETF when ENV is NIL."
225 (legal-fun-name-or-type-error name
)
226 ;; CLHS 3.2.2.1: Creating a lexical binding for the function name
227 ;; not only creates a new local function or macro definition, but
228 ;; also shadows[2] the compiler macro.
229 (unless (fun-locally-defined-p name env
)
230 ;; Note: CMU CL used to return NIL here when a NOTINLINE
231 ;; declaration was in force. That's fairly logical, given the
232 ;; specified effect of NOTINLINE declarations on compiler-macro
233 ;; expansion. However, (1) it doesn't seem to be consistent with
234 ;; the ANSI spec for COMPILER-MACRO-FUNCTION, and (2) it would
235 ;; give surprising behavior for (SETF (COMPILER-MACRO-FUNCTION
236 ;; FOO) ...) in the presence of a (PROCLAIM '(NOTINLINE FOO)). So
238 (values (info :function
:compiler-macro-function name
))))
240 ;;; FIXME: we don't generate redefinition warnings for these.
241 (defun (setf sb
!xc
:compiler-macro-function
) (function name
&optional env
)
242 (declare (type (or symbol list
) name
)
243 (type (or function null
) function
))
245 ;; ANSI says this operation is undefined.
246 (error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL"))
247 (when (eq (info :function
:kind name
) :special-form
)
248 (error "~S names a special form." name
))
249 (with-single-package-locked-error
250 (:symbol name
"setting the compiler-macro-function of ~A")
251 (setf (info :function
:compiler-macro-function name
) function
)
254 ;;;; a subset of DOCUMENTATION functionality for bootstrapping
256 ;;; FDOCUMENTATION is like DOCUMENTATION, but with less functionality,
257 ;;; and implemented with DEFUN instead of DEFGENERIC so that it can
258 ;;; run before CLOS is set up. Supported DOC-TYPE values are
265 ;;; FIXME: Other types end up in INFO :RANDOM-DOCUMENTATION :STUFF. I
266 ;;; should add some code to monitor this and make sure that nothing is
267 ;;; unintentionally being sent to never never land this way.
268 ;;; FIXME: Rename FDOCUMENTATION to BDOCUMENTATION, by analogy with
269 ;;; DEF!STRUCT and so forth. And consider simply saving
270 ;;; all the BDOCUMENTATION entries in a *BDOCUMENTATION* hash table
271 ;;; and slamming them into PCL once PCL gets going.
272 (defun (setf fdocumentation
) (string name doc-type
)
273 (declare (type (or null string
) string
))
274 #+sb-xc-host
(declare (ignore name doc-type
))
277 (macrolet ((info-number (class type
)
278 (meta-info-number (meta-info class type
))))
280 (variable (info-number :variable
:documentation
))
282 (cond ((eq (info :type
:kind name
) :instance
)
283 (info-number :type
:documentation
))
284 ((info :typed-structure
:info name
)
285 (info-number :typed-structure
:documentation
))))
286 (type (info-number :type
:documentation
))
287 (setf (info-number :setf
:documentation
))))))
290 (set-info-value name info-number string
)
291 (clear-info-values name
(list info-number
))))
292 ((eq doc-type
'function
)
293 ;; FIXME: this silently loses
294 ;; * (setf (documentation '(a bad name) 'function) "x") => "x"
295 ;; * (documentation '(a bad name) 'function) => NIL
296 ;; which is fine because as noted in pcl/documentation.lsp
297 ;; even for supported doc types an implementation is permitted
298 ;; to discard docs at any time
299 ;; but should a warning be issued just as for an unknown DOC-TYPE?
301 ;; And there's additional weirdness if you do, in this order -
302 ;; * (setf (documentation 'foo 'function) "hi")
303 ;; * (defun foo () "hey" 1)
304 ;; * (documentation 'foo 'function) => "hi" ; should be "hey"
305 ;; CLHS says regarding DEFUN:
306 ;; " Documentation is attached as a documentation string to
307 ;; /name/ (as kind function) and to the /function object/."
308 (cond ((not (legal-fun-name-p name
)))
309 ((not (equal (real-function-name name
) name
))
310 (setf (random-documentation name
'function
) string
))
312 (setf (%fun-doc
(fdefinition name
)) string
))))
313 ((typep name
'(or symbol cons
))
314 (setf (random-documentation name doc-type
) string
))))
318 (defun real-function-name (name)
319 ;; Resolve the actual name of the function named by NAME
320 ;; e.g. (setf (name-function 'x) #'car)
321 ;; (real-function-name 'x) => CAR
322 (cond ((not (fboundp name
))
325 (macro-function name
))
326 (let ((name (%fun-name
(macro-function name
))))
328 (eq (car name
) 'macro-function
)
331 (%fun-name
(fdefinition name
)))))
334 (defun random-documentation (name type
)
335 (cdr (assoc type
(info :random-documentation
:stuff name
))))
338 (defun (setf random-documentation
) (new-value name type
)
339 (let ((pair (assoc type
(info :random-documentation
:stuff name
))))
341 (setf (cdr pair
) new-value
)
342 (push (cons type new-value
)
343 (info :random-documentation
:stuff name
))))
346 ;; Return the number of calls to NAME that IR2 emitted as full calls,
347 ;; not counting calls via #'F that went untracked.
348 ;; Return 0 if the answer is nonzero but a warning was already signaled
349 ;; about any full calls were emitted. This return convention satisfies the
350 ;; intended use of this statistic - to decide whether to generate a warning
351 ;; about failure to inline NAME, which is shown at most once per name
352 ;; to avoid unleashing a flood of identical warnings.
353 (defun emitted-full-call-count (name)
354 (let ((status (car (info :function
:emitted-full-calls name
))))
355 (and (integerp status
)
356 ;; Bit 0 tells whether any call was NOT in the presence of
357 ;; a 'notinline' declaration, thus eligible to be inline.
358 ;; Bit 1 tells whether any warning was emitted yet.
359 (= (logand status
3) #b01
)
360 (ash status -
2)))) ; the call count as tracked by IR2