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 ;;; Check the legality of a function name that is being introduced.
21 ;;; -- If it names a macro, then give a warning and blast the macro
23 ;;; -- If it is a structure slot accessor, give a warning and blast
25 ;;; -- Check for conflicting setf macros.
26 (declaim (ftype (function ((or symbol cons)) t) proclaim-as-function-name))
27 (defun proclaim-as-function-name (name)
28 (check-function-name name)
29 (ecase (info :function :kind name)
31 (let ((accessor-for (info :function :accessor-for name)))
34 "Undefining structure type:~% ~S~@
35 so that this slot accessor can be redefined:~% ~S"
36 (sb!xc:class-name accessor-for) name)
37 ;; FIXME: This is such weird, unfriendly behavior.. (What if
38 ;; the user didn't want his structure blasted?) It probably
39 ;; violates ANSI, too. (Check this.) Perhaps instead of
40 ;; undefining the structure, we should attach the lost
41 ;; accessor function to SB-EXT:LOST-STRUCTURE-ACCESSORS on
42 ;; the property list of the symbol which names the structure?
43 (undefine-structure accessor-for)
44 (setf (info :function :kind name) :function))))
46 (compiler-style-warning "~S previously defined as a macro." name)
47 (setf (info :function :kind name) :function)
48 (setf (info :function :where-from name) :assumed)
49 (clear-info :function :macro-function name))
51 (setf (info :function :kind name) :function)))
52 (note-if-setf-function-and-macro name)
55 ;;; Make NAME no longer be a function name: clear everything back to the
57 (defun undefine-function-name (name)
59 (macrolet ((frob (type &optional val)
60 `(unless (eq (info :function ,type name) ,val)
61 (setf (info :function ,type name) ,val))))
63 (frob :type (specifier-type 'function))
64 (frob :where-from :assumed)
68 (frob :inline-expansion)
69 (frob :source-transform)
70 (frob :assumed-type)))
73 ;;;; ANSI Common Lisp functions which are defined in terms of the info
76 (defun sb!xc:constantp (object &optional environment)
78 "True of any Lisp object that has a constant value: types that eval to
79 themselves, keywords, constants, and list whose car is QUOTE."
80 ;; FIXME: Should STRUCTURE-OBJECT and/or STANDARD-OBJECT be here?
81 ;; They eval to themselves..
83 ;; KLUDGE: Someday it might be nice to make the code recognize foldable
84 ;; functions and call itself recursively on their arguments, so that
85 ;; more of the examples in the ANSI CL definition are recognized.
86 ;; (e.g. (+ 3 2), (SQRT PI), and (LENGTH '(A B C)))
87 (declare (ignore environment))
92 ;; (Note that the following test on INFO catches KEYWORDs as well as
93 ;; explicitly DEFCONSTANT symbols.)
94 (symbol (eq (info :variable :kind object) :constant))
95 (list (eq (car object) 'quote))))
97 (declaim (ftype (function (symbol &optional (or null sb!c::lexenv))) sb!xc:macro-function))
98 (defun sb!xc:macro-function (symbol &optional env)
100 "If SYMBOL names a macro in ENV, returns the expansion function,
101 else returns NIL. If ENV is unspecified or NIL, use the global
103 (declare (symbol symbol))
104 (let* ((fenv (when env (sb!c::lexenv-functions env)))
105 (local-def (cdr (assoc symbol fenv))))
107 (if (and (consp local-def) (eq (car local-def) 'MACRO))
110 ((eq (info :function :kind symbol) :macro)
111 (values (info :function :macro-function symbol)))
115 ;;; Note: Technically there could be an ENV optional argument to SETF
116 ;;; MACRO-FUNCTION, but since ANSI says that the consequences of
117 ;;; supplying that optional argument are undefined, we don't allow it.
118 ;;; (Thus our implementation of this unspecified behavior is to
119 ;;; complain that the wrong number of arguments was supplied. Since
120 ;;; the behavior is unspecified, this is conforming.:-)
121 (defun (setf sb!xc:macro-function) (function symbol)
122 (declare (symbol symbol) (type function function))
123 (when (eq (info :function :kind symbol) :special-form)
124 (error "~S names a special form." symbol))
125 (setf (info :function :kind symbol) :macro)
126 (setf (info :function :macro-function symbol) function)
127 ;; This is a nice thing to have in the target SBCL, but in the
128 ;; cross-compilation host it's not nice to mess with
129 ;; (SYMBOL-FUNCTION FOO) where FOO might be a symbol in the
130 ;; cross-compilation host's COMMON-LISP package.
132 (setf (symbol-function symbol)
134 (declare (ignore args))
135 ;; (ANSI specification of FUNCALL says that this should be
136 ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.)
137 (error 'undefined-function :name symbol)))
140 (defun sb!xc:compiler-macro-function (name &optional env)
142 "If NAME names a compiler-macro, returns the expansion function,
143 else returns NIL. Note: if the name is shadowed in ENV by a local
144 definition, or declared NOTINLINE, NIL is returned. Can be
146 (let ((found (and env
147 (cdr (assoc name (sb!c::lexenv-functions env)
149 (unless (eq (cond ((sb!c::defined-function-p found)
150 (sb!c::defined-function-inlinep found))
153 (info :function :inlinep name)))
155 (values (info :function :compiler-macro-function name)))))
156 (defun (setf sb!xc:compiler-macro-function) (function name)
157 (declare (type (or symbol list) name)
158 (type (or function null) function))
159 (when (eq (info :function :kind name) :special-form)
160 (error "~S names a special form." name))
161 (setf (info :function :compiler-macro-function name) function)
164 ;;;; a subset of DOCUMENTATION functionality for bootstrapping
166 ;;; FDOCUMENTATION is like DOCUMENTATION, but with less functionality,
167 ;;; and implemented with DEFUN instead of DEFGENERIC so that it can
168 ;;; run before CLOS is set up. Supported DOC-TYPE values are
175 ;;; FIXME: Other types end up in INFO :RANDOM-DOCUMENTATION :STUFF. I
176 ;;; should add some code to monitor this and make sure that nothing is
177 ;;; unintentionally being sent to never never land this way.
178 ;;; FIXME: Rename FDOCUMENTATION to BDOCUMENTATION, by analogy with
179 ;;; DEF!STRUCT and DEF!MACRO and so forth. And consider simply saving
180 ;;; all the BDOCUMENTATION entries in a *BDOCUMENTATION* hash table
181 ;;; and slamming them into PCL once PCL gets going.
182 (defun fdocumentation (x doc-type)
183 (flet ((try-cmucl-random-doc (x doc-type)
184 (declare (symbol doc-type))
186 (values (info :random-documentation :stuff x))))))
190 (symbol (values (info :variable :documentation x)))))
194 ((legal-function-name-p x)
195 ;; FIXME: Is it really right to make
196 ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to
197 ;; (DOCUMENTATION 'FOO 'FUNCTION)? That's what CMU CL
198 ;; did, so we do it, but I'm not sure it's what ANSI wants.
199 (values (info :function :documentation
200 (function-name-block-name x))))))
203 (symbol (when (eq (info :type :kind x) :instance)
204 (values (info :type :documentation x))))))
207 (structure-class (values (info :type :documentation (class-name x))))
208 (t (and (typep x 'symbol) (values (info :type :documentation x))))))
209 (setf (info :setf :documentation x))
212 (function (function-doc x))
213 (package (package-doc-string x))
214 (structure-class (values (info :type :documentation (class-name x))))
215 (symbol (try-cmucl-random-doc x doc-type))))
218 ;; FIXME: This code comes from CMU CL, but
219 ;; TRY-CMUCL-RANDOM-DOC doesn't seem to be defined anywhere
220 ;; in CMU CL. Perhaps it could be defined by analogy with the
221 ;; corresponding SETF FDOCUMENTATION code.
222 (symbol (try-cmucl-random-doc x doc-type)))))))
223 (defun (setf fdocumentation) (string name doc-type)
224 ;; FIXME: I think it should be possible to set documentation for
225 ;; things (e.g. compiler macros) named (SETF FOO). fndb.lisp
226 ;; declares DOC-TYPE to be a SYMBOL, which contradicts that. What
229 (variable (setf (info :variable :documentation name) string))
230 (function (setf (info :function :documentation name) string))
231 (structure (if (eq (info :type :kind name) :instance)
232 (setf (info :type :documentation name) string)
233 (error "~S is not the name of a structure type." name)))
234 (type (setf (info :type :documentation name) string))
235 (setf (setf (info :setf :documentation name) string))
237 (let ((pair (assoc doc-type (info :random-documentation :stuff name))))
239 (setf (cdr pair) string)
240 (push (cons doc-type string)
241 (info :random-documentation :stuff name))))))