Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/tests
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv22397/tests

Modified Files:
	compiler.pure.lisp 
Log Message:
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


Index: compiler.pure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/compiler.pure.lisp,v
retrieving revision 1.211
retrieving revision 1.212
diff -u -d -r1.211 -r1.212
--- compiler.pure.lisp	23 Aug 2009 21:36:14 -0000	1.211
+++ compiler.pure.lisp	26 Aug 2009 17:01:49 -0000	1.212
@@ -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)))))