Warn when wrapping constants with THE of multiple value types

IR1 translation was too eager in eliminating redundant THE forms
when the value is a constant.  We now also make sure that the
asserted type accepts single values.

Reported by Nathan Trapuzzano on sbcl-help.

diff --git a/NEWS b/NEWS
index 64ec424..c2fe8cd 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -17,10 +17,13 @@ changes relative to sbcl-1.1.12:
     vectors from FASLs. (Reported by Jan Moringen)
   * bug fix: COMPILE can now succefully compile setf functions.
     (Reported by Douglas Katzman)
-  * bug fix: run-prorgram performs more correct escaping of arguments on
+  * bug fix: run-program performs more correct escaping of arguments on
     Windows. (lp#1239242)
   * bug fix: function-lambda-expression on generic functions returns the
     actual name.
+  * bug fix: (the [type] [constant]) now warns when [constant] matches
+    [type] except for the number of values.  (Reported by Nathan Trapuzzano
+    on sbcl-help)
 
 changes in sbcl-1.1.12 relative to sbcl-1.1.11:
   * enhancement: Add sb-bsd-sockets:socket-shutdown, for calling

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index add4fa1..7bd2bfb 100644 (file)
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -912,6 +912,8 @@ other."
                     (values-subtypep (make-single-value-type (leaf-type value))
                                      type))
                (and (sb!xc:constantp value)
+                    (or (not (values-type-p type))
+                        (values-type-may-be-single-value-p type))
                     (ctypep (constant-form-value value)
                             (single-value-type type))))
            (ir1-convert start next result value))

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 83353e1..92079e7 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4870,3 +4870,13 @@
     (test `(lambda (x y) (setf (apply #'aref x y) 21)))
     (test `(lambda (x y) (setf (apply #'bit x y) 1)))
     (test `(lambda (x y) (setf (apply #'sbit x y) 0)))))
+
+(with-test (:name :warn-on-the-values-constant)
+  (multiple-value-bind (fun warnings-p failure-p)
+      (compile nil
+               ;; The compiler used to elide this test without
+               ;; noting that the type demands multiple values.
+               '(lambda () (the (values fixnum fixnum) 1)))
+    (declare (ignore warnings-p))
+    (assert (functionp fun))
+    (assert failure-p)))