Make MAKE-LISP-OBJ pickier on CHENEYGC.

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

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index dc9cffd..eddb7f1 100644 (file)
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -864,13 +864,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)))))
@@ -892,26 +896,49 @@
                            (lvar-source tag)
                            (type-specifier (lvar-type tag))))))
 
-(defun %compile-time-type-error (values atype dtype)
+(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))
+        (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
+                                       detail form
+                                       atype))
+        (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 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 (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))))))
     (ir2-convert-full-call node block)))