0.8.10.57:

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

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index a1df32b..37ddb42 100644 (file)
--- 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))