- cmucl-cvs - mailman3.common-lisp.net

[Cmucl-cvs] [git] CMU Common Lisp branch 20f-branch updated. snapshot-2014-09-13-g8329e1d
by Raymond Toy 02 Oct '14

02 Oct '14

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, 20f-branch has been updated via 8329e1d53ee57bf375c63675642b21358790ea2b (commit) from ab0a979db83310c64fcbbc13b178d5c31af9f5c9 (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 8329e1d53ee57bf375c63675642b21358790ea2b Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Oct 1 20:29:32 2014 -0700 Fix regression in %ENUMERATE-DIRECTORIES. Previously (18a at least), %ENUMERATE-DIRECTORIES would return a path even if a directory element did not exist. This behavior is restored. See email from cmucl-help, Sep 26, 2014. * src/code/filesys.lisp: * Fix regression.in %ENUMERATE-DIRECTORIES. Even if the directory does not exist, we continue recursing instead of stopping. * src/general-info/release-20f.txt: * Update * tests/filesys.lisp: * New file adding tests for UNIX-NAMESTRING. diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 9d224df..ee844e3 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -710,9 +710,13 @@ (with-directory-node-noted ((head) &body body) `(multiple-value-bind (res dev ino mode) (unix-xstat ,head) - (when (and res (eql (logand mode unix:s-ifmt) unix:s-ifdir)) - (let ((nodes (cons (cons dev ino) nodes))) - ,@body)))) + ;; Even if the directory does not exist, we want to + ;; continue recursing. + (let ((nodes (if (and res (eql (logand mode unix:s-ifmt) + unix:s-ifdir)) + (cons (cons dev ino) nodes) + nodes))) + ,@body))) (do-directory-entries ((name directory) &body body) `(let ((dir (unix:open-dir ,directory))) (when dir diff --git a/src/general-info/release-20f.txt b/src/general-info/release-20f.txt index 4fd57e3..2cdc460 100644 --- a/src/general-info/release-20f.txt +++ b/src/general-info/release-20f.txt @@ -127,6 +127,8 @@ New in this release: doubles. As a side-effect of this fix, DECODE-FLOAT returns the correct values for denormals, and SCALE-FLOAT scales denormals correctly. + * EXT:UNIX-NAMESTRING no longer returns NIL if a directory does + not exist. This was a regression from at least 18a. * Trac Tickets: * Ticket #90 fixed. diff --git a/tests/filesys.lisp b/tests/filesys.lisp new file mode 100644 index 0000000..a3d99e8 --- /dev/null +++ b/tests/filesys.lisp @@ -0,0 +1,60 @@ +;;; Tests for the functions in filesys.lisp. + +(defpackage :filesys-tests + (:use :cl :lisp-unit)) + +(in-package "FILESYS-TESTS") + +;; These tests for unix-namestring come from the cmucl-help mailing +;; list, Sep 26, 2014 by Jared C. Davis + +(define-test unix-namestring.1.exists + ;; Make sure the desired directories exist. + (assert-equal #P"/tmp/foo/bar/hello.txt" + (ensure-directories-exist "/tmp/foo/bar/hello.txt")) + (dolist (path '("/tmp/hello.txt" + "/tmp/foo/" + "/tmp/foo/hello.txt" + "/tmp/foo/bar/hello.txt" + "/tmp/foo/bar/bye.txt" + "/tmp/foo/bar/" + "/tmp/foo/bar/baz" + "/tmp/foo/bye.txt" + "/tmp/bye.txt")) + (assert-equal path + (ext:unix-namestring path nil) + path))) + +(define-test unix-namestring.1.non-existent + ;; Make sure the desired directories exist. + (assert-equal #P"/tmp/foo/bar/hello.txt" + (ensure-directories-exist "/tmp/foo/bar/hello.txt")) + ;; These paths contain directories that don't exist. + (dolist (path '("/tmp/oops/" + "/tmp/oops/hello.txt" + "/tmp/foo/oops/hello.txt" + "/tmp/foo/bar/oops/hello.txt" + "/tmp/foo/oops/" + )) + (assert-equal path + (ext:unix-namestring path nil) + path))) + +(define-test unix-namestring.2 + ;; Make sure the desired directories exist. + (assert-equal #P"/tmp/foo/bar/hello.txt" + (ensure-directories-exist "/tmp/foo/bar/hello.txt")) + (unwind-protect + (progn + ;; Create a symlink loop + ;; ln -s /tmp/foo/bar/symlink /tmp/foo/ + (unix:unix-unlink "/tmp/foo/bar/symlink") + (assert-equal t + (unix:unix-symlink "/tmp/foo/" "/tmp/foo/bar/symlink")) + (assert-equal "/tmp/foo/bar/symlink" + (ext:unix-namestring "/tmp/foo/bar/symlink" nil))) + (unix:unix-unlink "/tmp/foo/bar/symlink"))) + + + + ----------------------------------------------------------------------- Summary of changes: src/code/filesys.lisp | 10 +++++-- src/general-info/release-20f.txt | 2 ++ tests/filesys.lisp | 60 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 69 insertions(+), 3 deletions(-) create mode 100644 tests/filesys.lisp hooks/post-receive -- CMU Common Lisp

1 0

[Cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2014-09-28-g2f31675
by Raymond Toy 02 Oct '14

02 Oct '14

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 2f316750cc7f9ed3b49349c2ca858a8d31e1ceb9 (commit) from 19ac8cdc20d4124a6ef32578007e1183dc741305 (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 2f316750cc7f9ed3b49349c2ca858a8d31e1ceb9 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Oct 1 20:29:32 2014 -0700 Fix regression in %ENUMERATE-DIRECTORIES. Previously (18a at least), %ENUMERATE-DIRECTORIES would return a path even if a directory element did not exist. This behavior is restored. See email from cmucl-help, Sep 26, 2014. * src/code/filesys.lisp: * Fix regression.in %ENUMERATE-DIRECTORIES. Even if the directory does not exist, we continue recursing instead of stopping. * src/general-info/release-20f.txt: * Update * tests/filesys.lisp: * New file adding tests for UNIX-NAMESTRING. diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 9d224df..ee844e3 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -710,9 +710,13 @@ (with-directory-node-noted ((head) &body body) `(multiple-value-bind (res dev ino mode) (unix-xstat ,head) - (when (and res (eql (logand mode unix:s-ifmt) unix:s-ifdir)) - (let ((nodes (cons (cons dev ino) nodes))) - ,@body)))) + ;; Even if the directory does not exist, we want to + ;; continue recursing. + (let ((nodes (if (and res (eql (logand mode unix:s-ifmt) + unix:s-ifdir)) + (cons (cons dev ino) nodes) + nodes))) + ,@body))) (do-directory-entries ((name directory) &body body) `(let ((dir (unix:open-dir ,directory))) (when dir diff --git a/src/general-info/release-20f.txt b/src/general-info/release-20f.txt index 4fd57e3..2cdc460 100644 --- a/src/general-info/release-20f.txt +++ b/src/general-info/release-20f.txt @@ -127,6 +127,8 @@ New in this release: doubles. As a side-effect of this fix, DECODE-FLOAT returns the correct values for denormals, and SCALE-FLOAT scales denormals correctly. + * EXT:UNIX-NAMESTRING no longer returns NIL if a directory does + not exist. This was a regression from at least 18a. * Trac Tickets: * Ticket #90 fixed. diff --git a/tests/filesys.lisp b/tests/filesys.lisp new file mode 100644 index 0000000..a3d99e8 --- /dev/null +++ b/tests/filesys.lisp @@ -0,0 +1,60 @@ +;;; Tests for the functions in filesys.lisp. + +(defpackage :filesys-tests + (:use :cl :lisp-unit)) + +(in-package "FILESYS-TESTS") + +;; These tests for unix-namestring come from the cmucl-help mailing +;; list, Sep 26, 2014 by Jared C. Davis + +(define-test unix-namestring.1.exists + ;; Make sure the desired directories exist. + (assert-equal #P"/tmp/foo/bar/hello.txt" + (ensure-directories-exist "/tmp/foo/bar/hello.txt")) + (dolist (path '("/tmp/hello.txt" + "/tmp/foo/" + "/tmp/foo/hello.txt" + "/tmp/foo/bar/hello.txt" + "/tmp/foo/bar/bye.txt" + "/tmp/foo/bar/" + "/tmp/foo/bar/baz" + "/tmp/foo/bye.txt" + "/tmp/bye.txt")) + (assert-equal path + (ext:unix-namestring path nil) + path))) + +(define-test unix-namestring.1.non-existent + ;; Make sure the desired directories exist. + (assert-equal #P"/tmp/foo/bar/hello.txt" + (ensure-directories-exist "/tmp/foo/bar/hello.txt")) + ;; These paths contain directories that don't exist. + (dolist (path '("/tmp/oops/" + "/tmp/oops/hello.txt" + "/tmp/foo/oops/hello.txt" + "/tmp/foo/bar/oops/hello.txt" + "/tmp/foo/oops/" + )) + (assert-equal path + (ext:unix-namestring path nil) + path))) + +(define-test unix-namestring.2 + ;; Make sure the desired directories exist. + (assert-equal #P"/tmp/foo/bar/hello.txt" + (ensure-directories-exist "/tmp/foo/bar/hello.txt")) + (unwind-protect + (progn + ;; Create a symlink loop + ;; ln -s /tmp/foo/bar/symlink /tmp/foo/ + (unix:unix-unlink "/tmp/foo/bar/symlink") + (assert-equal t + (unix:unix-symlink "/tmp/foo/" "/tmp/foo/bar/symlink")) + (assert-equal "/tmp/foo/bar/symlink" + (ext:unix-namestring "/tmp/foo/bar/symlink" nil))) + (unix:unix-unlink "/tmp/foo/bar/symlink"))) + + + + ----------------------------------------------------------------------- Summary of changes: src/code/filesys.lisp | 10 +++++-- src/general-info/release-20f.txt | 2 ++ tests/filesys.lisp | 60 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 69 insertions(+), 3 deletions(-) create mode 100644 tests/filesys.lisp hooks/post-receive -- CMU Common Lisp

1 0

[Cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2014-09-27-g19ac8cd
by Raymond Toy 01 Oct '14

01 Oct '14

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 19ac8cdc20d4124a6ef32578007e1183dc741305 (commit) from 6f1c1c59b5e719143012ac7b217458953f2a0bed (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 19ac8cdc20d4124a6ef32578007e1183dc741305 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Sep 30 21:30:11 2014 -0700 Move fdlibm tests from trig.lisp to fdlibm.lisp. diff --git a/tests/fdlibm.lisp b/tests/fdlibm.lisp new file mode 100644 index 0000000..98657ef --- /dev/null +++ b/tests/fdlibm.lisp @@ -0,0 +1,268 @@ +;; Test that fdlibm routines signals exceptions as expected. + +(defpackage :fdlibm-tests + (:use :cl :lisp-unit)) + +(in-package "FDLIBM-TESTS") + +(defparameter *qnan* + (kernel::with-float-traps-masked (:invalid) + (* 0 ext:double-float-positive-infinity)) + "Some randon quiet MaN value") + +(defparameter *snan* + (kernel:make-double-float #x7ff00000 1) + "A randon signaling MaN value") + +(define-test %cosh.exceptions + (:tag :fdlibm) + (assert-error 'floating-point-overflow + (kernel:%cosh 1000d0)) + (assert-error 'floating-point-overflow + (kernel:%cosh -1000d0)) + (assert-error 'floating-point-invalid-operation + (kernel:%cosh *snan*)) + (assert-true (ext:float-nan-p (kernel:%cosh *qnan*))) + + ;; Same, but with overflow's masked + (kernel::with-float-traps-masked (:overflow) + (assert-equal ext:double-float-positive-infinity + (kernel:%cosh 1000d0)) + (assert-equal ext:double-float-positive-infinity + (kernel:%cosh -1000d0)) + (assert-equal ext:double-float-positive-infinity + (kernel:%cosh ext:double-float-positive-infinity)) + (assert-equal ext:double-float-positive-infinity + (kernel:%cosh ext:double-float-negative-infinity))) + ;; Test NaN + (kernel::with-float-traps-masked (:invalid) + (assert-true (ext:float-nan-p (kernel:%cosh *snan*))))) + +(define-test %sinh.exceptions + (:tag :fdlibm) + (assert-error 'floating-point-overflow + (kernel:%sinh 1000d0)) + (assert-error 'floating-point-overflow + (kernel:%sinh -1000d0)) + (assert-error 'floating-point-invalid-operation + (kernel:%sinh *snan*)) + (assert-true (ext:float-nan-p (kernel:%sinh *qnan*))) + ;; Same, but with overflow's masked + (kernel::with-float-traps-masked (:overflow) + (assert-equal ext:double-float-positive-infinity + (kernel:%sinh 1000d0)) + (assert-equal ext:double-float-negative-infinity + (kernel:%sinh -1000d0)) + (assert-equal ext:double-float-positive-infinity + (kernel:%sinh ext:double-float-positive-infinity)) + (assert-equal ext:double-float-negative-infinity + (kernel:%sinh ext:double-float-negative-infinity))) + ;; Test NaN + (kernel::with-float-traps-masked (:invalid) + (assert-true (ext:float-nan-p (kernel:%sinh *qnan*))))) + + +(define-test %tanh.exceptions + (:tag :fdlibm) + (assert-true (ext:float-nan-p (kernel:%tanh *qnan*))) + (assert-error 'floating-point-invalid-operation + (kernel:%tanh *snan*)) + (kernel::with-float-traps-masked (:invalid) + (assert-true (ext:float-nan-p (kernel:%tanh *snan*))))) + +(define-test %acosh.exceptions + (:tag :fdlibm) + (assert-error 'floating-point-overflow + (kernel:%acosh ext:double-float-positive-infinity)) + (assert-error 'floating-point-invalid-operation + (kernel:%acosh 0d0)) + (kernel::with-float-traps-masked (:overflow) + (assert-equal ext:double-float-positive-infinity + (kernel:%acosh ext:double-float-positive-infinity))) + (kernel::with-float-traps-masked (:invalid) + (assert-true (ext:float-nan-p (kernel:%acosh 0d0))))) + +(define-test %asinh.exceptions + (:tag :fdlibm) + (assert-error 'floating-point-invalid-operation + (kernel:%asinh *snan*)) + (assert-error 'floating-point-overflow + (kernel:%asinh ext:double-float-positive-infinity)) + (assert-error 'floating-point-overflow + (kernel:%asinh ext:double-float-negative-infinity)) + (assert-true (ext:float-nan-p (kernel:%asinh *qnan*))) + (kernel::with-float-traps-masked (:overflow) + (assert-equal ext:double-float-positive-infinity + (kernel:%asinh ext:double-float-positive-infinity)) + (assert-error ext:double-float-negative-infinity + (kernel:%asinh ext:double-float-negative-infinity))) + (kernel::with-float-traps-masked (:invalid) + (assert-true (ext:float-nan-p (kernel:%asinh *snan*))))) + +(define-test %atanh.exceptions + (:tag :fdlibm) + (assert-error 'floating-point-invalid-operation + (kernel:%atanh 2d0)) + (assert-error 'floating-point-invalid-operation + (kernel:%atanh -2d0)) + (assert-error 'division-by-zero + (kernel:%atanh 1d0)) + (assert-error 'division-by-zero + (kernel:%atanh -1d0)) + (kernel::with-float-traps-masked (:invalid) + (assert-true (ext:float-nan-p (kernel:%atanh 2d0))) + (assert-true (ext:float-nan-p (kernel:%atanh -2d0)))) + (kernel::with-float-traps-masked (:divide-by-zero) + (assert-equal ext:double-float-positive-infinity + (kernel:%atanh 1d0)) + (assert-equal ext:double-float-negative-infinity + (kernel:%atanh -1d0)))) + +(define-test %expm1.exceptions + (:tag :fdlibm) + (assert-error 'floating-point-overflow + (kernel:%expm1 709.8d0)) + (assert-equal ext:double-float-positive-infinity + (kernel:%expm1 ext:double-float-positive-infinity)) + (assert-error 'floating-point-invalid-operation + (kernel:%expm1 *snan*)) + (assert-true (ext:float-nan-p (kernel:%expm1 *qnan*))) + (kernel::with-float-traps-masked (:overflow) + (assert-equal ext:double-float-positive-infinity + (kernel:%expm1 709.8d0)) + ) + (kernel::with-float-traps-masked (:invalid) + (assert-true (ext::float-nan-p (kernel:%expm1 *snan*))))) + +(define-test %log1p.exceptions + (:tag :fdlibm) + (assert-error 'floating-point-invalid-operation + (kernel:%log1p -2d0)) + (assert-error 'floating-point-overflow + (kernel:%log1p -1d0)) + (assert-true (ext:float-nan-p (kernel:%log1p *qnan*))) + (kernel::with-float-traps-masked (:overflow) + (assert-equal ext:double-float-negative-infinity + (kernel:%log1p -1d0))) + (kernel::with-float-traps-masked (:invalid) + (assert-true (ext:float-nan-p (kernel:%log1p *snan*))))) + +(define-test %exp.exceptions + (:tag :fdlibm) + (assert-error 'floating-point-overflow + (kernel:%exp 710d0)) + (assert-true (ext:float-nan-p (kernel:%exp *qnan*))) + (assert-error 'floating-point-invalid-operation + (kernel:%exp *snan*)) + (assert-equal ext:double-float-positive-infinity + (kernel:%exp ext:double-float-positive-infinity)) + (assert-equal 0d0 + (kernel:%exp -1000d0)) + (kernel::with-float-traps-masked (:overflow) + (assert-equal ext:double-float-positive-infinity + (kernel:%exp 710d0))) + (let ((modes (ext:get-floating-point-modes))) + (unwind-protect + (progn + (ext:set-floating-point-modes :traps '(:underflow)) + (assert-error 'floating-point-underflow + (kernel:%exp -1000d0))) + (apply #'ext:set-floating-point-modes modes)))) + +(define-test %log.exception + (:tag :fdlibm) + (assert-error 'division-by-zero + (kernel:%log 0d0)) + (assert-error 'division-by-zero + (kernel:%log -0d0)) + (assert-error 'floating-point-invalid-operation + (kernel:%log -1d0)) + (assert-error 'floating-point-invalid-operation + (kernel:%log *snan*)) + (assert-true (ext:float-nan-p (kernel:%log *qnan*))) + (kernel::with-float-traps-masked (:divide-by-zero) + (assert-equal ext:double-float-negative-infinity + (kernel:%log 0d0)) + (assert-equal ext:double-float-negative-infinity + (kernel:%log -0d0))) + (kernel::with-float-traps-masked (:invalid) + (assert-true (ext:float-nan-p (kernel:%log -1d0))) + (assert-true (ext:float-nan-p (kernel:%log *snan*))))) + +(define-test %acos.exceptions + (:tag :fdlibm) + (assert-error 'floating-point-invalid-operation + (kernel:%acos 2d0)) + (assert-error 'floating-point-invalid-operation + (kernel:%acos -2d0)) + (kernel::with-float-traps-masked (:invalid) + (assert-true (ext:float-nan-p (kernel:%acos 2d0))) + (assert-true (ext:float-nan-p (kernel:%acos -2d0))))) + +(define-test %asin.exceptions + (:tag :fdlibm) + (assert-error 'floating-point-invalid-operation + (kernel:%asin 2d0)) + (assert-error 'floating-point-invalid-operation + (kernel:%asin -2d0)) + (kernel::with-float-traps-masked (:invalid) + (assert-true (ext:float-nan-p (kernel:%asin 2d0))) + (assert-true (ext:float-nan-p (kernel:%asin -2d0))))) + +(define-test %atan.exceptions + (:tag :fdlibm) + (assert-error 'floating-point-invalid-operation + (kernel:%atan *snan*)) + (assert-true (ext:float-nan-p (kernel:%atan *qnan*))) + (kernel::with-float-traps-masked (:invalid) + (assert-true (ext:float-nan-p (kernel:%atan *snan*))))) + +(define-test %log10.exceptions + (:tag :fdlibm) + ;; %log10(2^k) = k + (dotimes (k 23) + (assert-equalp k + (kernel:%log10 (float (expt 10 k) 1d0)))) + (assert-error 'division-by-zero + (kernel:%log10 0d0)) + (assert-error 'floating-point-invalid-operation + (kernel:%log10 -1d0)) + (assert-true (ext:float-nan-p (kernel:%log10 *qnan*))) + (assert-equal ext:double-float-positive-infinity + (kernel:%log10 ext:double-float-positive-infinity)) + (kernel::with-float-traps-masked (:divide-by-zero) + (assert-equal ext:double-float-negative-infinity + (kernel:%log10 0d0)) + (assert-equal ext:double-float-negative-infinity + (kernel:%log10 -0d0))) + (kernel::with-float-traps-masked (:invalid) + (assert-true (ext:float-nan-p (kernel:%log10 -1d0))))) + +(define-test %scalbn.exceptions + (:tag :fdlibm) + (let ((modes (ext:get-floating-point-modes))) + (unwind-protect + (progn + (ext:set-floating-point-modes :traps '(:underflow)) + (assert-error 'floating-point-underflow + (kernel:%scalbn 1d0 -51000))) + (apply #'ext:set-floating-point-modes modes))) + (assert-true 0d0 + (kernel:%scalbn 1d0 -51000)) + (assert-true -0d0 + (kernel:%scalbn -1d0 -51000)) + (assert-error 'floating-point-overflow + (kernel:%scalbn ext:double-float-positive-infinity 1)) + (assert-error 'floating-point-invalid-operation + (kernel:%scalbn *snan* 1)) + (assert-error 'floating-point-overflow + (kernel:%scalbn most-positive-double-float 2)) + (assert-error 'floating-point-overflow + (kernel:%scalbn most-negative-double-float 2)) + (kernel::with-float-traps-masked (:overflow) + (assert-equal ext:double-float-positive-infinity + (kernel:%scalbn ext:double-float-positive-infinity 1)) + (assert-equal ext:double-float-positive-infinity + (kernel:%scalbn most-positive-double-float 2)) + (assert-equal ext:double-float-negative-infinity + (kernel:%scalbn most-negative-double-float 2)))) diff --git a/tests/trig.lisp b/tests/trig.lisp index 86fdb39..84fc74c 100644 --- a/tests/trig.lisp +++ b/tests/trig.lisp @@ -792,267 +792,3 @@ (get-signs (atanh-def #c(2d0 +1d-20))) (assert-true (check-signs #'atanh #c(2d0 0d0) tr ti)) (assert-true (check-signs #'atanh #c(2w0 0w0) tr ti)))) - -;; Test that fdlibm routines signals exceptions as expected. - -(defparameter *qnan* - (kernel::with-float-traps-masked (:invalid) - (* 0 ext:double-float-positive-infinity)) - "Some randon quiet MaN value") - -(defparameter *snan* - (kernel:make-double-float #x7ff00000 1) - "A randon signaling MaN value") - -(define-test %cosh.exceptions - (:tag :fdlibm) - (assert-error 'floating-point-overflow - (kernel:%cosh 1000d0)) - (assert-error 'floating-point-overflow - (kernel:%cosh -1000d0)) - (assert-error 'floating-point-invalid-operation - (kernel:%cosh *snan*)) - (assert-true (ext:float-nan-p (kernel:%cosh *qnan*))) - - ;; Same, but with overflow's masked - (kernel::with-float-traps-masked (:overflow) - (assert-equal ext:double-float-positive-infinity - (kernel:%cosh 1000d0)) - (assert-equal ext:double-float-positive-infinity - (kernel:%cosh -1000d0)) - (assert-equal ext:double-float-positive-infinity - (kernel:%cosh ext:double-float-positive-infinity)) - (assert-equal ext:double-float-positive-infinity - (kernel:%cosh ext:double-float-negative-infinity))) - ;; Test NaN - (kernel::with-float-traps-masked (:invalid) - (assert-true (ext:float-nan-p (kernel:%cosh *snan*))))) - -(define-test %sinh.exceptions - (:tag :fdlibm) - (assert-error 'floating-point-overflow - (kernel:%sinh 1000d0)) - (assert-error 'floating-point-overflow - (kernel:%sinh -1000d0)) - (assert-error 'floating-point-invalid-operation - (kernel:%sinh *snan*)) - (assert-true (ext:float-nan-p (kernel:%sinh *qnan*))) - ;; Same, but with overflow's masked - (kernel::with-float-traps-masked (:overflow) - (assert-equal ext:double-float-positive-infinity - (kernel:%sinh 1000d0)) - (assert-equal ext:double-float-negative-infinity - (kernel:%sinh -1000d0)) - (assert-equal ext:double-float-positive-infinity - (kernel:%sinh ext:double-float-positive-infinity)) - (assert-equal ext:double-float-negative-infinity - (kernel:%sinh ext:double-float-negative-infinity))) - ;; Test NaN - (kernel::with-float-traps-masked (:invalid) - (assert-true (ext:float-nan-p (kernel:%sinh *qnan*))))) - - -(define-test %tanh.exceptions - (:tag :fdlibm) - (assert-true (ext:float-nan-p (kernel:%tanh *qnan*))) - (assert-error 'floating-point-invalid-operation - (kernel:%tanh *snan*)) - (kernel::with-float-traps-masked (:invalid) - (assert-true (ext:float-nan-p (kernel:%tanh *snan*))))) - -(define-test %acosh.exceptions - (:tag :fdlibm) - (assert-error 'floating-point-overflow - (kernel:%acosh ext:double-float-positive-infinity)) - (assert-error 'floating-point-invalid-operation - (kernel:%acosh 0d0)) - (kernel::with-float-traps-masked (:overflow) - (assert-equal ext:double-float-positive-infinity - (kernel:%acosh ext:double-float-positive-infinity))) - (kernel::with-float-traps-masked (:invalid) - (assert-true (ext:float-nan-p (kernel:%acosh 0d0))))) - -(define-test %asinh.exceptions - (:tag :fdlibm) - (assert-error 'floating-point-invalid-operation - (kernel:%asinh *snan*)) - (assert-error 'floating-point-overflow - (kernel:%asinh ext:double-float-positive-infinity)) - (assert-error 'floating-point-overflow - (kernel:%asinh ext:double-float-negative-infinity)) - (assert-true (ext:float-nan-p (kernel:%asinh *qnan*))) - (kernel::with-float-traps-masked (:overflow) - (assert-equal ext:double-float-positive-infinity - (kernel:%asinh ext:double-float-positive-infinity)) - (assert-error ext:double-float-negative-infinity - (kernel:%asinh ext:double-float-negative-infinity))) - (kernel::with-float-traps-masked (:invalid) - (assert-true (ext:float-nan-p (kernel:%asinh *snan*))))) - -(define-test %atanh.exceptions - (:tag :fdlibm) - (assert-error 'floating-point-invalid-operation - (kernel:%atanh 2d0)) - (assert-error 'floating-point-invalid-operation - (kernel:%atanh -2d0)) - (assert-error 'division-by-zero - (kernel:%atanh 1d0)) - (assert-error 'division-by-zero - (kernel:%atanh -1d0)) - (kernel::with-float-traps-masked (:invalid) - (assert-true (ext:float-nan-p (kernel:%atanh 2d0))) - (assert-true (ext:float-nan-p (kernel:%atanh -2d0)))) - (kernel::with-float-traps-masked (:divide-by-zero) - (assert-equal ext:double-float-positive-infinity - (kernel:%atanh 1d0)) - (assert-equal ext:double-float-negative-infinity - (kernel:%atanh -1d0)))) - -(define-test %expm1.exceptions - (:tag :fdlibm) - (assert-error 'floating-point-overflow - (kernel:%expm1 709.8d0)) - (assert-equal ext:double-float-positive-infinity - (kernel:%expm1 ext:double-float-positive-infinity)) - (assert-error 'floating-point-invalid-operation - (kernel:%expm1 *snan*)) - (assert-true (ext:float-nan-p (kernel:%expm1 *qnan*))) - (kernel::with-float-traps-masked (:overflow) - (assert-equal ext:double-float-positive-infinity - (kernel:%expm1 709.8d0)) - ) - (kernel::with-float-traps-masked (:invalid) - (assert-true (ext::float-nan-p (kernel:%expm1 *snan*))))) - -(define-test %log1p.exceptions - (:tag :fdlibm) - (assert-error 'floating-point-invalid-operation - (kernel:%log1p -2d0)) - (assert-error 'floating-point-overflow - (kernel:%log1p -1d0)) - (assert-true (ext:float-nan-p (kernel:%log1p *qnan*))) - (kernel::with-float-traps-masked (:overflow) - (assert-equal ext:double-float-negative-infinity - (kernel:%log1p -1d0))) - (kernel::with-float-traps-masked (:invalid) - (assert-true (ext:float-nan-p (kernel:%log1p *snan*))))) - -(define-test %exp.exceptions - (:tag :fdlibm) - (assert-error 'floating-point-overflow - (kernel:%exp 710d0)) - (assert-true (ext:float-nan-p (kernel:%exp *qnan*))) - (assert-error 'floating-point-invalid-operation - (kernel:%exp *snan*)) - (assert-equal ext:double-float-positive-infinity - (kernel:%exp ext:double-float-positive-infinity)) - (assert-equal 0d0 - (kernel:%exp -1000d0)) - (kernel::with-float-traps-masked (:overflow) - (assert-equal ext:double-float-positive-infinity - (kernel:%exp 710d0))) - (let ((modes (ext:get-floating-point-modes))) - (unwind-protect - (progn - (ext:set-floating-point-modes :traps '(:underflow)) - (assert-error 'floating-point-underflow - (kernel:%exp -1000d0))) - (apply #'ext:set-floating-point-modes modes)))) - -(define-test %log.exception - (:tag :fdlibm) - (assert-error 'division-by-zero - (kernel:%log 0d0)) - (assert-error 'division-by-zero - (kernel:%log -0d0)) - (assert-error 'floating-point-invalid-operation - (kernel:%log -1d0)) - (assert-error 'floating-point-invalid-operation - (kernel:%log *snan*)) - (assert-true (ext:float-nan-p (kernel:%log *qnan*))) - (kernel::with-float-traps-masked (:divide-by-zero) - (assert-equal ext:double-float-negative-infinity - (kernel:%log 0d0)) - (assert-equal ext:double-float-negative-infinity - (kernel:%log -0d0))) - (kernel::with-float-traps-masked (:invalid) - (assert-true (ext:float-nan-p (kernel:%log -1d0))) - (assert-true (ext:float-nan-p (kernel:%log *snan*))))) - -(define-test %acos.exceptions - (:tag :fdlibm) - (assert-error 'floating-point-invalid-operation - (kernel:%acos 2d0)) - (assert-error 'floating-point-invalid-operation - (kernel:%acos -2d0)) - (kernel::with-float-traps-masked (:invalid) - (assert-true (ext:float-nan-p (kernel:%acos 2d0))) - (assert-true (ext:float-nan-p (kernel:%acos -2d0))))) - -(define-test %asin.exceptions - (:tag :fdlibm) - (assert-error 'floating-point-invalid-operation - (kernel:%asin 2d0)) - (assert-error 'floating-point-invalid-operation - (kernel:%asin -2d0)) - (kernel::with-float-traps-masked (:invalid) - (assert-true (ext:float-nan-p (kernel:%asin 2d0))) - (assert-true (ext:float-nan-p (kernel:%asin -2d0))))) - -(define-test %atan.exceptions - (:tag :fdlibm) - (assert-error 'floating-point-invalid-operation - (kernel:%atan *snan*)) - (assert-true (ext:float-nan-p (kernel:%atan *qnan*))) - (kernel::with-float-traps-masked (:invalid) - (assert-true (ext:float-nan-p (kernel:%atan *snan*))))) - -(define-test %log10.exceptions - (:tag :fdlibm) - ;; %log10(2^k) = k - (dotimes (k 23) - (assert-equalp k - (kernel:%log10 (float (expt 10 k) 1d0)))) - (assert-error 'division-by-zero - (kernel:%log10 0d0)) - (assert-error 'floating-point-invalid-operation - (kernel:%log10 -1d0)) - (assert-true (ext:float-nan-p (kernel:%log10 *qnan*))) - (assert-equal ext:double-float-positive-infinity - (kernel:%log10 ext:double-float-positive-infinity)) - (kernel::with-float-traps-masked (:divide-by-zero) - (assert-equal ext:double-float-negative-infinity - (kernel:%log10 0d0)) - (assert-equal ext:double-float-negative-infinity - (kernel:%log10 -0d0))) - (kernel::with-float-traps-masked (:invalid) - (assert-true (ext:float-nan-p (kernel:%log10 -1d0))))) - -(define-test %scalbn.exceptions - (:tag :fdlibm) - (let ((modes (ext:get-floating-point-modes))) - (unwind-protect - (progn - (ext:set-floating-point-modes :traps '(:underflow)) - (assert-error 'floating-point-underflow - (kernel:%scalbn 1d0 -51000))) - (apply #'ext:set-floating-point-modes modes))) - (assert-true 0d0 - (kernel:%scalbn 1d0 -51000)) - (assert-true -0d0 - (kernel:%scalbn -1d0 -51000)) - (assert-error 'floating-point-overflow - (kernel:%scalbn ext:double-float-positive-infinity 1)) - (assert-error 'floating-point-invalid-operation - (kernel:%scalbn *snan* 1)) - (assert-error 'floating-point-overflow - (kernel:%scalbn most-positive-double-float 2)) - (assert-error 'floating-point-overflow - (kernel:%scalbn most-negative-double-float 2)) - (kernel::with-float-traps-masked (:overflow) - (assert-equal ext:double-float-positive-infinity - (kernel:%scalbn ext:double-float-positive-infinity 1)) - (assert-equal ext:double-float-positive-infinity - (kernel:%scalbn most-positive-double-float 2)) - (assert-equal ext:double-float-negative-infinity - (kernel:%scalbn most-negative-double-float 2)))) ----------------------------------------------------------------------- Summary of changes: tests/fdlibm.lisp | 268 +++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/trig.lisp | 264 ---------------------------------------------------- 2 files changed, 268 insertions(+), 264 deletions(-) create mode 100644 tests/fdlibm.lisp hooks/post-receive -- CMU Common Lisp

1 0

[Cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2014-09-26-g6f1c1c5
by Raymond Toy 01 Oct '14

01 Oct '14

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 6f1c1c59b5e719143012ac7b217458953f2a0bed (commit) via 098f3c14711de24cfeb3ce6a74bca320fd8e2aa1 (commit) from f61fb8591ba745046f96770093330be7d12e45d2 (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 6f1c1c59b5e719143012ac7b217458953f2a0bed Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Sep 30 21:12:52 2014 -0700 Add tests for kernel:%scalbn. diff --git a/tests/trig.lisp b/tests/trig.lisp index cdebe39..86fdb39 100644 --- a/tests/trig.lisp +++ b/tests/trig.lisp @@ -1027,3 +1027,32 @@ (kernel:%log10 -0d0))) (kernel::with-float-traps-masked (:invalid) (assert-true (ext:float-nan-p (kernel:%log10 -1d0))))) + +(define-test %scalbn.exceptions + (:tag :fdlibm) + (let ((modes (ext:get-floating-point-modes))) + (unwind-protect + (progn + (ext:set-floating-point-modes :traps '(:underflow)) + (assert-error 'floating-point-underflow + (kernel:%scalbn 1d0 -51000))) + (apply #'ext:set-floating-point-modes modes))) + (assert-true 0d0 + (kernel:%scalbn 1d0 -51000)) + (assert-true -0d0 + (kernel:%scalbn -1d0 -51000)) + (assert-error 'floating-point-overflow + (kernel:%scalbn ext:double-float-positive-infinity 1)) + (assert-error 'floating-point-invalid-operation + (kernel:%scalbn *snan* 1)) + (assert-error 'floating-point-overflow + (kernel:%scalbn most-positive-double-float 2)) + (assert-error 'floating-point-overflow + (kernel:%scalbn most-negative-double-float 2)) + (kernel::with-float-traps-masked (:overflow) + (assert-equal ext:double-float-positive-infinity + (kernel:%scalbn ext:double-float-positive-infinity 1)) + (assert-equal ext:double-float-positive-infinity + (kernel:%scalbn most-positive-double-float 2)) + (assert-equal ext:double-float-negative-infinity + (kernel:%scalbn most-negative-double-float 2)))) commit 098f3c14711de24cfeb3ce6a74bca320fd8e2aa1 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Sep 30 21:12:37 2014 -0700 Add alien interface to scalbn. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index c07e979..8ddd413 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -91,6 +91,12 @@ (def-math-rtn ("fdlibm_log1p" %log1p) 1) (def-math-rtn ("fdlibm_expm1" %expm1) 1) +(declaim (inline %scalbn)) +(export '%scalbn) +(alien:def-alien-routine ("fdlibm_scalbn" %scalbn) c-call:double + (x double-float) + (n c-call:int)) + ;; These are needed for use by byte-compiled files. But don't use ;; these with sse2 since we don't support using the x87 instructions ;; here. ----------------------------------------------------------------------- Summary of changes: src/code/irrat.lisp | 6 ++++++ tests/trig.lisp | 29 +++++++++++++++++++++++++++++ 2 files changed, 35 insertions(+) hooks/post-receive -- CMU Common Lisp

1 0

[Cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2014-09-24-gf61fb85
by Raymond Toy 01 Oct '14

01 Oct '14

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 f61fb8591ba745046f96770093330be7d12e45d2 (commit) from 33adf3d4d02f8416b829569af99735a5b28c9d73 (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 f61fb8591ba745046f96770093330be7d12e45d2 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Sep 30 21:11:36 2014 -0700 Fix a couple of issues in the code. * Use fdlibm_setexception to handle the case when the arg is NaN or Inf. (Previously depended on x+x doing the right thing.) * Fix a compiler warning about possible dangling else by adding braces as needed. diff --git a/src/lisp/s_scalbn.c b/src/lisp/s_scalbn.c index 4889385..1993bbb 100644 --- a/src/lisp/s_scalbn.c +++ b/src/lisp/s_scalbn.c @@ -52,15 +52,24 @@ tiny = 1.0e-300; k = ((hx&0x7ff00000)>>20) - 54; if (n< -50000) return fdlibm_setexception(x, FDLIBM_UNDERFLOW);; /*underflow*/ } - if (k==0x7ff) return x+x; /* NaN or Inf */ + if (k==0x7ff) { + /* NaN or Inf */ + if(((hx&0xfffff)|lx)!=0) { + return fdlibm_setexception(x, FDLIBM_INVALID); + } else { + return fdlibm_setexception(x, FDLIBM_OVERFLOW); + } + } + k = k+n; if (k > 0x7fe) return fdlibm_setexception(x, FDLIBM_OVERFLOW); /* overflow */ if (k > 0) /* normal result */ {ux.i[HIWORD] = (hx&0x800fffff)|(k<<20); return x;} - if (k <= -54) + if (k <= -54) { if (n > 50000) /* in case integer overflow in n+k */ return fdlibm_setexception(x, FDLIBM_OVERFLOW); /*overflow*/ else return fdlibm_setexception(x, FDLIBM_UNDERFLOW); /*underflow*/ + } k += 54; /* subnormal result */ ux.i[HIWORD] = (hx&0x800fffff)|(k<<20); return x*twom54; ----------------------------------------------------------------------- Summary of changes: src/lisp/s_scalbn.c | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[Cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2014-09-23-g33adf3d
by Raymond Toy 28 Sep '14

28 Sep '14

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 33adf3d4d02f8416b829569af99735a5b28c9d73 (commit) from 95551b41407093f6bdb89e50967c9d3203b273b9 (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 33adf3d4d02f8416b829569af99735a5b28c9d73 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Sep 28 15:03:53 2014 -0700 Compile in scalbn. diff --git a/src/lisp/GNUmakefile b/src/lisp/GNUmakefile index d0d6104..d8fb690 100644 --- a/src/lisp/GNUmakefile +++ b/src/lisp/GNUmakefile @@ -12,7 +12,7 @@ FDLIBM = k_sin.c k_cos.c k_tan.c s_sin.c s_cos.c s_tan.c sincos.c \ e_acosh.c s_asinh.c e_atanh.c \ e_atan2.c \ e_rem_pio2.c k_rem_pio2.c \ - e_log10.c \ + e_log10.c s_scalbn.c \ setexception.c SRCS = lisp.c coreparse.c alloc.c monitor.c print.c interr.c \ ----------------------------------------------------------------------- Summary of changes: src/lisp/GNUmakefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) hooks/post-receive -- CMU Common Lisp

1 0

[Cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2014-09-22-g95551b4
by Raymond Toy 28 Sep '14

28 Sep '14

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 95551b41407093f6bdb89e50967c9d3203b273b9 (commit) from e82e6d3ba6e9e22735d5822d95836fe0b4838d04 (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 95551b41407093f6bdb89e50967c9d3203b273b9 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Sep 28 14:44:09 2014 -0700 Rename scalbn to fdlibm_scalbn, and use a union. diff --git a/src/lisp/s_scalbn.c b/src/lisp/s_scalbn.c index 329be8b..4889385 100644 --- a/src/lisp/s_scalbn.c +++ b/src/lisp/s_scalbn.c @@ -31,33 +31,37 @@ huge = 1.0e+300, tiny = 1.0e-300; #ifdef __STDC__ - double scalbn (double x, int n) + double fdlibm_scalbn (double x, int n) #else - double scalbn (x,n) + double fdlibm_scalbn (x,n) double x; int n; #endif { int k,hx,lx; - hx = __HI(x); - lx = __LO(x); + union { int i[2]; double d; } ux; + + ux.d = x; + hx = ux.i[HIWORD]; + lx = ux.i[LOWORD]; k = (hx&0x7ff00000)>>20; /* extract exponent */ if (k==0) { /* 0 or subnormal x */ if ((lx|(hx&0x7fffffff))==0) return x; /* +-0 */ - x *= two54; - hx = __HI(x); + x *= two54; + ux.d = x; + hx = ux.i[HIWORD]; k = ((hx&0x7ff00000)>>20) - 54; - if (n< -50000) return tiny*x; /*underflow*/ + if (n< -50000) return fdlibm_setexception(x, FDLIBM_UNDERFLOW);; /*underflow*/ } if (k==0x7ff) return x+x; /* NaN or Inf */ k = k+n; - if (k > 0x7fe) return huge*copysign(huge,x); /* overflow */ + if (k > 0x7fe) return fdlibm_setexception(x, FDLIBM_OVERFLOW); /* overflow */ if (k > 0) /* normal result */ - {__HI(x) = (hx&0x800fffff)|(k<<20); return x;} + {ux.i[HIWORD] = (hx&0x800fffff)|(k<<20); return x;} if (k <= -54) if (n > 50000) /* in case integer overflow in n+k */ - return huge*copysign(huge,x); /*overflow*/ - else return tiny*copysign(tiny,x); /*underflow*/ + return fdlibm_setexception(x, FDLIBM_OVERFLOW); /*overflow*/ + else return fdlibm_setexception(x, FDLIBM_UNDERFLOW); /*underflow*/ k += 54; /* subnormal result */ - __HI(x) = (hx&0x800fffff)|(k<<20); + ux.i[HIWORD] = (hx&0x800fffff)|(k<<20); return x*twom54; } ----------------------------------------------------------------------- Summary of changes: src/lisp/s_scalbn.c | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[Cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2014-09-21-ge82e6d3
by Raymond Toy 28 Sep '14

28 Sep '14

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 e82e6d3ba6e9e22735d5822d95836fe0b4838d04 (commit) from 3c677fd9362246effb35724d499e70effdf6dfed (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 e82e6d3ba6e9e22735d5822d95836fe0b4838d04 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Sep 28 14:28:46 2014 -0700 Import scalbn directly from fdlibm. Since the x86 port calls this already, might as well make it available to everyone. diff --git a/src/lisp/s_scalbn.c b/src/lisp/s_scalbn.c new file mode 100644 index 0000000..329be8b --- /dev/null +++ b/src/lisp/s_scalbn.c @@ -0,0 +1,63 @@ + +/* @(#)s_scalbn.c 1.3 95/01/18 */ +/* + * ==================================================== + * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. + * + * Developed at SunSoft, a Sun Microsystems, Inc. business. + * Permission to use, copy, modify, and distribute this + * software is freely granted, provided that this notice + * is preserved. + * ==================================================== + */ + +/* + * scalbn (double x, int n) + * scalbn(x,n) returns x* 2**n computed by exponent + * manipulation rather than by actually performing an + * exponentiation or a multiplication. + */ + +#include "fdlibm.h" + +#ifdef __STDC__ +static const double +#else +static double +#endif +two54 = 1.80143985094819840000e+16, /* 0x43500000, 0x00000000 */ +twom54 = 5.55111512312578270212e-17, /* 0x3C900000, 0x00000000 */ +huge = 1.0e+300, +tiny = 1.0e-300; + +#ifdef __STDC__ + double scalbn (double x, int n) +#else + double scalbn (x,n) + double x; int n; +#endif +{ + int k,hx,lx; + hx = __HI(x); + lx = __LO(x); + k = (hx&0x7ff00000)>>20; /* extract exponent */ + if (k==0) { /* 0 or subnormal x */ + if ((lx|(hx&0x7fffffff))==0) return x; /* +-0 */ + x *= two54; + hx = __HI(x); + k = ((hx&0x7ff00000)>>20) - 54; + if (n< -50000) return tiny*x; /*underflow*/ + } + if (k==0x7ff) return x+x; /* NaN or Inf */ + k = k+n; + if (k > 0x7fe) return huge*copysign(huge,x); /* overflow */ + if (k > 0) /* normal result */ + {__HI(x) = (hx&0x800fffff)|(k<<20); return x;} + if (k <= -54) + if (n > 50000) /* in case integer overflow in n+k */ + return huge*copysign(huge,x); /*overflow*/ + else return tiny*copysign(tiny,x); /*underflow*/ + k += 54; /* subnormal result */ + __HI(x) = (hx&0x800fffff)|(k<<20); + return x*twom54; +} ----------------------------------------------------------------------- Summary of changes: src/lisp/s_scalbn.c | 63 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 63 insertions(+) create mode 100644 src/lisp/s_scalbn.c hooks/post-receive -- CMU Common Lisp

1 0

[Cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2014-09-20-g3c677fd
by Raymond Toy 28 Sep '14

28 Sep '14

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 3c677fd9362246effb35724d499e70effdf6dfed (commit) from 315ea23408772763fc0f141d51bf5038269f0b7c (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 3c677fd9362246effb35724d499e70effdf6dfed Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Sep 28 14:16:38 2014 -0700 Correct a comment for %ieee754-rem-pi/2. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index daf6166..c07e979 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -183,10 +183,10 @@ (%sqrt x)) ) -;; Same as above, but instead of needing to pass an array in, the -;; output array is broken up into two output values instead. This is -;; easier for the user, and we don't have to wrap calls with -;; without-gcing. +;; Slightly simplified interface to __ieee754_rem_pio2, but instead of +;; needing to pass an array in, the output array is broken up into two +;; output values instead. This is easier for the user, and we don't +;; have to wrap calls with without-gcing. (declaim (inline %ieee754-rem-pi/2)) (export '%ieee754-rem-pi/2) (alien:def-alien-routine ("ieee754_rem_pio2" %ieee754-rem-pi/2) c-call:int ----------------------------------------------------------------------- Summary of changes: src/code/irrat.lisp | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[Cmucl-cvs] [git] CMU Common Lisp branch 20f-branch updated. snapshot-2014-09-12-gab0a979
by Raymond Toy 27 Sep '14

27 Sep '14

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, 20f-branch has been updated via ab0a979db83310c64fcbbc13b178d5c31af9f5c9 (commit) from 878f7c4337d04265d067a90d29acca0d868cd35d (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 ab0a979db83310c64fcbbc13b178d5c31af9f5c9 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Sep 26 20:20:54 2014 -0700 Fix incorrect value from INTEGER-DECODE-FLOAT for denormals. This is a long standing bug where INTEGER-DECODE-FLOAT returned incorrect values for denormal double-float numbers. The lower 32 bits of the double were not shifted enough when creating the integer result. As a side-effect, DECODE-FLOAT decodes denormal double-float's correctly and SCALE-FLOAT scales denormals correctly too. * src/code/float.lisp: * Shift the lower 32-bit of the fraction one more time to adjust for the fact that the upper 20 bits were shifted an extra time. * tests/float.lisp: * Add several tests for INTEGER-DECODE-FLOAT, SCALE-FLOAT, and DECODE-FLOAT. * src/general-info/release-20f.txt: * Add this bug fix to the notes. Conflicts: tests/float.lisp diff --git a/src/code/float.lisp b/src/code/float.lisp index cace1a4..3ac6512 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -581,7 +581,7 @@ (return)) (setq sig (ash sig 1)) (incf extra-bias)) - (values (logior (ash sig 32) (ash low-bits (1- extra-bias))) + (values (logior (ash sig 32) (ash low-bits (1+ extra-bias))) (truly-the fixnum (- biased extra-bias)) sign))))) diff --git a/src/general-info/release-20f.txt b/src/general-info/release-20f.txt index 0327f5b..4fd57e3 100644 --- a/src/general-info/release-20f.txt +++ b/src/general-info/release-20f.txt @@ -123,6 +123,10 @@ New in this release: * For linux, motifd is no longer a 64-bit app. * (exp 1d0) now returns the correctly rounded value of e. Previously, it was off by one bit. + * INTEGER-DECODE-FLOAT returns the correct values for denormal + doubles. As a side-effect of this fix, DECODE-FLOAT returns the + correct values for denormals, and SCALE-FLOAT scales denormals + correctly. * Trac Tickets: * Ticket #90 fixed. diff --git a/tests/float.lisp b/tests/float.lisp index 6fe1f50..454ab99 100644 --- a/tests/float.lisp +++ b/tests/float.lisp @@ -10,3 +10,77 @@ (declare (type (double-float (0d0)) x)) (decode-float x))) 1d0))) + +(define-test integer-decode-float.double + ;; Generate 100 random denormal values and compare what + ;; integer-decode-float returns against what it should return. + (dotimes (k 100) + (let ((x (random least-positive-normalized-double-float))) + (multiple-value-bind (hi lo) + (kernel:double-float-bits x) + ;; Verify that the exponent is 0, which it must be for a + ;; denormal number. + (assert-equal 0 + (ldb vm:double-float-exponent-byte hi) + x) + ;; Print out the fraction bits, and the bits returned by + ;; INTEGER-DECODE-FLOAT. We could do this differently, but + ;; this has the nice side effect of making it easy to see what + ;; is expected and what went wrong. + (let* ((expected (format nil "~b~32,'0b" hi lo)) + (actual (format nil "~b" (integer-decode-float x))) + (tail (subseq actual (length expected)))) + ;; If everything is working correctly, the beginning of the + ;; actual bits must exactly match the expected bits. + (assert-true (every #'char= + expected + actual) + x + expected + actual) + ;; And finally, the trailing part of the actual bits must be + ;; all zeroes, but this is a denormal number. + (assert-true (every #'(lambda (c) + (char= c #\0)) + tail) + x + tail)))))) + +(define-test scale-float.double + ;; As a side-effect of fixing INTEGER-DECODE-FLOAT, SCALE-FLOAT + ;; should return the correct values now when scaling + ;; denormals. Check a few denormal values. + (dotimes (k 100) + (let* ((x (random least-positive-normalized-double-float)) + (scaled (scale-float x 54)) + (mult (* x (scale-float 1d0 54)))) + ;; The result of SCALE-FLOAT and the multiplication should be + ;; exactly equal because the multiplication by 2^54 is exactly + ;; representable. + (assert-equal scaled + mult + x + scaled + mult))) + ;; Add the test caused the investigation of SCALE-FLOAT + (let* ((x 1d-310) + (scaled (scale-float x 54)) + (mult (* x (scale-float 1d0 54)))) + (assert-equal scaled + mult + x + scaled + mult))) + +(define-test decode-float.double + ;; As a side-effect of fixing INTEGER-DECODE-FLOAT, DECODE-FLOAT + ;; should return the correct values now. We just spot check one + ;; value here. + (dotimes (k 100) + (let ((x (random least-positive-normalized-double-float))) + (multiple-value-bind (f e) + (decode-float x) + (assert-equal x + (scale-float f e) + f + e))))) ----------------------------------------------------------------------- Summary of changes: src/code/float.lisp | 2 +- src/general-info/release-20f.txt | 4 +++ tests/float.lisp | 74 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 79 insertions(+), 1 deletion(-) hooks/post-receive -- CMU Common Lisp

1 0