[git] CMU Common Lisp branch master updated. snapshot-2014-09-7-gd03e178

[Raymond Toy]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CMU Common Lisp".

The branch, master has been updated
       via  d03e178481b3be542e4a2519890ed2772d081fb6 (commit)
      from  13bd32f69a31581b50582d6283ba08b745eca6d3 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit d03e178481b3be542e4a2519890ed2772d081fb6
Author: Raymond Toy <toy.raymond at gmail.com>
Date:   Fri Sep 19 22:35:27 2014 -0700

    Fix error in type derivation for the sign in DECODE-FLOAT.
    
    Type derivation of the sign of (DECODE-FLOAT X) returned the incorrect
    value when x was declared to be of type (DOUBLE-FLOAT (0d0)).
    
     * src/compiler/float-tran.lisp
       * Fix type derivation
     * tests/float-tran.lisp
       * New file for tests of DECODE-FLOAT-SIGN-DERIVE-TYPE-AUX.
     * tests/float.lisp
       * New file to test that decode-float is compiled correctly.

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index ccb6e06..4aecd5c 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -2082,24 +2082,19 @@
 
 (defun decode-float-sign-derive-type-aux (arg)
   ;; Derive the sign of the float.
-  (flet ((calc-sign (x)
-	   (when x
-	     (nth-value 2 (decode-float x)))))
-    (let* ((lo (bound-func #'calc-sign
-			       (numeric-type-low arg)))
-	   (hi (bound-func #'calc-sign
-			       (numeric-type-high arg))))
-      (if (numeric-type-format arg)
-	  (specifier-type `(,(numeric-type-format arg)
-			     ;; If lo or high bounds are NIL, use -1
-			     ;; or 1 of the appropriate type instead.
-			     ,(or lo (coerce -1 (numeric-type-format arg)))
-			     ,(or hi (coerce 1  (numeric-type-format arg)))))
-	  (specifier-type '(or (member 1f0 -1f0
-				1d0 -1d0
-				#+double-double 1w0
-				#+double-double -1w0)))))))
-
+  (if (numeric-type-format arg)
+      (let ((arg-range (interval-range-info (numeric-type->interval arg))))
+	(case arg-range
+	  (+ (make-member-type :members (list (coerce 1 (numeric-type-format arg)))))
+	  (- (make-member-type :members (list (coerce -1 (numeric-type-format arg)))))
+	  (otherwise
+	   (make-member-type :members (list (coerce 1 (numeric-type-format arg))
+					    (coerce -1 (numeric-type-format arg)))))))
+      (specifier-type '(or (member 1f0 -1f0
+			    1d0 -1d0
+			    #+double-double 1w0
+			    #+double-double -1w0)))))
+    
 (defoptimizer (decode-float derive-type) ((num))
   (let ((f (one-arg-derive-type num
 				#'(lambda (arg)
diff --git a/tests/float-tran.lisp b/tests/float-tran.lisp
new file mode 100644
index 0000000..9c81882
--- /dev/null
+++ b/tests/float-tran.lisp
@@ -0,0 +1,17 @@
+;; Tests for various float transformations.
+
+(defpackage :float-tran-tests
+  (:use :cl :lisp-unit))
+
+(in-package "FLOAT-TRAN-TESTS")
+
+(define-test decode-float-sign
+  "Test type derivation of the sign from decode-float"
+  (assert-equalp (c::make-member-type :members (list 1f0 -1f0))
+		 (c::decode-float-sign-derive-type-aux (c::specifier-type 'single-float)))
+  (assert-equalp (c::make-member-type :members (list 1d0 -1d0))
+		 (c::decode-float-sign-derive-type-aux (c::specifier-type 'double-float)))
+  (assert-equalp (c::make-member-type :members (list 1f0))
+		 (c::decode-float-sign-derive-type-aux (c::specifier-type '(single-float (0f0))))))
+
+  
\ No newline at end of file
diff --git a/tests/float.lisp b/tests/float.lisp
new file mode 100644
index 0000000..6fe1f50
--- /dev/null
+++ b/tests/float.lisp
@@ -0,0 +1,12 @@
+;; Tests of float functions
+
+(defpackage :float-tests
+  (:use :cl :lisp-unit))
+
+(in-package "FLOAT-TESTS")
+
+(define-test decode-float
+  (assert-true (funcall (compile nil #'(lambda (x)
+					 (declare (type (double-float (0d0)) x))
+					 (decode-float x)))
+			1d0)))

-----------------------------------------------------------------------

Summary of changes:
 src/compiler/float-tran.lisp |   31 +++++++++++++------------------
 tests/float-tran.lisp        |   17 +++++++++++++++++
 tests/float.lisp             |   12 ++++++++++++
 3 files changed, 42 insertions(+), 18 deletions(-)
 create mode 100644 tests/float-tran.lisp
 create mode 100644 tests/float.lisp


hooks/post-receive
-- 
CMU Common Lisp