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 ;;; Record a new function definition, and check its legality.
21 (declaim (ftype (function ((or symbol cons)) t) proclaim-as-function-name))
22 (defun proclaim-as-function-name (name)
23 (check-function-name name)
24 (ecase (info :function :kind name)
26 (let ((accessor-for (info :function :accessor-for name)))
28 (compiler-style-warning
31 ~I~_was previously defined as a slot accessor for ~
35 (clear-info :function :accessor-for name))))
37 (compiler-style-warning "~S was previously defined as a macro." name)
38 (setf (info :function :where-from name) :assumed)
39 (clear-info :function :macro-function name))
41 (setf (info :function :kind name) :function)
42 (note-if-setf-function-and-macro name)
45 ;;; Make NAME no longer be a function name: clear everything back to
47 (defun undefine-function-name (name)
49 (macrolet ((frob (type &optional val)
50 `(unless (eq (info :function ,type name) ,val)
51 (setf (info :function ,type name) ,val))))
53 (frob :type (specifier-type 'function))
54 (frob :where-from :assumed)
58 (frob :inline-expansion)
59 (frob :source-transform)
60 (frob :assumed-type)))
63 ;;; part of what happens with DEFUN, also with some PCL stuff: Make
64 ;;; NAME known to be a function definition.
65 (defun become-defined-function-name (name)
66 (proclaim-as-function-name name)
67 (when (eq (info :function :where-from name) :assumed)
68 (setf (info :function :where-from name) :defined)
69 (if (info :function :assumed-type name)
70 (setf (info :function :assumed-type name) nil))))
72 ;;;; ANSI Common Lisp functions which are defined in terms of the info
75 (defun sb!xc:constantp (object &optional environment)
77 "True of any Lisp object that has a constant value: types that eval to
78 themselves, keywords, constants, and list whose car is QUOTE."
79 ;; FIXME: Should STRUCTURE-OBJECT and/or STANDARD-OBJECT be here?
80 ;; They eval to themselves..
82 ;; FIXME: Someday it would be nice to make the code recognize foldable
83 ;; functions and call itself recursively on their arguments, so that
84 ;; more of the examples in the ANSI CL definition are recognized.
85 ;; (e.g. (+ 3 2), (SQRT PI), and (LENGTH '(A B C)))
86 (declare (ignore environment))
91 ;; (Note that the following test on INFO catches KEYWORDs as well as
92 ;; explicitly DEFCONSTANT symbols.)
93 (symbol (eq (info :variable :kind object) :constant))
94 (list (eq (car object) 'quote))))
96 (declaim (ftype (function (symbol &optional (or null sb!c::lexenv))) sb!xc:macro-function))
97 (defun sb!xc:macro-function (symbol &optional env)
99 "If SYMBOL names a macro in ENV, returns the expansion function,
100 else returns NIL. If ENV is unspecified or NIL, use the global
102 (declare (symbol symbol))
103 (let* ((fenv (when env (sb!c::lexenv-functions env)))
104 (local-def (cdr (assoc symbol fenv))))
106 (if (and (consp local-def) (eq (car local-def) 'MACRO))
109 ((eq (info :function :kind symbol) :macro)
110 (values (info :function :macro-function symbol)))
114 ;;; Note: Technically there could be an ENV optional argument to SETF
115 ;;; MACRO-FUNCTION, but since ANSI says that the consequences of
116 ;;; supplying that optional argument are undefined, we don't allow it.
117 ;;; (Thus our implementation of this unspecified behavior is to
118 ;;; complain that the wrong number of arguments was supplied. Since
119 ;;; the behavior is unspecified, this is conforming.:-)
120 (defun (setf sb!xc:macro-function) (function symbol)
121 (declare (symbol symbol) (type function function))
122 (when (eq (info :function :kind symbol) :special-form)
123 (error "~S names a special form." symbol))
124 (setf (info :function :kind symbol) :macro)
125 (setf (info :function :macro-function symbol) function)
126 ;; This is a nice thing to have in the target SBCL, but in the
127 ;; cross-compilation host it's not nice to mess with
128 ;; (SYMBOL-FUNCTION FOO) where FOO might be a symbol in the
129 ;; cross-compilation host's COMMON-LISP package.
131 (setf (symbol-function symbol)
133 (declare (ignore args))
134 ;; (ANSI specification of FUNCALL says that this should be
135 ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.)
136 (error 'undefined-function :name symbol)))
139 (defun sb!xc:compiler-macro-function (name &optional env)
141 "If NAME names a compiler-macro, returns the expansion function,
142 else returns NIL. Note: if the name is shadowed in ENV by a local
143 definition, or declared NOTINLINE, NIL is returned. Can be
145 (let ((found (and env
146 (cdr (assoc name (sb!c::lexenv-functions env)
148 (unless (eq (cond ((sb!c::defined-function-p found)
149 (sb!c::defined-function-inlinep found))
152 (info :function :inlinep name)))
154 (values (info :function :compiler-macro-function name)))))
155 (defun (setf sb!xc:compiler-macro-function) (function name)
156 (declare (type (or symbol list) name)
157 (type (or function null) function))
158 (when (eq (info :function :kind name) :special-form)
159 (error "~S names a special form." name))
160 (setf (info :function :compiler-macro-function name) function)
163 ;;;; a subset of DOCUMENTATION functionality for bootstrapping
165 ;;; FDOCUMENTATION is like DOCUMENTATION, but with less functionality,
166 ;;; and implemented with DEFUN instead of DEFGENERIC so that it can
167 ;;; run before CLOS is set up. Supported DOC-TYPE values are
174 ;;; FIXME: Other types end up in INFO :RANDOM-DOCUMENTATION :STUFF. I
175 ;;; should add some code to monitor this and make sure that nothing is
176 ;;; unintentionally being sent to never never land this way.
177 ;;; FIXME: Rename FDOCUMENTATION to BDOCUMENTATION, by analogy with
178 ;;; DEF!STRUCT and DEF!MACRO and so forth. And consider simply saving
179 ;;; all the BDOCUMENTATION entries in a *BDOCUMENTATION* hash table
180 ;;; and slamming them into PCL once PCL gets going.
181 (defun fdocumentation (x doc-type)
182 (flet ((try-cmucl-random-doc (x doc-type)
183 (declare (symbol doc-type))
185 (values (info :random-documentation :stuff x))))))
189 (symbol (values (info :variable :documentation x)))))
193 ((legal-function-name-p x)
194 ;; FIXME: Is it really right to make
195 ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to
196 ;; (DOCUMENTATION 'FOO 'FUNCTION)? That's what CMU CL
197 ;; did, so we do it, but I'm not sure it's what ANSI wants.
198 (values (info :function :documentation
199 (function-name-block-name x))))))
202 (symbol (when (eq (info :type :kind x) :instance)
203 (values (info :type :documentation x))))))
206 (structure-class (values (info :type :documentation (class-name x))))
207 (t (and (typep x 'symbol) (values (info :type :documentation x))))))
208 (setf (info :setf :documentation x))
211 (function (function-doc x))
212 (package (package-doc-string x))
213 (structure-class (values (info :type :documentation (class-name x))))
214 (symbol (try-cmucl-random-doc x doc-type))))
217 ;; FIXME: This code comes from CMU CL, but
218 ;; TRY-CMUCL-RANDOM-DOC doesn't seem to be defined anywhere
219 ;; in CMU CL. Perhaps it could be defined by analogy with the
220 ;; corresponding SETF FDOCUMENTATION code.
221 (symbol (try-cmucl-random-doc x doc-type)))))))
222 (defun (setf fdocumentation) (string name doc-type)
223 ;; FIXME: I think it should be possible to set documentation for
224 ;; things (e.g. compiler macros) named (SETF FOO). fndb.lisp
225 ;; declares DOC-TYPE to be a SYMBOL, which contradicts that. What
228 (variable (setf (info :variable :documentation name) string))
229 (function (setf (info :function :documentation name) string))
230 (structure (if (eq (info :type :kind name) :instance)
231 (setf (info :type :documentation name) string)
232 (error "~S is not the name of a structure type." name)))
233 (type (setf (info :type :documentation name) string))
234 (setf (setf (info :setf :documentation name) string))
236 (let ((pair (assoc doc-type (info :random-documentation :stuff name))))
238 (setf (cdr pair) string)
239 (push (cons doc-type string)
240 (info :random-documentation :stuff name))))))