X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=37ddb427cbee20c6f50bf36cf89b5f898e1ce9c1;hb=bfa4310e41dcd011ca9d139f29be1c5757b41378;hp=64f1f7d0a12eaceef4bbbbebdf5f7377380c023a;hpb=304c44d731bea3b9ce3c47d864d90eac92ba604e;p=sbcl.git

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 64f1f7d..37ddb42 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -396,7 +396,7 @@
     (let* ((forms (if for-value `(,form) `(,form nil)))
 	   (res (ir1-convert-lambda-body
 		 forms ()
-		 :debug-name (debug-namify "top level form ~S" form))))
+		 :debug-name (debug-namify "top level form " form))))
       (setf (functional-entry-fun res) res
 	    (functional-arg-documentation res) ()
 	    (functional-kind res) :toplevel)
@@ -520,7 +520,7 @@
 					      (ir1-convert-lambda
 					       opname
 					       :debug-name (debug-namify
-							    "LAMBDA CAR ~S"
+							    "LAMBDA CAR "
 							    opname)
 					       :allow-debug-catch-tag t))))))))
     (values))
@@ -619,7 +619,12 @@
 	 (when (lambda-var-ignorep var)
 	   ;; (ANSI's specification for the IGNORE declaration requires
 	   ;; that this be a STYLE-WARNING, not a full WARNING.)
-	   (compiler-style-warn "reading an ignored variable: ~S" name)))
+	   #-sb-xc-host
+	   (compiler-style-warn "reading an ignored variable: ~S" name)
+	   ;; there's no need for us to accept ANSI's lameness when
+	   ;; processing our own code, though.
+	   #+sb-xc-host
+	   (warn "reading an ignored variable: ~S" name)))
        (reference-leaf start next result var))
       (cons
        (aver (eq (car var) 'MACRO))
@@ -738,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~:>"
@@ -923,22 +928,29 @@
 			(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))
@@ -1166,6 +1178,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