From b51c9978bcfab5952438a1c831949c8f387cfc90 Mon Sep 17 00:00:00 2001
From: Raymond Toy <toy.raymond@gmail.com>
Date: Fri, 19 Sep 2014 22:35:27 -0700
Subject: [PATCH] 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.
---
 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

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index ccb6e0609..4aecd5cd2 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 000000000..9c818824b
--- /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 000000000..6fe1f50f7
--- /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)))
-- 
GitLab