X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1tran.lisp;h=22654d10e31714d03fde3d7b4b9e2ae104347159;hb=dde834ef75cb12b8cdda23472b3365de72d9422a;hp=a58d8d7757a63b0dd3fb293ee96efb0ebc32e53f;hpb=4ccd8dcd4b936ca6a0f989e12397bd9426905a11;p=sbcl.git

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index a58d8d7..22654d1 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -624,7 +624,7 @@
 	   ;; there's no need for us to accept ANSI's lameness when
 	   ;; processing our own code, though.
 	   #+sb-xc-host
-	   (compiler-warn "reading an ignored variable: ~S" name)))
+	   (warn "reading an ignored variable: ~S" name)))
        (reference-leaf start next result var))
       (cons
        (aver (eq (car var) 'MACRO))
@@ -743,8 +743,8 @@
                                 (muffle-warning-or-die)))
 		     #-(and cmu sb-xc-host)
 		     (warning (lambda (c)
-				(compiler-warn "~@<~A~:@_~A~@:_~A~:>"
-					       (wherestring) hint c)
+				(warn "~@<~A~:@_~A~@:_~A~:>"
+				      (wherestring) hint c)
 				(muffle-warning-or-die)))
                      (error (lambda (c)
                               (compiler-error "~@<~A~:@_~A~@:_~A~:>"
@@ -922,28 +922,38 @@
     (collect ((restr nil cons)
              (new-vars nil cons))
       (dolist (var-name (rest decl))
+	(when (boundp var-name)
+	  (with-single-package-locked-error
+              (:symbol var-name "declaring the type of ~A")))
 	(let* ((bound-var (find-in-bindings vars var-name))
 	       (var (or bound-var
 			(lexenv-find var-name vars)
 			(find-free-var var-name))))
 	  (etypecase var
 	    (leaf
-             (flet ((process-var (var bound-var)
-                      (let* ((old-type (or (lexenv-find var type-restrictions)
-                                           (leaf-type var)))
-                             (int (if (or (fun-type-p type)
-                                          (fun-type-p old-type))
-                                      type
-                                      (type-approx-intersection2 old-type type))))
-                        (cond ((eq int *empty-type*)
-                               (unless (policy *lexenv* (= inhibit-warnings 3))
-                                 (compiler-warn
-                                  "The type declarations ~S and ~S for ~S conflict."
-                                  (type-specifier old-type) (type-specifier type)
-                                  var-name)))
-                              (bound-var (setf (leaf-type bound-var) int))
-                              (t
-                               (restr (cons var int)))))))
+             (flet 
+		 ((process-var (var bound-var)
+		    (let* ((old-type (or (lexenv-find var type-restrictions)
+					 (leaf-type var)))
+			   (int (if (or (fun-type-p type)
+					(fun-type-p old-type))
+				    type
+				    (type-approx-intersection2 
+				     old-type type))))
+		      (cond ((eq int *empty-type*)
+			     (unless (policy *lexenv* (= inhibit-warnings 3))
+			       (warn
+				'type-warning
+				:format-control
+				"The type declarations ~S and ~S for ~S conflict."
+				:format-arguments
+				(list
+				 (type-specifier old-type) 
+				 (type-specifier type)
+				 var-name))))
+			    (bound-var (setf (leaf-type bound-var) int))
+			    (t
+			     (restr (cons var int)))))))
                (process-var var bound-var)
                (awhen (and (lambda-var-p var)
                            (lambda-var-specvar var))
@@ -975,6 +985,9 @@
   (let ((type (compiler-specifier-type spec)))
     (collect ((res nil cons))
       (dolist (name names)
+	(when (fboundp name)
+	  (with-single-package-locked-error
+              (:symbol name "declaring the ftype of ~A")))
 	(let ((found (find name fvars
 			   :key #'leaf-source-name
 			   :test #'equal)))
@@ -999,6 +1012,8 @@
   (declare (list spec vars) (type lexenv res))
   (collect ((new-venv nil cons))
     (dolist (name (cdr spec))
+      (with-single-package-locked-error
+          (:symbol name "declaring ~A special"))
       (let ((var (find-in-bindings vars name)))
 	(etypecase var
 	  (cons
@@ -1171,6 +1186,16 @@
         (make-lexenv
          :default res
          :policy (process-optimize-decl spec (lexenv-policy res))))
+       (muffle-conditions
+	(make-lexenv
+	 :default res
+	 :handled-conditions (process-muffle-conditions-decl
+			      spec (lexenv-handled-conditions res))))
+       (unmuffle-conditions
+	(make-lexenv
+	 :default res
+	 :handled-conditions (process-unmuffle-conditions-decl
+			      spec (lexenv-handled-conditions res))))
        (type
         (process-type-decl (cdr spec) res vars))
        (values
@@ -1185,6 +1210,11 @@
        (dynamic-extent
 	(process-dx-decl (cdr spec) vars)
         res)
+       ((disable-package-locks enable-package-locks)
+        (make-lexenv
+         :default res
+         :disabled-package-locks (process-package-lock-decl 
+                                  spec (lexenv-disabled-package-locks res))))
        (t
         (unless (info :declaration :recognized (first spec))
           (compiler-warn "unrecognized declaration ~S" raw-spec))