X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fproclaim.lisp;h=755467a6f618189d8d0da7f7a93191630ad067ce;hb=7f579b076a1fc54587538ead07e506e7f06f3fe8;hp=8381cd91327cf4510e0101ea9cd7fb3650d46c29;hpb=203e466f5fbb3bffa7b4beb19d87bed6f8a1b5db;p=sbcl.git diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 8381cd9..755467a 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -45,11 +45,12 @@ (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)) + (or (policy-quality-deprecation-warning quality) + (compiler-warn + "~@" + quality spec))) ((not (typep raw-value 'policy-quality)) - (compiler-warn "ignoring bad optimization value ~S in ~S" + (compiler-warn "~@" raw-value spec)) (t ;; we can't do this yet, because CLOS macros expand @@ -65,7 +66,7 @@ (unless (assq (car old-entry) result) (push old-entry result))) ;; Voila. - result)) + (sort-policy result))) (declaim (ftype (function (list list) list) process-handle-conditions-decl)) @@ -168,16 +169,35 @@ (kind (first form)) (args (rest form))) (case kind - (special + ((special global) + (flet ((make-special (name old) + (unless (member old '(:special :unknown)) + (error "Cannot proclaim a ~(~A~) variable special: ~S" old name)) + (with-single-package-locked-error + (:symbol name "globally declaring ~A special") + (setf (info :variable :kind name) :special))) + (make-global (name old) + (unless (member old '(:global :unknown)) + (error "Cannot proclaim a ~(~A~) variable global: ~S" old name)) + (with-single-package-locked-error + (:symbol name "globally declaring ~A global") + (setf (info :variable :kind name) :global)))) + (let ((fun (if (eq 'special kind) #'make-special #'make-global))) + (dolist (name args) + (unless (symbolp name) + (error "Can't declare a non-symbol as ~S: ~S" kind name)) + (funcall fun name (info :variable :kind name)))))) + (always-bound (dolist (name args) (unless (symbolp name) - (error "can't declare a non-symbol as SPECIAL: ~S" name)) - (when (sb!xc:constantp name) - (error "can't declare a constant as SPECIAL: ~S" name)) + (error "Can't proclaim a non-symbol as ~S: ~S" kind name)) + (unless (boundp name) + (error "Can't proclaim an unbound symbol as ~S: ~S" kind name)) + (when (eq :constant (info :variable :kind name)) + (error "Can't proclaim a constant variable as ~S: ~S" kind name)) (with-single-package-locked-error - (:symbol name "globally declaring ~A special")) - (clear-info :variable :constant-value name) - (setf (info :variable :kind name) :special))) + (:symbol name "globally declaring ~A always bound") + (setf (info :variable :always-bound name) t)))) (type (if *type-system-initialized* (let ((type (specifier-type (first args)))) @@ -189,10 +209,12 @@ (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~@ - for ~S does not match the old TYPE~@ - proclamation ~S" - type name old-type)))) + ;; FIXME: changing to TYPE-PROCLAMATION-MISMATCH + ;; broke late-proclaim.lisp. + (style-warn + "~@" + name (type-specifier type) (type-specifier old-type))))) (setf (info :variable :type name) type) (setf (info :variable :where-from name) :declared))) (push raw-form *queued-proclaims*))) @@ -203,29 +225,36 @@ (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) - (style-warn - "new FTYPE proclamation~@ - ~S~@ - for ~S does not match old FTYPE proclamation~@ - ~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) + (: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. + (if (info :function :info name) + ;; Allow for tightening of known function types + (unless (csubtypep ctype old-type) + (cerror "Continue" + "~@" + name (type-specifier ctype) (type-specifier old-type))) + (#+sb-xc-host warn + #-sb-xc-host style-warn + "~@" + name (type-specifier ctype) (type-specifier 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) - ;; the actual type declaration - (setf (info :function :type name) ctype - (info :function :where-from name) :declared))) + ;; 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) @@ -234,7 +263,7 @@ (setf (classoid-state class) :sealed) (let ((subclasses (classoid-subclasses class))) (when subclasses - (dohash (subclass layout subclasses) + (dohash ((subclass layout) subclasses :locked t) (declare (ignore layout)) (setf (classoid-state subclass) :sealed)))))))) (optimize @@ -250,7 +279,8 @@ (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 + ; since implicitly it is a function, also scrubs *FREE-FUNS* + (proclaim-as-fun-name name) (setf (info :function :inlinep name) (ecase kind (inline :inline)