X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fproclaim.lisp;h=ed783154a52f4706a39357bcde840cbf6a29e240;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=8381cd91327cf4510e0101ea9cd7fb3650d46c29;hpb=203e466f5fbb3bffa7b4beb19d87bed6f8a1b5db;p=sbcl.git

diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp
index 8381cd9..ed78315 100644
--- a/src/compiler/proclaim.lisp
+++ b/src/compiler/proclaim.lisp
@@ -45,11 +45,13 @@
               (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))
+               (let ((deprecation-warning (policy-quality-deprecation-warning quality spec)))
+                 (if deprecation-warning
+                     (compiler-warn deprecation-warning)
+                     (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"
+               (compiler-warn "~@<Ignoring bad optimization value ~S in:~_ ~S~:>"
                               raw-value spec))
               (t
                ;; we can't do this yet, because CLOS macros expand
@@ -65,7 +67,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 +170,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 +210,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
+                      "~@<new TYPE proclamation for ~S~@:_  ~S~@:_~
+                        does not match the old TYPE proclamation:~@:_  ~S~@:>"
+                      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*)))
@@ -207,12 +230,12 @@
                (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~@
-                       for ~S does not match old FTYPE proclamation~@
-                       ~S"
-                      ctype name old-type))))
+                      "~@<new FTYPE proclamation for ~S~@:_  ~S~@:_~
+                       does not match the old FTYPE proclamation:~@:_  ~S~@:>"
+                      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
@@ -234,7 +257,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 +273,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)