diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index ccb6e06090e70958756f69ce97c7229c07ca4b39..4aecd5cd2760f2b5715ce730c09e5bd819093b85 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 0000000000000000000000000000000000000000..9c818824ba70bab59e5c942e385475f36c5647a6
--- /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 0000000000000000000000000000000000000000..6fe1f50f78693b0dd66cbfc2bf2ec264246f9d1b
--- /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)))