X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=62aa72ebee8864eed8fc7ac4926c26bbc595d471;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=dc9cffd8b2072e70e618b74bf25d12f6c1a622d3;hpb=feba3c704ebcf93a3351422fcc6cf8fa60b2637e;p=sbcl.git

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index dc9cffd..62aa72e 100644
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -851,8 +851,10 @@
       (let ((name (key-info-name key)))
         (do ((arg args (cddr arg)))
             ((null arg))
-          (when (eq (lvar-value (first arg)) name)
-            (funcall fun (second arg) (key-info-type key))))))))
+          (let ((keyname (first arg)))
+            (when (and (constant-lvar-p keyname)
+                       (eq (lvar-value keyname) name))
+              (funcall fun (second arg) (key-info-type key)))))))))
 
 ;;; Assert that CALL is to a function of the specified TYPE. It is
 ;;; assumed that the call is legal and has only constants in the
@@ -864,13 +866,17 @@
     (if trusted
         (derive-node-type call returns)
         (let ((lvar (node-lvar call)))
-          ;; If the value is used in a non-tail position, and
-          ;; the lvar is a single-use, assert the type. Multiple use
-          ;; sites need to be elided because the assertion has to apply
-          ;; to all uses. Tail positions are elided because the assertion
-          ;; would lose cause us not the be in a tail-position anymore.
+          ;; If the value is used in a non-tail position, and the lvar
+          ;; is a single-use, assert the type. Multiple use sites need
+          ;; to be elided because the assertion has to apply to all
+          ;; uses. Tail positions are elided because the assertion
+          ;; would cause us not the be in a tail-position anymore. MV
+          ;; calls are elided because not only are the assertions of
+          ;; less use there, but they can cause the MV call conversion
+          ;; to cause astray.
           (when (and lvar
                      (not (return-p (lvar-dest lvar)))
+                     (not (mv-combination-p (lvar-dest lvar)))
                      (lvar-has-single-use-p lvar))
             (when (assert-lvar-type lvar returns policy)
               (reoptimize-lvar lvar)))))
@@ -886,32 +892,95 @@
   (declare (type lvar tag))
   (let ((ctype (lvar-type tag)))
     (when (csubtypep ctype (specifier-type '(or number character)))
-      (compiler-style-warn "~@<using ~S of type ~S as a catch tag (which ~
-                            tends to be unportable because THROW and CATCH ~
-                            use EQ comparison)~@:>"
-                           (lvar-source tag)
-                           (type-specifier (lvar-type tag))))))
-
-(defun %compile-time-type-error (values atype dtype)
+      (let ((sources (lvar-all-sources tag)))
+        (if (singleton-p sources)
+            (compiler-style-warn
+             "~@<using ~S of type ~S as a catch tag (which ~
+                 tends to be unportable because THROW and CATCH ~
+                 use EQ comparison)~@:>"
+             (first sources)
+             (type-specifier (lvar-type tag)))
+            (compiler-style-warn
+             "~@<using ~{~S~^~#[~; or ~:;, ~]~} in ~S of type ~S ~
+                 as a catch tag (which tends to be unportable ~
+                 because THROW and CATCH use EQ comparison)~@:>"
+             (rest sources) (first sources)
+             (type-specifier (lvar-type tag))))))))
+
+(defun %compile-time-type-error (values atype dtype context)
   (declare (ignore dtype))
-  (if (and (consp atype)
-           (eq (car atype) 'values))
-      (error 'values-type-error :datum values :expected-type atype)
-      (error 'type-error :datum (car values) :expected-type atype)))
+  (destructuring-bind (form . detail) context
+    (if (and (consp atype) (eq (car atype) 'values))
+        (if (singleton-p detail)
+            (error 'simple-type-error
+                   :datum (car values)
+                   :expected-type atype
+                   :format-control
+                   "~@<Value set ~2I~_[~{~S~^ ~}] ~I~_from ~S in ~2I~_~S ~I~_is ~
+                   not of type ~2I~_~S.~:>"
+                   :format-arguments (list values
+                                           (first detail) form
+                                           atype))
+            (error 'simple-type-error
+                   :datum (car values)
+                   :expected-type atype
+                   :format-control
+                   "~@<Value set ~2I~_[~{~S~^ ~}] ~
+                   ~I~_from ~2I~_~{~S~^~#[~; or ~:;, ~]~} ~
+                   ~I~_of ~2I~_~S ~I~_in ~2I~_~S ~I~_is not of type ~2I~_~S.~:>"
+                   :format-arguments (list values
+                                           (rest detail) (first detail)
+                                           form
+                                           atype)))
+        (if (singleton-p detail)
+            (error 'simple-type-error
+                   :datum (car values)
+                   :expected-type atype
+                   :format-control "~@<Value of ~S in ~2I~_~S ~I~_is ~2I~_~S, ~
+                                ~I~_not a ~2I~_~S.~:@>"
+                   :format-arguments (list (car detail) form
+                                           (car values)
+                                           atype))
+            (error 'simple-type-error
+                   :datum (car values)
+                   :expected-type atype
+                   :format-control "~@<Value from ~2I~_~{~S~^~#[~; or ~:;, ~]~} ~
+                                   ~I~_of ~2I~_~S ~I~_in ~2I~_~S ~I~_is ~2I~_~S, ~
+                                   ~I~_not a ~2I~_~S.~:@>"
+                   :format-arguments (list (rest detail) (first detail) form
+                                           (car values)
+                                           atype))))))
 
 (defoptimizer (%compile-time-type-error ir2-convert)
-    ((objects atype dtype) node block)
+    ((objects atype dtype context) node block)
   (let ((*compiler-error-context* node))
     (setf (node-source-path node)
           (cdr (node-source-path node)))
-    (destructuring-bind (values atype dtype)
+    (destructuring-bind (values atype dtype context)
         (basic-combination-args node)
       (declare (ignore values))
       (let ((atype (lvar-value atype))
-            (dtype (lvar-value dtype)))
-      (unless (eq atype nil)
-        (warn 'type-warning
-              :format-control
-              "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
-              :format-arguments (list atype dtype)))))
+            (dtype (lvar-value dtype))
+            (detail (cdr (lvar-value context))))
+        (unless (eq atype nil)
+          (if (singleton-p detail)
+              (let ((detail (first detail)))
+                (if (constantp detail)
+                    (warn 'type-warning
+                          :format-control
+                          "~@<Constant ~2I~_~S ~Iconflicts with its ~
+                              asserted type ~2I~_~S.~@:>"
+                          :format-arguments (list (eval detail) atype))
+                    (warn 'type-warning
+                          :format-control
+                          "~@<Derived type of ~S is ~2I~_~S, ~
+                              ~I~_conflicting with ~
+                              its asserted type ~2I~_~S.~@:>"
+                          :format-arguments (list detail dtype atype))))
+              (warn 'type-warning
+                    :format-control
+                    "~@<Derived type of ~2I~_~{~S~^~#[~; and ~:;, ~]~} ~
+                     ~I~_in ~2I~_~S ~I~_is ~2I~_~S, ~I~_conflicting with ~
+                     their asserted type ~2I~_~S.~@:>"
+                    :format-arguments (list (rest detail) (first detail) dtype atype))))))
     (ir2-convert-full-call node block)))