From: Christophe Rhodes <csr21@cantab.net>
Date: Wed, 26 Aug 2009 17:01:49 +0000 (+0000)
Subject: 1.0.30.52: fix for multiple-value TRUNCATE
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=41affad5889b78b0f4666bb18cd6bce43b0538d4;p=sbcl.git

1.0.30.52: fix for multiple-value TRUNCATE

Regression from 1.0.30 (in 1.0.30.28); Noted by Lars Nostdal; fix by
Paul Khuong
---

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index 6a51a47..a1184e1 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -1517,7 +1517,7 @@
                                         (,type
                                          &optional (or ,type ,@other-float-arg-types integer))
                                         * :result result)
-                  (let ((result-type (lvar-type result)))
+                  (let ((result-type (lvar-derived-type result)))
                     (if (or (not y)
                             (and (constant-lvar-p y) (= 1 (lvar-value y))))
                         (if (values-type-p result-type)
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index fd89794..5d3c463 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3302,7 +3302,7 @@
     (assert (or (= ret (+ (* 5 256) 4)) (= ret (+ (* 4 256) 5))))))
 
 (with-test (:name :coerce-type-warning)
-  (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) 
+  (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32)
                   (signed-byte 8) (signed-byte 16) (signed-byte 32)))
     (multiple-value-bind (fun warningsp failurep)
         (compile nil `(lambda (x)
@@ -3311,3 +3311,12 @@
       (assert (null warningsp))
       (assert (null failurep))
       (assert (typep (funcall fun #(1)) `(simple-array ,type (*)))))))
+
+(with-test (:name :truncate-double-float)
+  (let ((fun (compile nil `(lambda (x)
+                             (multiple-value-bind (q r)
+                                 (truncate (coerce x 'double-float))
+                               (declare (type unsigned-byte q)
+                                        (type double-float r))
+                               (list q r))))))
+    (assert (equal (funcall fun 1.0d0) '(1 0.0d0)))))
diff --git a/version.lisp-expr b/version.lisp-expr
index 044d9aa..1dd0551 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.30.51"
+"1.0.30.52"