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

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index a1df32b..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))
@@ -1104,6 +1116,38 @@
 	(setf (lambda-var-ignorep var) t)))))
   (values))
 
+(defun process-dx-decl (names vars)
+  (flet ((maybe-notify (control &rest args)
+	   (when (policy *lexenv* (> speed inhibit-warnings))
+	     (apply #'compiler-notify control args))))
+    (if (policy *lexenv* (= stack-allocate-dynamic-extent 3))
+	(dolist (name names)
+	  (cond
+	    ((symbolp name)
+	     (let* ((bound-var (find-in-bindings vars name))
+		    (var (or bound-var
+			     (lexenv-find name vars)
+			     (find-free-var name))))
+	       (etypecase var
+		 (leaf
+		  (if bound-var
+		      (setf (leaf-dynamic-extent var) t)
+		      (maybe-notify
+		       "ignoring DYNAMIC-EXTENT declaration for free ~S"
+		       name)))
+		 (cons
+		  (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
+		 (heap-alien-info
+		  (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S"
+				  name)))))
+	    ((and (consp name)
+		  (eq (car name) 'function)
+		  (null (cddr name))
+		  (valid-function-name-p (cadr name)))
+	     (maybe-notify "ignoring DYNAMIC-EXTENT declaration for ~S" name))
+	    (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name))))
+      (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names))))
+
 ;;; FIXME: This is non-ANSI, so the default should be T, or it should
 ;;; go away, I think.
 (defvar *suppress-values-declaration* nil
@@ -1134,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
@@ -1146,10 +1200,7 @@
                        `(values ,@types)))))
           res))
        (dynamic-extent
-        (when (policy *lexenv* (> speed inhibit-warnings))
-          (compiler-notify
-           "compiler limitation: ~
-          ~%  There's no special support for DYNAMIC-EXTENT (so it's ignored)."))
+	(process-dx-decl (cdr spec) vars)
         res)
        (t
         (unless (info :declaration :recognized (first spec))