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)))