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 ;; scrubbing old data I: possible collision with old definition
46 (ecase (info :function
:kind name
)
47 (:function
) ; happy case
48 ((nil)) ; another happy case
49 (:macro
; maybe-not-so-good case
50 (compiler-style-warn "~S was previously defined as a macro." name
)
51 (setf (info :function
:where-from name
) :assumed
)
52 (clear-info :function
:macro-function name
))))
54 ;; scrubbing old data II: dangling forward references
56 ;; (This could happen if someone executes PROCLAIM FTYPE at
57 ;; macroexpansion time, which is bad style, or at compile time, e.g.
58 ;; in EVAL-WHEN (:COMPILE) inside something like DEFSTRUCT, in which
59 ;; case it's reasonable style. Either way, NAME is no longer a free
61 (when (boundp '*free-funs
*) ; when compiling
62 (remhash name
*free-funs
*))
64 ;; recording the ordinary case
65 (setf (info :function
:kind name
) :function
)
66 (note-if-setf-fun-and-macro name
)
70 ;;; This is called to do something about SETF functions that overlap
71 ;;; with SETF macros. Perhaps we should interact with the user to see
72 ;;; whether the macro should be blown away, but for now just give a
73 ;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we
74 ;;; can't assume that they aren't just naming a function (SETF FOO)
75 ;;; for the heck of it. NAME is already known to be well-formed.
76 (defun note-if-setf-fun-and-macro (name)
78 (when (or (info :setf
:inverse name
)
79 (info :setf
:expander name
))
81 "defining as a SETF function a name that already has a SETF macro:~
86 ;;; Make NAME no longer be a function name: clear everything back to
88 (defun undefine-fun-name (name)
90 (macrolet ((frob (type &optional val
)
91 `(unless (eq (info :function
,type name
) ,val
)
92 (setf (info :function
,type name
) ,val
))))
94 (frob :type
(specifier-type 'function
))
95 (frob :where-from
:assumed
)
98 (frob :inline-expansion-designator
)
99 (frob :source-transform
)
100 (frob :structure-accessor
)
101 (frob :assumed-type
)))
104 ;;; part of what happens with DEFUN, also with some PCL stuff: Make
105 ;;; NAME known to be a function definition.
106 (defun become-defined-fun-name (name)
107 (proclaim-as-fun-name name
)
108 (when (eq (info :function
:where-from name
) :assumed
)
109 (setf (info :function
:where-from name
) :defined
)
110 (if (info :function
:assumed-type name
)
111 (setf (info :function
:assumed-type name
) nil
))))
113 ;;; Decode any raw (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR FUN-NAME)
114 ;;; value into a lambda expression, or return NIL if there is none.
115 (declaim (ftype (function ((or symbol cons
)) list
) fun-name-inline-expansion
))
116 (defun fun-name-inline-expansion (fun-name)
117 (let ((info (info :function
:inline-expansion-designator fun-name
)))
122 ;;;; ANSI Common Lisp functions which are defined in terms of the info
125 (defun sb!xc
:macro-function
(symbol &optional env
)
127 "If SYMBOL names a macro in ENV, returns the expansion function,
128 else returns NIL. If ENV is unspecified or NIL, use the global environment
130 (declare (symbol symbol
))
131 (let* ((fenv (when env
(lexenv-funs env
)))
132 (local-def (cdr (assoc symbol fenv
))))
134 (if (and (consp local-def
) (eq (car local-def
) 'macro
))
137 ((eq (info :function
:kind symbol
) :macro
)
138 (values (info :function
:macro-function symbol
)))
142 (defun (setf sb
!xc
:macro-function
) (function symbol
&optional environment
)
143 (declare (symbol symbol
) (type function function
))
145 ;; Note: Technically there could be an ENV optional argument to SETF
146 ;; MACRO-FUNCTION, but since ANSI says that the consequences of
147 ;; supplying a non-nil one are undefined, we don't allow it.
148 ;; (Thus our implementation of this unspecified behavior is to
149 ;; complain. SInce the behavior is unspecified, this is conforming.:-)
150 (error "Non-NIL environment argument in SETF of MACRO-FUNCTION ~S: ~S"
152 (when (eq (info :function
:kind symbol
) :special-form
)
153 (error "~S names a special form." symbol
))
154 (setf (info :function
:kind symbol
) :macro
)
155 (setf (info :function
:macro-function symbol
) function
)
156 ;; This is a nice thing to have in the target SBCL, but in the
157 ;; cross-compilation host it's not nice to mess with
158 ;; (SYMBOL-FUNCTION FOO) where FOO might be a symbol in the
159 ;; cross-compilation host's COMMON-LISP package.
161 (setf (symbol-function symbol
)
163 (declare (ignore args
))
164 ;; (ANSI specification of FUNCALL says that this should be
165 ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.)
166 (error 'undefined-function
:name symbol
)))
169 (defun fun-locally-defined-p (name env
)
171 (let ((fun (cdr (assoc name
(lexenv-funs env
) :test
#'equal
))))
172 (and fun
(not (global-var-p fun
))))))
174 (defun sb!xc
:compiler-macro-function
(name &optional env
)
176 "If NAME names a compiler-macro in ENV, return the expansion function, else
177 return NIL. Can be set with SETF when ENV is NIL."
178 (legal-fun-name-or-type-error name
)
179 ;; CLHS 3.2.2.1: Creating a lexical binding for the function name
180 ;; not only creates a new local function or macro definition, but
181 ;; also shadows[2] the compiler macro.
182 (unless (fun-locally-defined-p name env
)
183 ;; Note: CMU CL used to return NIL here when a NOTINLINE
184 ;; declaration was in force. That's fairly logical, given the
185 ;; specified effect of NOTINLINE declarations on compiler-macro
186 ;; expansion. However, (1) it doesn't seem to be consistent with
187 ;; the ANSI spec for COMPILER-MACRO-FUNCTION, and (2) it would
188 ;; give surprising behavior for (SETF (COMPILER-MACRO-FUNCTION
189 ;; FOO) ...) in the presence of a (PROCLAIM '(NOTINLINE FOO)). So
191 (values (info :function
:compiler-macro-function name
))))
193 (defun (setf sb
!xc
:compiler-macro-function
) (function name
&optional env
)
194 (declare (type (or symbol list
) name
)
195 (type (or function null
) function
))
197 ;; ANSI says this operation is undefined.
198 (error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL"))
199 (when (eq (info :function
:kind name
) :special-form
)
200 (error "~S names a special form." name
))
201 (with-single-package-locked-error
202 (:symbol name
"setting the compiler-macro-function of ~A")
203 (setf (info :function
:compiler-macro-function name
) function
)
206 ;;;; a subset of DOCUMENTATION functionality for bootstrapping
208 ;;; FDOCUMENTATION is like DOCUMENTATION, but with less functionality,
209 ;;; and implemented with DEFUN instead of DEFGENERIC so that it can
210 ;;; run before CLOS is set up. Supported DOC-TYPE values are
217 ;;; FIXME: Other types end up in INFO :RANDOM-DOCUMENTATION :STUFF. I
218 ;;; should add some code to monitor this and make sure that nothing is
219 ;;; unintentionally being sent to never never land this way.
220 ;;; FIXME: Rename FDOCUMENTATION to BDOCUMENTATION, by analogy with
221 ;;; DEF!STRUCT and DEF!MACRO and so forth. And consider simply saving
222 ;;; all the BDOCUMENTATION entries in a *BDOCUMENTATION* hash table
223 ;;; and slamming them into PCL once PCL gets going.
224 (defun fdocumentation (x doc-type
)
225 (flet ((try-cmucl-random-doc (x doc-type
)
226 (declare (symbol doc-type
))
228 (values (info :random-documentation
:stuff x
))))))
232 (symbol (values (info :variable
:documentation x
)))))
236 ((legal-fun-name-p x
)
237 ;; FIXME: Is it really right to make
238 ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to
239 ;; (DOCUMENTATION 'FOO 'FUNCTION)? That's what CMU CL
240 ;; did, so we do it, but I'm not sure it's what ANSI wants.
241 (values (info :function
:documentation
242 (fun-name-block-name x
))))))
246 ((eq (info :type
:kind x
) :instance
)
247 (values (info :type
:documentation x
)))
248 ((info :typed-structure
:info x
)
249 (values (info :typed-structure
:documentation x
)))))))
252 (structure-class (values (info :type
:documentation
(class-name x
))))
253 (t (and (typep x
'symbol
) (values (info :type
:documentation x
))))))
254 (setf (values (info :setf
:documentation x
)))
257 (function (%fun-doc x
))
258 (package (package-doc-string x
))
259 (structure-class (values (info :type
:documentation
(class-name x
))))
260 (symbol (try-cmucl-random-doc x doc-type
))))
263 ;; FIXME: This code comes from CMU CL, but
264 ;; TRY-CMUCL-RANDOM-DOC doesn't seem to be defined anywhere
265 ;; in CMU CL. Perhaps it could be defined by analogy with the
266 ;; corresponding SETF FDOCUMENTATION code.
267 (symbol (try-cmucl-random-doc x doc-type
)))))))
268 (defun (setf fdocumentation
) (string name doc-type
)
269 ;; FIXME: I think it should be possible to set documentation for
270 ;; things (e.g. compiler macros) named (SETF FOO). fndb.lisp
271 ;; declares DOC-TYPE to be a SYMBOL, which contradicts that. What
274 (variable (setf (info :variable
:documentation name
) string
))
275 (function (setf (info :function
:documentation name
) string
))
277 ((eq (info :type
:kind name
) :instance
)
278 (setf (info :type
:documentation name
) string
))
279 ((info :typed-structure
:info name
)
280 (setf (info :typed-structure
:documentation name
) string
))
282 (error "~S is not a structure name." name
))))
283 (type (setf (info :type
:documentation name
) string
))
284 (setf (setf (info :setf
:documentation name
) string
))
286 (let ((pair (assoc doc-type
(info :random-documentation
:stuff name
))))
288 (setf (cdr pair
) string
)
289 (push (cons doc-type string
)
290 (info :random-documentation
:stuff name
))))))