0.6.12.3:

[sbcl.git] / src / compiler / proclaim.lisp

diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp
index 792c37c..3c94f2f 100644 (file)
--- a/src/compiler/proclaim.lisp
+++ b/src/compiler/proclaim.lisp
@@ -71,7 +71,8 @@
 ;;; defaulted from the POLICY argument.
 (declaim (ftype (function (list policy) policy) process-optimize-decl))
 (defun process-optimize-decl (spec policy)
-  (let ((result policy)) ; may have new entries pushed on it below
+  (let ((result nil))
+    ;; 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)
@@ -88,6 +89,11 @@
              (t
               (push (cons quality (rational raw-value))
                     result)))))
+    ;; Add any nonredundant entries from old POLICY.
+    (dolist (old-entry policy)
+      (unless (assq (car old-entry) result)
+       (push old-entry result)))
+    ;; Voila.
     result))
 
 ;;; ANSI defines the declaration (FOO X Y) to be equivalent to
@@ -96,7 +102,7 @@
 (defun canonized-decl-spec (decl-spec)
   (let ((id (first decl-spec)))
     (unless (symbolp id)
-      (error "The declaration identifier is not a symbol: ~S" what))
+      (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)))
       (cond ((and id-is-type id-is-declared-decl)
@@ -190,11 +196,12 @@
                    (when (eq (info :function :where-from name) :declared)
                      (let ((old-type (info :function :type name)))
                        (when (type/= type old-type)
-                         (style-warn "new FTYPE proclamation~@
-                                       ~S~@
-                                       for ~S does not match old FTYPE proclamation~@
-                                       ~S"
-                                     (list type name old-type)))))
+                         (style-warn
+                          "new FTYPE proclamation~@
+                            ~S~@
+                            for ~S does not match old FTYPE proclamation~@
+                            ~S"
+                          (list type name old-type)))))
 
                    (proclaim-as-function-name name)
                    (note-name-defined name :function)
@@ -203,7 +210,7 @@
       (freeze-type
        (dolist (type args)
         (let ((class (specifier-type type)))
-          (when (typep class 'class)
+          (when (typep class 'sb!xc:class)
             (setf (class-state class) :sealed)
             (let ((subclasses (class-subclasses class)))
               (when subclasses
@@ -211,10 +218,7 @@
                   (declare (ignore layout))
                   (setf (class-state subclass) :sealed))))))))
       (optimize
-       (setq *default-policy* (process-optimize-decl form *default-policy*)))
-      (optimize-interface
-       (setq *default-interface-policy*
-            (process-optimize-decl form *default-interface-policy*)))
+       (setq *policy* (process-optimize-decl form *policy*)))
       ((inline notinline maybe-inline)
        (dolist (name args)
         (proclaim-as-function-name name)