1 ;;;; This file contains load-time support for declaration processing.
2 ;;;; In CMU CL it was split off from the compiler so that the compiler
3 ;;;; doesn't have to be in the cold load, but in SBCL the compiler is
4 ;;;; in the cold load again, so this might not be valuable.
6 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; This software is derived from the CMU CL system, which was
10 ;;;; written at Carnegie Mellon University and released into the
11 ;;;; public domain. The software is in the public domain and is
12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
13 ;;;; files for more information.
17 ;;; A list of UNDEFINED-WARNING structures representing references to unknown
18 ;;; stuff which came up in a compilation unit.
19 (defvar *undefined-warnings*)
20 (declaim (list *undefined-warnings*))
22 ;;; Check that NAME is a valid function name, returning the name if
23 ;;; OK, and doing an error if not. In addition to checking for basic
24 ;;; well-formedness, we also check that symbol names are not NIL or
25 ;;; the name of a special form.
26 (defun check-function-name (name)
29 (unless (and (consp name) (consp (cdr name))
30 (null (cddr name)) (eq (car name) 'setf)
31 (symbolp (cadr name)))
32 (compiler-error "illegal function name: ~S" name))
35 (when (eq (info :function :kind name) :special-form)
36 (compiler-error "Special form is an illegal function name: ~S" name))
39 (compiler-error "illegal function name: ~S" name))))
41 ;;; This is called to do something about SETF functions that overlap
42 ;;; with SETF macros. Perhaps we should interact with the user to see
43 ;;; whether the macro should be blown away, but for now just give a
44 ;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we
45 ;;; can't assume that they aren't just naming a function (SETF FOO)
46 ;;; for the heck of it. NAME is already known to be well-formed.
47 (defun note-if-setf-function-and-macro (name)
49 (when (or (info :setf :inverse name)
50 (info :setf :expander name))
51 (compiler-style-warning
52 "defining as a SETF function a name that already has a SETF macro:~
57 ;;; Look up some symbols in *FREE-VARIABLES*, returning the var
58 ;;; structures for any which exist. If any of the names aren't
59 ;;; symbols, we complain.
60 (declaim (ftype (function (list) list) get-old-vars))
61 (defun get-old-vars (names)
63 (dolist (name names (vars))
64 (unless (symbolp name)
65 (compiler-error "The name ~S is not a symbol." name))
66 (let ((old (gethash name *free-variables*)))
67 (when old (vars old))))))
69 ;;; Return a new POLICY containing the policy information represented
70 ;;; by the optimize declaration SPEC. Any parameters not specified are
71 ;;; defaulted from the POLICY argument.
72 (declaim (ftype (function (list policy) policy) process-optimize-declaration))
73 (defun process-optimize-declaration (spec policy)
74 (let ((result policy)) ; may have new entries pushed on it below
75 (dolist (q-and-v-or-just-q (cdr spec))
76 (multiple-value-bind (quality raw-value)
77 (if (atom q-and-v-or-just-q)
78 (values q-and-v-or-just-q 3)
79 (destructuring-bind (quality raw-value) q-and-v-or-just-q
80 (values quality raw-value)))
81 (cond ((not (policy-quality-p quality))
82 (compiler-warning "ignoring unknown optimization quality ~
85 ((not (and (typep raw-value 'real) (<= 0 raw-value 3)))
86 (compiler-warning "ignoring bad optimization value ~S in ~S"
89 (push (cons quality (rational raw-value))
93 (defun sb!xc:proclaim (form)
95 (error "malformed PROCLAIM spec: ~S" form))
96 (let ((kind (first form))
101 (unless (symbolp name)
102 (error "can't declare a non-symbol as SPECIAL: ~S" name))
103 (when (constantp name)
104 (error "can't declare a constant as SPECIAL: ~S" name))
105 (clear-info :variable :constant-value name)
106 (setf (info :variable :kind name) :special)))
108 (when *type-system-initialized*
109 (let ((type (specifier-type (first args))))
110 (dolist (name (rest args))
111 (unless (symbolp name)
112 (error "can't declare TYPE of a non-symbol: ~S" name))
113 (when (eq (info :variable :where-from name) :declared)
114 (let ((old-type (info :variable :type name)))
115 (when (type/= type old-type)
116 (style-warn "The new TYPE proclamation~% ~S~@
117 for ~S does not match the old TYPE~@
119 type name old-type))))
120 (setf (info :variable :type name) type)
121 (setf (info :variable :where-from name) :declared)))))
123 ;; FIXME: Since currently *TYPE-SYSTEM-INITIALIZED* is not set
124 ;; until many toplevel forms have run, this condition on
125 ;; PROCLAIM (FTYPE ..) (and on PROCLAIM (TYPE ..), above) means
126 ;; that valid PROCLAIMs in cold code could get lost. Probably
127 ;; the cleanest way to deal with this would be to initialize
128 ;; the type system completely in special cold init forms,
129 ;; before any ordinary toplevel forms run. Failing that, we
130 ;; could queue up PROCLAIMs to be done after the type system is
131 ;; initialized. Failing that, we could at least issue a warning
132 ;; when we have to ignore a PROCLAIM because the type system is
134 (when *type-system-initialized*
135 (let ((type (specifier-type (first args))))
136 (unless (csubtypep type (specifier-type 'function))
137 (error "not a function type: ~S" (first args)))
138 (dolist (name (rest args))
139 (cond ((info :function :accessor-for name)
140 ;; FIXME: This used to be a WARNING, which was
141 ;; clearly wrong, since it would cause warnings to
142 ;; be issued for conforming code, which is really
143 ;; annoying for people who use Lisp code to build
144 ;; Lisp systems (and check the return values from
145 ;; COMPILE and COMPILE-FILE). Changing it to a
146 ;; compiler note is somewhat better, since it's
147 ;; after all news about a limitation of the
148 ;; compiler, not a problem in the code. But even
149 ;; better would be to handle FTYPE proclamations
150 ;; for slot accessors, and since in the long run
151 ;; slot accessors should become more like other
152 ;; functions, this should eventually become
155 "~@<ignoring FTYPE proclamation for ~
156 slot accessor (currently unsupported): ~2I~_~S~:>"
160 ;; KLUDGE: Something like the commented-out TYPE/=
161 ;; check here would be nice, but it has been
162 ;; commented out because TYPE/= doesn't support
163 ;; function types. It could probably be made to do
164 ;; so, but it might take some time, since function
165 ;; types involve values types, which aren't
166 ;; supported, and since the SUBTYPEP operator for
167 ;; FUNCTION types is rather broken, e.g.
168 ;; (SUBTYPEP '(FUNCTION (T BOOLEAN) NIL)
169 ;; '(FUNCTION (FIXNUM FIXNUM) NIL)) => T, T
172 (when (eq (info :function :where-from name) :declared)
173 (let ((old-type (info :function :type name)))
174 (when (type/= type old-type)
175 (style-warn "new FTYPE proclamation~@
177 for ~S does not match old FTYPE proclamation~@
179 (list type name old-type)))))
181 (proclaim-as-function-name name)
182 (note-name-defined name :function)
183 (setf (info :function :type name) type
184 (info :function :where-from name) :declared)))))))
187 (let ((class (specifier-type type)))
188 (when (typep class 'class)
189 (setf (class-state class) :sealed)
190 (let ((subclasses (class-subclasses class)))
192 (dohash (subclass layout subclasses)
193 (declare (ignore layout))
194 (setf (class-state subclass) :sealed))))))))
196 (setq *default-policy*
197 (process-optimize-declaration form *default-policy*)))
199 (setq *default-interface-policy*
200 (process-optimize-declaration form *default-interface-policy*)))
201 ((inline notinline maybe-inline)
203 (proclaim-as-function-name name)
204 (setf (info :function :inlinep name)
207 (notinline :notinline)
208 (maybe-inline :maybe-inline)))))
210 (let ((info (make-function-info
211 :attributes (ir1-attributes movable foldable flushable
214 (proclaim-as-function-name name)
215 (setf (info :function :info name) info))))
218 (unless (symbolp decl)
219 (error "The declaration to be recognized is not a symbol: ~S" decl))
220 (setf (info :declaration :recognized decl) t)))
222 (cond ((member kind *standard-type-names*)
223 (sb!xc:proclaim `(type ,@form))) ; FIXME: ,@ instead of . ,
224 ((not (info :declaration :recognized kind))
225 (warn "unrecognized proclamation: ~S" form))))))