/[cmucl]/src/compiler/proclaim.lisp
ViewVC logotype

Contents of /src/compiler/proclaim.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.48 - (show annotations)
Tue Apr 20 17:57:46 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.47: +19 -19 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Package: C; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/proclaim.lisp,v 1.48 2010/04/20 17:57:46 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains load-time support for declaration processing. It is
13 ;;; split off from the compiler so that the compiler doesn'thave to be in the
14 ;;; cold load.
15 ;;;
16 ;;; Written by Rob MacLachlan
17 ;;;
18 (in-package "C")
19 (intl:textdomain "cmucl")
20
21 (in-package "EXTENSIONS")
22 (export '(inhibit-warnings freeze-type optimize-interface constant-function))
23 (in-package "KERNEL")
24 (export '(note-name-defined define-function-name undefine-function-name
25 *type-system-initialized* %note-type-defined))
26 (in-package "LISP")
27 (export '(declaim proclaim))
28 (in-package "C")
29 (export '(&more))
30
31 ;;; True if the type system has been properly initialized, and thus is o.k. to
32 ;;; use.
33 ;;;
34 (defvar *type-system-initialized* nil)
35
36 ;;; The Cookie holds information about the compilation environment for a node.
37 ;;; See the Lexenv definition for a description of how it is used.
38 ;;;
39 (defstruct cookie
40 (speed nil :type (or (rational 0 3) null))
41 (space nil :type (or (rational 0 3) null))
42 (safety nil :type (or (rational 0 3) null))
43 (cspeed nil :type (or (rational 0 3) null))
44 (brevity nil :type (or (rational 0 3) null))
45 (debug nil :type (or (rational 0 3) null)))
46
47
48 ;;; The *default-cookie* represents the current global compiler policy
49 ;;; information. Whenever the policy is changed, we copy the structure so that
50 ;;; old uses will still get the old values. *default-interface-cookie* holds
51 ;;; any values specified by an OPTIMIZE-INTERFACE declaration.
52 ;;;
53 (declaim (type cookie *default-cookie* *default-interface-cookie*))
54 (defvar *default-cookie*)
55 (defvar *default-interface-cookie*)
56
57 ;;; PROCLAIM-INIT -- sorta interface.
58 ;;;
59 ;;; %Initial-function (in lispinit) calls this after running all the
60 ;;; initial top level forms to reset the cookies. We also use it in place
61 ;;; of supplying initial values in the DEFVARs above so that we don't
62 ;;; have to put the initial default cookie in two places.
63 ;;;
64 (defun proclaim-init ()
65 (setf *default-cookie*
66 (make-cookie :safety 1 :speed 1 :space 1 :cspeed 1
67 :brevity 1 :debug 2))
68 (setf *default-interface-cookie*
69 (make-cookie)))
70 ;;;
71 (proclaim-init)
72
73 ;;; A list of UNDEFINED-WARNING structures representing the calls to unknown
74 ;;; functions. This is bound by WITH-COMPILATION-UNIT.
75 ;;;
76 (defvar *undefined-warnings*)
77 (declaim (list *undefined-warnings*))
78
79 ;;; NOTE-NAME-DEFINED -- Interface
80 ;;;
81 ;;; Delete any undefined warnings for Name and Kind. We do the BOUNDP check
82 ;;; because this function can be called when not in a compilation unit (as when
83 ;;; loading top-level forms.)
84 ;;;
85 (defun note-name-defined (name kind)
86 (when (boundp '*undefined-warnings*)
87 (setq *undefined-warnings*
88 (delete-if #'(lambda (x)
89 (and (equal (undefined-warning-name x) name)
90 (eq (undefined-warning-kind x) kind)))
91 *undefined-warnings*)))
92 (undefined-value))
93
94
95 ;;; Parse-Lambda-List -- Interface
96 ;;;
97 ;;; Break a lambda-list into its component parts. We return eleven values:
98 ;;; 1] A list of the required args.
99 ;;; 2] A list of the optional arg specs.
100 ;;; 3] True if a rest arg was specified.
101 ;;; 4] The rest arg.
102 ;;; 5] A boolean indicating whether keywords args are present.
103 ;;; 6] A list of the keyword arg specs.
104 ;;; 7] True if &allow-other-keys was specified.
105 ;;; 8] A list of the &aux specifiers.
106 ;;; 9] True if a more arg was specified.
107 ;;; 10] The &more context var
108 ;;; 11] The &more count var
109 ;;;
110 ;;; The top-level lambda-list syntax is checked for validity, but the arg
111 ;;; specifiers are just passed through untouched. If something is wrong, we
112 ;;; use Compiler-Error, aborting compilation to the last recovery point.
113 ;;;
114 (defun parse-lambda-list (list)
115 (declare (list list)
116 (values list list boolean t boolean list boolean list boolean t t))
117 (collect ((required)
118 (optional)
119 (keys)
120 (aux))
121 (let ((restp nil)
122 (rest nil)
123 (morep nil)
124 (more-context nil)
125 (more-count nil)
126 (keyp nil)
127 (allowp nil)
128 (state :required))
129 (dolist (arg list)
130 ;; check for arguments that have the syntactic form of a
131 ;; keyword argument without being a recognized lambda-list keyword
132 (when (and (symbolp arg)
133 (let ((name (symbol-name arg)))
134 (and (/= (length name) 0)
135 (char= (char name 0) #\&))))
136 (unless (member arg lambda-list-keywords)
137 (compiler-note
138 _N"~S uses lambda-list keyword naming convention, but is not a recognized lambda-list keyword."
139 arg)))
140 (if (member arg lambda-list-keywords)
141 (ecase arg
142 (&optional
143 (unless (eq state :required)
144 (compiler-error _N"Misplaced &optional in lambda-list: ~S." list))
145 (setq state '&optional))
146 (&rest
147 (unless (member state '(:required &optional))
148 (compiler-error _N"Misplaced &rest in lambda-list: ~S." list))
149 (setq state '&rest))
150 (&more
151 (unless (member state '(:required &optional))
152 (compiler-error _N"Misplaced &more in lambda-list: ~S." list))
153 (setq morep t state '&more-context))
154 (&key
155 (unless (member state '(:required &optional :post-rest
156 :post-more))
157 (compiler-error _N"Misplaced &key in lambda-list: ~S." list))
158 (setq keyp t)
159 (setq state '&key))
160 (&allow-other-keys
161 (unless (eq state '&key)
162 (compiler-error _N"Misplaced &allow-other-keys in lambda-list: ~S." list))
163 (setq allowp t state '&allow-other-keys))
164 (&aux
165 (when (member state '(&rest &more-context &more-count))
166 (compiler-error _N"Misplaced &aux in lambda-list: ~S." list))
167 (setq state '&aux)))
168 (case state
169 (:required (required arg))
170 (&optional (optional arg))
171 (&rest
172 (setq restp t rest arg state :post-rest))
173 (&more-context
174 (setq more-context arg state '&more-count))
175 (&more-count
176 (setq more-count arg state :post-more))
177 (&key (keys arg))
178 (&aux (aux arg))
179 (t
180 (compiler-error _N"Found garbage in lambda-list when expecting a keyword: ~S." arg)))))
181
182 (when (eq state '&rest)
183 (compiler-error _N"&rest not followed by required variable."))
184
185 (values (required) (optional) restp rest keyp (keys) allowp (aux)
186 morep more-context more-count))))
187
188
189 ;;; Check-Function-Name -- Interface
190 ;;;
191 ;;; Check that Name is a valid function name, returning the name if OK, and
192 ;;; doing an error if not. In addition to checking for basic well-formedness,
193 ;;; we also check that symbol names are not NIL or the name of a special form.
194 ;;;
195 (defun check-function-name (name)
196 (typecase name
197 (list
198 (unless (valid-function-name-p name)
199 (compiler-error _N"Illegal function name: ~S." name))
200 name)
201 (symbol
202 (when (eq (info function kind name) :special-form)
203 (compiler-error _N"Special form is an illegal function name: ~S." name))
204 name)
205 (t
206 (compiler-error _N"Illegal function name: ~S." name))))
207
208
209 ;;; NOTE-IF-SETF-FUNCTION-AND-MACRO -- Interface
210 ;;;
211 ;;; Called to do something about SETF functions that overlap with setf
212 ;;; macros. Perhaps we should interact with the user to see if the macro
213 ;;; should be blown away, but for now just give a warning. Due to the weak
214 ;;; semantics of the (SETF FUNCTION) name, we can't assume that they aren't
215 ;;; just naming a function (SETF FOO) for the heck of it. Name is already
216 ;;; known to be well-formed.
217 ;;;
218 (defun note-if-setf-function-and-macro (name)
219 (when (consp name)
220 (when (or (info setf inverse name)
221 (info setf expander name))
222 (compiler-warning
223 _N"Defining as a SETF function a name that already has a SETF macro:~
224 ~% ~S"
225 name)))
226 (undefined-value))
227
228 ;;; Note-If-Accessor -- Interface
229 ;;;
230 ;;; Check if Name is also the name of a slot accessor for some
231 ;;; structure. If it is, we signal an continuable error. If we
232 ;;; continue, assume the user knows what he's doing and redefine the
233 ;;; function.
234 (defun note-if-accessor (name)
235 (let ((for (info function accessor-for name)))
236 (when for
237 (cerror (intl:gettext "Assume redefinition is compatible and allow it")
238 (intl:gettext "Redefining slot accessor ~S for structure type ~S")
239 name (%class-name for))
240 ;;(undefine-structure for)
241 (setf (info function kind name) :function))))
242
243 ;;; Define-Function-Name -- Interface
244 ;;;
245 ;;; Check the legality of a function name that is being introduced.
246 ;;; -- If it names a macro, then give a warning and blast the macro
247 ;;; information.
248 ;;; -- If it is a structure slot accessor, give a continuable error
249 ;;; and allow redefinition if continued.
250 ;;; -- Check for conflicting setf macros.
251 ;;;
252 (defun define-function-name (name)
253 (check-function-name name)
254 (ecase (info function kind name)
255 (:function
256 (note-if-accessor name))
257 (:macro
258 (compiler-warning _N"~S previously defined as a macro." name)
259 (setf (info function kind name) :function)
260 (setf (info function where-from name) :assumed)
261 (clear-info function macro-function name))
262 ((nil)
263 (setf (info function kind name) :function)))
264
265
266 (note-if-setf-function-and-macro name)
267 name)
268
269
270 ;;; UNDEFINE-FUNCTION-NAME -- Interface
271 ;;;
272 ;;; Make Name no longer be a function name: clear everything back to the
273 ;;; default.
274 ;;;
275 (defun undefine-function-name (name)
276 (when name
277 (macrolet ((frob (type &optional val)
278 `(unless (eq (info function ,type name) ,val)
279 (setf (info function ,type name) ,val))))
280 (frob info)
281 (frob type (specifier-type 'function))
282 (frob where-from :assumed)
283 (frob inlinep)
284 (frob kind)
285 (frob accessor-for)
286 (frob inline-expansion)
287 (frob source-transform)
288 (frob assumed-type)))
289 (undefined-value))
290
291
292 ;;; Process-Optimize-Declaration -- Interface
293 ;;;
294 ;;; Return a new cookie containing the policy information represented by the
295 ;;; optimize declaration Spec. Any parameters not specified are defaulted from
296 ;;; Cookie.
297 ;;;
298 (defun process-optimize-declaration (spec cookie)
299 (declare (list spec) (type cookie cookie) (values cookie))
300 (let ((res (copy-cookie cookie)))
301 (dolist (quality (cdr spec))
302 (let ((quality (if (atom quality) (list quality 3) quality)))
303 (if (and (consp (cdr quality)) (null (cddr quality))
304 (typep (second quality) 'real) (<= 0 (second quality) 3))
305 (let ((value (rational (second quality))))
306 (case (first quality)
307 (speed (setf (cookie-speed res) value))
308 (space (setf (cookie-space res) value))
309 (safety (setf (cookie-safety res) value))
310 (compilation-speed (setf (cookie-cspeed res) value))
311 ((inhibit-warnings brevity) (setf (cookie-brevity res) value))
312 ((debug-info debug) (setf (cookie-debug res) value))
313 (t
314 (compiler-warning _N"Unknown optimization quality ~S in ~S."
315 (car quality) spec))))
316 (compiler-warning
317 _N"Malformed optimization quality specifier ~S in ~S."
318 quality spec))))
319 res))
320
321
322 ;;; DECLAIM -- Public
323 ;;;
324
325 (defmacro declaim (&rest specs)
326 "DECLAIM Declaration*
327 Do a declaration for the global environment."
328 `(progn
329 (eval-when (:load-toplevel :execute)
330 ,@(mapcar #'(lambda (x)
331 `(proclaim ',x))
332 specs))
333 (eval-when (:compile-toplevel)
334 ,@(mapcar #'(lambda (x)
335 `(%declaim ',x))
336 specs))))
337
338 (defun %declaim (x)
339 (proclaim x))
340
341 (defvar *proclamation-hooks* nil)
342
343 ;;; PROCLAIM -- Public
344 ;;;
345 ;;; This function is the guts of proclaim, since it does the global
346 ;;; environment updating.
347 ;;;
348 (defun proclaim (form)
349 (unless (consp form)
350 (error (intl:gettext "Malformed PROCLAIM spec: ~S.") form))
351
352 (when (boundp '*proclamation-hooks*)
353 (dolist (hook *proclamation-hooks*)
354 (funcall hook form)))
355
356 (let ((kind (first form))
357 (args (rest form)))
358 (case kind
359 (special
360 (dolist (name args)
361 (unless (symbolp name)
362 (error (intl:gettext "Variable name is not a symbol: ~S.") name))
363 (unless (or (member (info variable kind name) '(:global :special))
364 ;; If we are still in cold-load, and the package system
365 ;; is not set up, the global db will claim all variables
366 ;; are keywords/constants, because all symbols have the
367 ;; same package nil. Proceed normally in this case:
368 (null (symbol-package :end)))
369 (cond
370 ((eq name 'nil)
371 (error (intl:gettext "Nihil ex nihil, can't declare ~S special.") name))
372 ((eq name 't)
373 (error (intl:gettext "Veritas aeterna, can't declare ~S special.") name))
374 ((keywordp name)
375 (error (intl:gettext "Can't declare ~S special, it is a keyword.") name))
376 (t
377 (cerror (intl:gettext "Proceed anyway.")
378 (intl:gettext "Trying to declare ~S special, which is ~A.") name
379 (ecase (info variable kind name)
380 (:constant (intl:gettext "a constant"))
381 (:alien (intl:gettext "an alien variable"))
382 (:macro (intl:gettext "a symbol macro")))))))
383 (clear-info variable constant-value name)
384 (setf (info variable kind name) :special)))
385 (type
386 (when *type-system-initialized*
387 (let ((type (specifier-type (first args))))
388 (dolist (name (rest args))
389 (unless (symbolp name)
390 (error (intl:gettext "Variable name is not a symbol: ~S.") name))
391 (setf (info variable type name) type)
392 (setf (info variable where-from name) :declared)))))
393 (ftype
394 (when *type-system-initialized*
395 (let ((type (specifier-type (first args))))
396 (unless (csubtypep type (specifier-type 'function))
397 (error (intl:gettext "Declared functional type is not a function type: ~S.")
398 (first args)))
399 (dolist (name (rest args))
400 (cond ((info function accessor-for name)
401 (warn (intl:gettext "Ignoring FTYPE declaration for slot accesor:~% ~S")
402 name))
403 (t
404 (define-function-name name)
405 (note-name-defined name :function)
406 (setf (info function type name) type)
407 (setf (info function where-from name) :declared)))))))
408 (freeze-type
409 (dolist (type args)
410 (let ((class (specifier-type type)))
411 (when (typep class 'kernel::class)
412 (setf (%class-state class) :sealed)
413 (let ((subclasses (%class-subclasses class)))
414 (when subclasses
415 (do-hash (subclass layout subclasses)
416 (declare (ignore layout))
417 (setf (%class-state subclass) :sealed))))))))
418 (function
419 ;;
420 ;; Handle old-style FUNCTION declaration, which is a shorthand for
421 ;; FTYPE.
422 (when *type-system-initialized*
423 (if (and (<= 2 (length args) 3) (listp (second args)))
424 (proclaim `(ftype (function . ,(rest args)) ,(first args)))
425 (proclaim `(type function . ,args)))))
426 (optimize
427 (setq *default-cookie*
428 (process-optimize-declaration form *default-cookie*)))
429 (optimize-interface
430 (setq *default-interface-cookie*
431 (process-optimize-declaration form *default-interface-cookie*)))
432 ((inline notinline maybe-inline)
433 (dolist (name args)
434 (define-function-name name)
435 (setf (info function inlinep name)
436 (case kind
437 (inline :inline)
438 (notinline :notinline)
439 (maybe-inline :maybe-inline)))))
440 (constant-function
441 (let ((info (make-function-info
442 :attributes (ir1-attributes movable foldable flushable
443 unsafe))))
444 (dolist (name args)
445 (define-function-name name)
446 (setf (info function info name) info))))
447 (declaration
448 (dolist (decl args)
449 (unless (symbolp decl)
450 (error (intl:gettext "Declaration to be RECOGNIZED is not a symbol: ~S.") decl))
451 (when (info type kind decl)
452 (error (intl:gettext "Declaration already names a type: ~S.") decl))
453 (setf (info declaration recognized decl) t)))
454 ((start-block end-block)) ; ignore.
455 (t
456 (cond ((member kind type-specifier-symbols)
457 (proclaim `(type . ,form)))
458 ((or (info type kind kind)
459 (and (consp kind) (info type translator (car kind))))
460 (proclaim `(type . ,form)))
461 ((not (info declaration recognized kind))
462 (warn (intl:gettext "Unrecognized proclamation: ~S.") form))))))
463 (undefined-value))
464
465
466 ;;; %NOTE-TYPE-DEFINED -- Interface
467 ;;;
468 ;;; Note that the type Name has been (re)defined, updating the undefined
469 ;;; warnings and VALUES-SPECIFIER-TYPE cache.
470 ;;;
471 (defun %note-type-defined (name)
472 (declare (symbol name))
473 (note-name-defined name :type)
474 (when (boundp 'kernel::*values-specifier-type-cache-vector*)
475 (values-specifier-type-cache-clear))
476 (undefined-value))
477
478
479 ;;;; Dummy definitions of COMPILER-ERROR, etc.
480 ;;;
481 ;;; Until the compiler is properly loaded, we make the compiler error
482 ;;; functions synonyms for the obvious standard error function.
483 ;;;
484
485 (defun compiler-error (string &rest args)
486 (apply #'error string args))
487
488 (defun compiler-warning (string &rest args)
489 (apply #'warn string args))
490
491 (defun compiler-note (string &rest args)
492 (apply #'warn string args))
493
494 (defun compiler-error-message (string &rest args)
495 (apply #'warn string args))
496

  ViewVC Help
Powered by ViewVC 1.1.5