cmucl-cvs February 2018

cmucl-cvs@common-lisp.net

1 participants
12 discussions

[Git][cmucl/cmucl][rtoy-fix-59-derive-decode-float] 3 commits: Fix typo. double-double-float is in the kernel package
by Raymond Toy 04 Feb '18

04 Feb '18

Raymond Toy pushed to branch rtoy-fix-59-derive-decode-float at cmucl / cmucl Commits: 2292400e by Raymond Toy at 2018-02-04T08:16:35-08:00 Fix typo. double-double-float is in the kernel package - - - - - 4e58e53c by Raymond Toy at 2018-02-04T08:19:13-08:00 Be more careful in computing the decode-float bounds If 0 is the lower bound then the smallest exponent is not for 0, but for the least positive float because of denormals. Also handle exclusive bounds. - - - - - 7b336362 by Raymond Toy at 2018-02-04T08:19:37-08:00 Add more tests decode-float. - - - - - 3 changed files: - src/compiler/float-tran.lisp - tests/float-tran.lisp - tests/issues.lisp Changes: ===================================== src/compiler/float-tran.lisp ===================================== --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -2031,29 +2031,33 @@ (labels ((calc-exp (x) (when x - (nth-value 1 (decode-float x)))) - (min-exp () - ;; Use decode-float on the least positive float of the - ;; appropriate type to find the min exponent. If we don't - ;; know the actual number format, use double, which has the - ;; widest range (including double-double-float). - (calc-exp (if (eq 'single-float (numeric-type-format arg)) - least-positive-single-float - least-positive-double-float))) - (max-exp () + (bound-func #'(lambda (arg) + (nth-value 1 (decode-float arg))) + x))) + (min-exp (interval) + ;; (decode-float 0d0) returns an exponent of -1022. But + ;; (decode-float least-positive-double-float returns -1073. + ;; Hence, if the low value is less than this, we need to + ;; return the exponent of the least positive number. + (let ((least (if (eq 'single-float (numeric-type-format arg)) + least-positive-single-float + least-positive-double-float))) + (if (or (interval-contains-p 0 interval) + (interval-contains-p least interval)) + (calc-exp least) + (calc-exp (bound-value (interval-low interval)))))) + (max-exp (interval) ;; Use decode-float on the most postive number of the ;; appropriate type to find the max exponent. If we don't ;; know the actual number format, use double, which has the ;; widest range (including double-double-float). - (calc-exp (if (eq 'single-float (numeric-type-format arg)) - most-positive-single-float - most-positive-double-float)))) - (let* ((interval (interval-func #'calc-exp - (interval-abs (numeric-type->interval arg)))) - (lo (or (interval-low interval) - (min-exp))) - (hi (or (interval-high interval) - (max-exp)))) + (or (calc-exp (bound-value (interval-high interval))) + (calc-exp (if (eq 'single-float (numeric-type-format arg)) + most-positive-single-float + most-positive-double-float))))) + (let* ((interval (interval-abs (numeric-type->interval arg))) + (lo (min-exp interval)) + (hi (max-exp interval))) (specifier-type `(integer ,(or lo '*) ,(or hi '*)))))) (defun decode-float-sign-derive-type-aux (arg) ===================================== tests/float-tran.lisp ===================================== --- a/tests/float-tran.lisp +++ b/tests/float-tran.lisp @@ -28,7 +28,7 @@ #+double-double (assert-equalp (c::specifier-type '(integer -1073 1024)) (c::decode-float-exp-derive-type-aux - (c::specifier-type 'double-double-float))) + (c::specifier-type 'kernel:double-double-float))) (assert-equalp (c::specifier-type '(integer 2 8)) (c::decode-float-exp-derive-type-aux (c::specifier-type '(double-float 2d0 128d0))))) ===================================== tests/issues.lisp ===================================== --- a/tests/issues.lisp +++ b/tests/issues.lisp @@ -450,3 +450,57 @@ (declare (type (double-float -2d0 0d0) z)) (nth-value 2 (decode-float z)))))) (assert-equal -1d0 (funcall f -1d0)))) + +(define-test issue.59.1-double + (:tag :issues) + (dolist (entry '(((-2d0 2d0) (-1073 2)) + ((-2d0 0d0) (-1073 2)) + ((0d0 2d0) (-1073 2)) + ((1d0 4d0) (1 3)) + ((-4d0 -1d0) (1 3)) + (((0d0) (10d0)) (-1073 4)) + ((-2f0 2f0) (-148 2)) + ((-2f0 0f0) (-148 2)) + ((0f0 2f0) (-148 2)) + ((1f0 4f0) (1 3)) + ((-4f0 -1f0) (1 3)) + ((0f0) (10f0)) (-148 4))) + (destructuring-bind ((arg-lo arg-hi) (result-lo result-hi)) + entry + (assert-equalp (c::specifier-type `(integer ,result-lo ,result-hi)) + (c::decode-float-exp-derive-type-aux + (c::specifier-type `(double-float ,arg-lo ,arg-hi))))))) + +(define-test issue.59.1-double + (:tag :issues) + (dolist (entry '(((-2d0 2d0) (-1073 2)) + ((-2d0 0d0) (-1073 2)) + ((0d0 2d0) (-1073 2)) + ((1d0 4d0) (1 3)) + ((-4d0 -1d0) (1 3)) + (((0d0) (10d0)) (-1073 4)) + (((0.5d0) (4d0)) (0 3)))) + (destructuring-bind ((arg-lo arg-hi) (result-lo result-hi)) + entry + (assert-equalp (c::specifier-type `(integer ,result-lo ,result-hi)) + (c::decode-float-exp-derive-type-aux + (c::specifier-type `(double-float ,arg-lo ,arg-hi))) + arg-lo + arg-hi)))) + +(define-test issue.59.1-float + (:tag :issues) + (dolist (entry '(((-2f0 2f0) (-148 2)) + ((-2f0 0f0) (-148 2)) + ((0f0 2f0) (-148 2)) + ((1f0 4f0) (1 3)) + ((-4f0 -1f0) (1 3)) + (((0f0) (10f0)) (-148 4)) + (((0.5f0) (4f0)) (0 3)))) + (destructuring-bind ((arg-lo arg-hi) (result-lo result-hi)) + entry + (assert-equalp (c::specifier-type `(integer ,result-lo ,result-hi)) + (c::decode-float-exp-derive-type-aux + (c::specifier-type `(single-float ,arg-lo ,arg-hi))) + arg-lo + arg-hi)))) \ No newline at end of file View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/62c5f3e9a170e5f8799f37b3… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/62c5f3e9a170e5f8799f37b3… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch rtoy-fix-59-derive-decode-float
by Raymond Toy 03 Feb '18

03 Feb '18

Raymond Toy pushed new branch rtoy-fix-59-derive-decode-float at cmucl / cmucl --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/tree/rtoy-fix-59-derive-decode-f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs February 2018