X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fproclaim.lisp;h=3c94f2fa01ebdd8a7157f541613f04140f831290;hb=b5703d98da9ebfd688c87e14862ab4e26dc94d14;hp=d835f987afb928e30253c93a69b083edbebf7826;hpb=82e0a78df47685519b12683f495d7ae19e07d3cf;p=sbcl.git

diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp
index d835f98..3c94f2f 100644
--- a/src/compiler/proclaim.lisp
+++ b/src/compiler/proclaim.lisp
@@ -69,16 +69,17 @@
 ;;; Return a new POLICY containing the policy information represented
 ;;; by the optimize declaration SPEC. Any parameters not specified are
 ;;; defaulted from the POLICY argument.
-(declaim (ftype (function (list policy) policy) process-optimize-declaration))
-(defun process-optimize-declaration (spec policy)
-  (let ((result policy)) ; may have new entries pushed on it below
+(declaim (ftype (function (list policy) policy) process-optimize-decl))
+(defun process-optimize-decl (spec policy)
+  (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)
 	      (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-p quality))
+	(cond ((not (policy-quality-name-p quality))
 	       (compiler-warning "ignoring unknown optimization quality ~
                                  ~S in ~S"
 				 quality spec))
@@ -88,13 +89,36 @@
 	      (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))
 
-(defun sb!xc:proclaim (form)
-  (unless (consp form)
-    (error "malformed PROCLAIM spec: ~S" form))
-  (let ((kind (first form))
-	(args (rest form)))
+;;; ANSI defines the declaration (FOO X Y) to be equivalent to
+;;; (TYPE FOO X Y) when FOO is a type specifier. This function
+;;; 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)))
+      (cond ((and id-is-type id-is-declared-decl)
+	     (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)))))
+
+(defun sb!xc:proclaim (raw-form)
+  (let* ((form (canonized-decl-spec raw-form))
+	 (kind (first form))
+	 (args (rest form)))
     (case kind
       (special
        (dolist (name args)
@@ -172,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)
@@ -185,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
@@ -193,11 +218,7 @@
 		   (declare (ignore layout))
 		   (setf (class-state subclass) :sealed))))))))
       (optimize
-       (setq *default-policy*
-	     (process-optimize-declaration form *default-policy*)))
-      (optimize-interface
-       (setq *default-interface-policy*
-	     (process-optimize-declaration form *default-interface-policy*)))
+       (setq *policy* (process-optimize-decl form *policy*)))
       ((inline notinline maybe-inline)
        (dolist (name args)
 	 (proclaim-as-function-name name)
@@ -206,21 +227,14 @@
 		 (inline :inline)
 		 (notinline :notinline)
 		 (maybe-inline :maybe-inline)))))
-      (constant-function
-       (let ((info (make-function-info
-		    :attributes (ir1-attributes movable foldable flushable
-						unsafe))))
-	 (dolist (name args)
-	   (proclaim-as-function-name name)
-	   (setf (info :function :info name) info))))
       (declaration
        (dolist (decl args)
 	 (unless (symbolp decl)
-	   (error "The declaration to be recognized is not a symbol: ~S" decl))
+	   (error "In~%  ~S~%the declaration to be recognized is not a ~
+                  symbol:~%  ~S"
+		  form decl))
 	 (setf (info :declaration :recognized decl) t)))
       (t
-       (cond ((member kind *standard-type-names*)
-	      (sb!xc:proclaim `(type ,@form))) ; FIXME: ,@ instead of . ,
-	     ((not (info :declaration :recognized kind))
-	      (warn "unrecognized proclamation: ~S" form))))))
+       (unless (info :declaration :recognized kind)
+	 (compiler-warning "unrecognized declaration ~S" raw-form)))))
   (values))