X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fproclaim.lisp;h=7ebf66646ab4284078cfdfe09d79cdbc74794caa;hb=7c406887c08477181e869b1b98142d99b52990ac;hp=985816bb094ab98de362736fd315ce67e61e4c0b;hpb=c696666acb1e79504d3c49283288ba5c35180e71;p=sbcl.git diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 985816b..7ebf666 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -27,9 +27,9 @@ (collect ((vars)) (dolist (name names (vars)) (unless (symbolp name) - (compiler-error "The name ~S is not a symbol." name)) + (compiler-error "The name ~S is not a symbol." name)) (let ((old (gethash name *free-vars*))) - (when old (vars old)))))) + (when old (vars old)))))) ;;; Return a new POLICY containing the policy information represented ;;; by the optimize declaration SPEC. Any parameters not specified are @@ -40,83 +40,85 @@ ;; Add new entries from SPEC. (dolist (q-and-v-or-just-q (cdr spec)) (multiple-value-bind (quality raw-value) - (if (atom q-and-v-or-just-q) - (values q-and-v-or-just-q 3) - (destructuring-bind (quality raw-value) q-and-v-or-just-q - (values quality raw-value))) - (cond ((not (policy-quality-name-p quality)) - (compiler-warn "ignoring unknown optimization quality ~ - ~S in ~S" - quality spec)) - ((not (typep raw-value 'policy-quality)) - (compiler-warn "ignoring bad optimization value ~S in ~S" - raw-value spec)) - (t - ;; we can't do this yet, because CLOS macros expand - ;; into code containing INHIBIT-WARNINGS. - #+nil - (when (eql quality 'sb!ext:inhibit-warnings) - (compiler-style-warn "~S is deprecated: use ~S instead" - quality 'sb!ext:muffle-conditions)) - (push (cons quality raw-value) - result))))) + (if (atom q-and-v-or-just-q) + (values q-and-v-or-just-q 3) + (destructuring-bind (quality raw-value) q-and-v-or-just-q + (values quality raw-value))) + (cond ((not (policy-quality-name-p quality)) + (let ((deprecation-warning (policy-quality-deprecation-warning quality spec))) + (if deprecation-warning + (compiler-warn deprecation-warning) + (compiler-warn "~@" + quality spec)))) + ((not (typep raw-value 'policy-quality)) + (compiler-warn "~@" + raw-value spec)) + (t + ;; we can't do this yet, because CLOS macros expand + ;; into code containing INHIBIT-WARNINGS. + #+nil + (when (eql quality 'sb!ext:inhibit-warnings) + (compiler-style-warn "~S is deprecated: use ~S instead" + quality 'sb!ext:muffle-conditions)) + (push (cons quality raw-value) + result))))) ;; Add any nonredundant entries from old POLICY. (dolist (old-entry policy) (unless (assq (car old-entry) result) - (push old-entry result))) + (push old-entry result))) ;; Voila. - result)) + (sort-policy result))) (declaim (ftype (function (list list) list) - process-handle-conditions-decl)) + process-handle-conditions-decl)) (defun process-handle-conditions-decl (spec list) (let ((new (copy-alist list))) (dolist (clause (cdr spec)) (destructuring-bind (typespec restart-name) clause - (let ((ospec (rassoc restart-name new :test #'eq))) - (if ospec - (setf (car ospec) - (type-specifier - (type-union (specifier-type (car ospec)) - (specifier-type typespec)))) - (push (cons (type-specifier (specifier-type typespec)) - restart-name) - new))))) + (let ((ospec (rassoc restart-name new :test #'eq))) + (if ospec + (setf (car ospec) + (type-specifier + (type-union (specifier-type (car ospec)) + (specifier-type typespec)))) + (push (cons (type-specifier (specifier-type typespec)) + restart-name) + new))))) new)) (declaim (ftype (function (list list) list) - process-muffle-conditions-decl)) + process-muffle-conditions-decl)) (defun process-muffle-conditions-decl (spec list) (process-handle-conditions-decl (cons 'handle-conditions - (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec))) + (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec))) list)) (declaim (ftype (function (list list) list) - process-unhandle-conditions-decl)) + process-unhandle-conditions-decl)) (defun process-unhandle-conditions-decl (spec list) (let ((new (copy-alist list))) (dolist (clause (cdr spec)) (destructuring-bind (typespec restart-name) clause - (let ((ospec (rassoc restart-name new :test #'eq))) - (if ospec - (let ((type-specifier - (type-specifier - (type-intersection - (specifier-type (car ospec)) - (specifier-type `(not ,typespec)))))) - (if type-specifier - (setf (car ospec) type-specifier) - (setq new - (delete restart-name new :test #'eq :key #'cdr)))) - ;; do nothing? - nil)))) + (let ((ospec (rassoc restart-name new :test #'eq))) + (if ospec + (let ((type-specifier + (type-specifier + (type-intersection + (specifier-type (car ospec)) + (specifier-type `(not ,typespec)))))) + (if type-specifier + (setf (car ospec) type-specifier) + (setq new + (delete restart-name new :test #'eq :key #'cdr)))) + ;; do nothing? + nil)))) new)) (declaim (ftype (function (list list) list) - process-unmuffle-conditions-decl)) + process-unmuffle-conditions-decl)) (defun process-unmuffle-conditions-decl (spec list) (process-unhandle-conditions-decl (cons 'unhandle-conditions - (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec))) + (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec))) list)) (declaim (ftype (function (list list) list) @@ -135,19 +137,25 @@ ;;; implements that by converting (FOO X Y) to (TYPE FOO X Y). (defun canonized-decl-spec (decl-spec) (let ((id (first decl-spec))) - (unless (symbolp id) - (error "The declaration identifier is not a symbol: ~S" id)) - (let ((id-is-type (info :type :kind id)) - (id-is-declared-decl (info :declaration :recognized id))) + (let ((id-is-type (if (symbolp id) + (info :type :kind id) + ;; A cons might not be a valid type specifier, + ;; but it can't be a declaration either. + (or (consp id) + (typep id 'class)))) + (id-is-declared-decl (info :declaration :recognized id))) + ;; FIXME: Checking ID-IS-DECLARED is probably useless these days, + ;; since we refuse to use the same symbol as both a type name and + ;; recognized declaration name. (cond ((and id-is-type id-is-declared-decl) - (compiler-error - "ambiguous declaration ~S:~% ~ + (compiler-error + "ambiguous declaration ~S:~% ~ ~S was declared as a DECLARATION, but is also a type name." - decl-spec id)) - (id-is-type - (cons 'type decl-spec)) - (t - decl-spec))))) + decl-spec id)) + (id-is-type + (cons 'type decl-spec)) + (t + decl-spec))))) (defvar *queued-proclaims*) ; initialized in !COLD-INIT-FORMS @@ -159,48 +167,50 @@ #+sb-xc (/show0 "entering PROCLAIM, RAW-FORM=..") #+sb-xc (/hexstr raw-form) (let* ((form (canonized-decl-spec raw-form)) - (kind (first form)) - (args (rest form))) + (kind (first form)) + (args (rest form))) (case kind (special (dolist (name args) - (unless (symbolp name) - (error "can't declare a non-symbol as SPECIAL: ~S" name)) - (when (constantp name) - (error "can't declare a constant as SPECIAL: ~S" name)) - (with-single-package-locked-error - (:symbol name "globally declaring ~A special")) - (clear-info :variable :constant-value name) - (setf (info :variable :kind name) :special))) + (unless (symbolp name) + (error "can't declare a non-symbol as SPECIAL: ~S" name)) + (with-single-package-locked-error + (:symbol name "globally declaring ~A special") + (about-to-modify-symbol-value name "proclaim ~S as SPECIAL") + (setf (info :variable :kind name) :special)))) (type (if *type-system-initialized* - (let ((type (specifier-type (first args)))) - (dolist (name (rest args)) - (unless (symbolp name) - (error "can't declare TYPE of a non-symbol: ~S" name)) - (with-single-package-locked-error + (let ((type (specifier-type (first args)))) + (dolist (name (rest args)) + (unless (symbolp name) + (error "can't declare TYPE of a non-symbol: ~S" name)) + (with-single-package-locked-error (:symbol name "globally declaring the type of ~A")) - (when (eq (info :variable :where-from name) :declared) - (let ((old-type (info :variable :type name))) - (when (type/= type old-type) - (style-warn "The new TYPE proclamation~% ~S~@ + (when (eq (info :variable :where-from name) :declared) + (let ((old-type (info :variable :type name))) + (when (type/= type old-type) + ;; FIXME: changing to TYPE-PROCLAMATION-MISMATCH + ;; broke late-proclaim.lisp. + (style-warn "The new TYPE proclamation~% ~S~@ for ~S does not match the old TYPE~@ proclamation ~S" - type name old-type)))) - (setf (info :variable :type name) type) - (setf (info :variable :where-from name) :declared))) - (push raw-form *queued-proclaims*))) + type name old-type)))) + (setf (info :variable :type name) type) + (setf (info :variable :where-from name) :declared))) + (push raw-form *queued-proclaims*))) (ftype (if *type-system-initialized* - (let ((ctype (specifier-type (first args)))) - (unless (csubtypep ctype (specifier-type 'function)) - (error "not a function type: ~S" (first args))) - (dolist (name (rest args)) - (with-single-package-locked-error + (let ((ctype (specifier-type (first args)))) + (unless (csubtypep ctype (specifier-type 'function)) + (error "not a function type: ~S" (first args))) + (dolist (name (rest args)) + (with-single-package-locked-error (:symbol name "globally declaring the ftype of ~A")) (when (eq (info :function :where-from name) :declared) (let ((old-type (info :function :type name))) (when (type/= ctype old-type) + ;; FIXME: changing to FTYPE-PROCLAMATION-MISMATCH + ;; broke late-proclaim.lisp. (style-warn "new FTYPE proclamation~@ ~S~@ @@ -208,59 +218,60 @@ ~S" ctype name old-type)))) - ;; Now references to this function shouldn't be warned - ;; about as undefined, since even if we haven't seen a - ;; definition yet, we know one is planned. - ;; - ;; Other consequences of we-know-you're-a-function-now - ;; are appropriate too, e.g. any MACRO-FUNCTION goes away. - (proclaim-as-fun-name name) - (note-name-defined name :function) + ;; Now references to this function shouldn't be warned + ;; about as undefined, since even if we haven't seen a + ;; definition yet, we know one is planned. + ;; + ;; Other consequences of we-know-you're-a-function-now + ;; are appropriate too, e.g. any MACRO-FUNCTION goes away. + (proclaim-as-fun-name name) + (note-name-defined name :function) - ;; the actual type declaration - (setf (info :function :type name) ctype - (info :function :where-from name) :declared))) - (push raw-form *queued-proclaims*))) + ;; the actual type declaration + (setf (info :function :type name) ctype + (info :function :where-from name) :declared))) + (push raw-form *queued-proclaims*))) (freeze-type (dolist (type args) - (let ((class (specifier-type type))) - (when (typep class 'classoid) - (setf (classoid-state class) :sealed) - (let ((subclasses (classoid-subclasses class))) - (when subclasses - (dohash (subclass layout subclasses) - (declare (ignore layout)) - (setf (classoid-state subclass) :sealed)))))))) + (let ((class (specifier-type type))) + (when (typep class 'classoid) + (setf (classoid-state class) :sealed) + (let ((subclasses (classoid-subclasses class))) + (when subclasses + (dohash ((subclass layout) subclasses :locked t) + (declare (ignore layout)) + (setf (classoid-state subclass) :sealed)))))))) (optimize (setq *policy* (process-optimize-decl form *policy*))) (muffle-conditions (setq *handled-conditions* - (process-muffle-conditions-decl form *handled-conditions*))) + (process-muffle-conditions-decl form *handled-conditions*))) (unmuffle-conditions (setq *handled-conditions* - (process-unmuffle-conditions-decl form *handled-conditions*))) + (process-unmuffle-conditions-decl form *handled-conditions*))) ((disable-package-locks enable-package-locks) (setq *disabled-package-locks* (process-package-lock-decl form *disabled-package-locks*))) ((inline notinline maybe-inline) (dolist (name args) - (proclaim-as-fun-name name) ; since implicitly it is a function - (setf (info :function :inlinep name) - (ecase kind - (inline :inline) - (notinline :notinline) - (maybe-inline :maybe-inline))))) + ; since implicitly it is a function, also scrubs *FREE-FUNS* + (proclaim-as-fun-name name) + (setf (info :function :inlinep name) + (ecase kind + (inline :inline) + (notinline :notinline) + (maybe-inline :maybe-inline))))) (declaration (dolist (decl args) - (unless (symbolp decl) - (error "In~% ~S~%the declaration to be recognized is not a ~ + (unless (symbolp decl) + (error "In~% ~S~%the declaration to be recognized is not a ~ symbol:~% ~S" - form decl)) - (with-single-package-locked-error + form decl)) + (with-single-package-locked-error (:symbol decl "globally declaring ~A as a declaration proclamation")) - (setf (info :declaration :recognized decl) t))) + (setf (info :declaration :recognized decl) t))) (t (unless (info :declaration :recognized kind) - (compiler-warn "unrecognized declaration ~S" raw-form))))) + (compiler-warn "unrecognized declaration ~S" raw-form))))) #+sb-xc (/show0 "returning from PROCLAIM") (values))