[cmucl-commit] [git] CMU Common Lisp branch master updated. snapshot-2014-08-13-g258101b
Raymond Toy
rtoy at common-lisp.net
Wed Aug 20 04:31:16 UTC 2014
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 258101b2bc45125f6bd72dc2a1cf56e6baab821b (commit)
from c5f98ef90641ec6912e35730b215eaf751841539 (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 258101b2bc45125f6bd72dc2a1cf56e6baab821b
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Tue Aug 19 21:31:04 2014 -0700
Make sure floating-point exceptions are signaled.
The compiler sometimes constant folds operations so that
floating-point exceptions are not signaled. However, lisp and other
applications (maxima) currently expects these exceptions to be
signaled. Make this happen by using feraiseexcept to force these
signals when they are enabled. If feraiseexcept does not raise an
exception (because it is masked), we return the appropriate value.
Only a few files have been updated to support this. More work needed.
* src/lisp/setexception.c:
* New file. This is used by the routines to signal an appropriate
exception or return the appropriate value. Uses feraiseexcept to
do this, which should be available on all supported platforms.
* src/lisp/GNUmakefile:
* Add setexception.c to list of files to compile and link into
lisp.
* src/lisp/e_cosh.c:
* Update to use the new routine.to signal exceptions.
* src/lisp/e_sinh.c:
* Update to use the new routine.to signal exceptions.
* tests/trig.lisp:
* Add tests to make sure exceptions are thrown for cosh and sinh.
* Add tests to make sure that the correct value is returned when
the floating point exception is masked.
diff --git a/src/lisp/GNUmakefile b/src/lisp/GNUmakefile
index 55a0b5b..c557d3b 100644
--- a/src/lisp/GNUmakefile
+++ b/src/lisp/GNUmakefile
@@ -11,7 +11,8 @@ FDLIBM = k_sin.c k_cos.c k_tan.c s_sin.c s_cos.c s_tan.c sincos.c \
e_cosh.c e_sinh.c s_tanh.c \
e_acosh.c s_asinh.c e_atanh.c \
e_atan2.c \
- e_rem_pio2.c k_rem_pio2.c
+ e_rem_pio2.c k_rem_pio2.c \
+ setexception.c
SRCS = lisp.c coreparse.c alloc.c monitor.c print.c interr.c \
vars.c parse.c interrupt.c search.c validate.c globals.c \
diff --git a/src/lisp/e_cosh.c b/src/lisp/e_cosh.c
index 1d2ac30..dc13fee 100644
--- a/src/lisp/e_cosh.c
+++ b/src/lisp/e_cosh.c
@@ -58,8 +58,14 @@ static double one = 1.0, half=0.5, huge = 1.0e307;
ix &= 0x7fffffff;
/* x is INF or NaN */
- if(ix>=0x7ff00000) return x*x;
-
+ if(ix>=0x7ff00000) {
+ if (ix == 0x7ff00000 && (ux.i[LOWORD] == 0)) {
+ return fdlibm_setexception(fabs(x), FDLIBM_OVERFLOW);
+ } else {
+ return fdlibm_setexception(x, FDLIBM_INVALID);
+ }
+ }
+
/* |x| in [0,0.5*ln2], return 1+expm1(|x|)^2/(2*exp(|x|)) */
if(ix<0x3fd62e43) {
t = fdlibm_expm1(fabs(x));
@@ -91,5 +97,5 @@ static double one = 1.0, half=0.5, huge = 1.0e307;
}
/* |x| > overflowthresold, cosh(x) overflow */
- return fabs(x)*huge;
+ return fdlibm_setexception(fabs(x), FDLIBM_OVERFLOW);;
}
diff --git a/src/lisp/e_sinh.c b/src/lisp/e_sinh.c
index 76b3418..9d7aec8 100644
--- a/src/lisp/e_sinh.c
+++ b/src/lisp/e_sinh.c
@@ -55,7 +55,13 @@ static double one = 1.0, shuge = 1.0e307;
ix = jx&0x7fffffff;
/* x is INF or NaN */
- if(ix>=0x7ff00000) return x+x;
+ if(ix>=0x7ff00000) {
+ if (ix == 0x7ff00000 && (ux.i[LOWORD] == 0)) {
+ return fdlibm_setexception(x, FDLIBM_OVERFLOW);
+ } else {
+ return fdlibm_setexception(x, FDLIBM_INVALID);
+ }
+ };
h = 0.5;
if (jx<0) h = -h;
@@ -84,5 +90,5 @@ static double one = 1.0, shuge = 1.0e307;
}
/* |x| > overflowthresold, sinh(x) overflow */
- return x*shuge;
+ return fdlibm_setexception(x, FDLIBM_OVERFLOW);;
}
diff --git a/src/lisp/fdlibm.h b/src/lisp/fdlibm.h
index 9d25664..abd6e80 100644
--- a/src/lisp/fdlibm.h
+++ b/src/lisp/fdlibm.h
@@ -57,5 +57,13 @@ extern double fdlibm_atan(double x);
extern double __ieee754_exp(double x);
extern double __ieee754_log(double x);
+enum FDLIBM_EXCEPTION {
+ FDLIBM_DIVIDE_BY_ZERO,
+ FDLIBM_UNDERFLOW,
+ FDLIBM_OVERFLOW,
+ FDLIBM_INVALID
+};
+
+extern double fdlibm_setexception(double x, enum FDLIBM_EXCEPTION);
#endif
diff --git a/src/lisp/setexception.c b/src/lisp/setexception.c
new file mode 100644
index 0000000..a0f568c
--- /dev/null
+++ b/src/lisp/setexception.c
@@ -0,0 +1,55 @@
+#include <fenv.h>
+#include <math.h>
+#include <stdio.h>
+
+#include "fdlibm.h"
+
+/*
+ * Signal the floating-point exception of the given |type|, based on
+ * the value of |x|.
+ */
+
+double
+fdlibm_setexception(double x, enum FDLIBM_EXCEPTION type)
+{
+ double ret;
+
+ switch (type) {
+ case 0:
+ /* Division by zero. Use the sign of x to get the correct
+ * signed infinity
+ */
+ feraiseexcept(FE_DIVBYZERO);
+
+ ret = copysign(INFINITY, x);
+ break;
+ case 1:
+ /* Underflow. Use the sign of x to get a signed zero. */
+ feraiseexcept(FE_UNDERFLOW);
+ ret = copysign(0.0, x);
+ break;
+ case 2:
+ /* overflow */
+ feraiseexcept(FE_OVERFLOW);
+ ret = copysign(INFINITY, x);
+ break;
+ case 3:
+ {
+ /* invalid */
+ feraiseexcept(FE_INVALID);
+ /*
+ * FIXME: Of the many NaN values that we have, what NaN
+ * should we return?
+ */
+ union { int i[2]; double d; } ux;
+ ux.i[HIWORD] = 0x7ff00000;
+ ux.i[LOWORD] = 0xdeadbeef;
+
+ ret = ux.d;
+
+ break;
+ }
+ }
+
+ return ret;
+}
diff --git a/tests/trig.lisp b/tests/trig.lisp
index 4f15848..18c9199 100644
--- a/tests/trig.lisp
+++ b/tests/trig.lisp
@@ -792,12 +792,56 @@
(assert-true (check-signs #'atanh #c(2d0 0d0) tr ti))
(assert-true (check-signs #'atanh #c(2w0 0w0) tr ti))))
-(define-test cosh.overflow
- (:tag :cosh)
+;; Test that fdlibm routines signals exceptions as expected.
+
+(defparameter *nan*
+ (kernel::with-float-traps-masked (:invalid)
+ (* 0 ext:double-float-positive-infinity))
+ "Some randon MaN value")
+
+(define-test cosh.exceptions
+ (:tag :fdlibm)
(assert-error 'floating-point-overflow
- (cosh 1000d0)))
+ (cosh 1000d0))
+ (assert-error 'floating-point-overflow
+ (cosh -1000d0))
+ (assert-error 'floating-point-invalid-operation
+ (cosh *nan*))
+ ;; Same, but with overflow's masked
+ (kernel::with-float-traps-masked (:overflow)
+ (assert-equal ext:double-float-positive-infinity
+ (cosh 1000d0))
+ (assert-equal ext:double-float-positive-infinity
+ (cosh -1000d0))
+ (assert-equal ext:double-float-positive-infinity
+ (cosh ext:double-float-positive-infinity))
+ (assert-equal ext:double-float-positive-infinity
+ (cosh ext:double-float-negative-infinity)))
+ ;; Test NaN
+ (kernel::with-float-traps-masked (:invalid)
+ (assert-true (ext:float-nan-p (cosh *nan*)))))
(define-test sinh.overflow
- (:tag :sinh)
+ (:tag :fdlibm)
+ (assert-error 'floating-point-overflow
+ (sinh 1000d0))
(assert-error 'floating-point-overflow
- (sinh 1000d0)))
\ No newline at end of file
+ (sinh -1000d0))
+ (assert-error 'floating-point-invalid-operation
+ (sinh *nan*))
+ ;; Same, but with overflow's masked
+ (kernel::with-float-traps-masked (:overflow)
+ (assert-equal ext:double-float-positive-infinity
+ (sinh 1000d0))
+ (assert-equal ext:double-float-negative-infinity
+ (sinh -1000d0))
+ (assert-equal ext:double-float-positive-infinity
+ (sinh ext:double-float-positive-infinity))
+ (assert-equal ext:double-float-negative-infinity
+ (sinh ext:double-float-negative-infinity)))
+ ;; Test NaN
+ (kernel::with-float-traps-masked (:invalid)
+ (assert-true (ext:float-nan-p (sinh *nan*)))))
+
+
+
-----------------------------------------------------------------------
Summary of changes:
src/lisp/GNUmakefile | 3 ++-
src/lisp/e_cosh.c | 12 ++++++++---
src/lisp/e_sinh.c | 10 +++++++--
src/lisp/fdlibm.h | 8 +++++++
src/lisp/setexception.c | 55 +++++++++++++++++++++++++++++++++++++++++++++++
tests/trig.lisp | 54 +++++++++++++++++++++++++++++++++++++++++-----
6 files changed, 131 insertions(+), 11 deletions(-)
create mode 100644 src/lisp/setexception.c
hooks/post-receive
--
CMU Common Lisp
More information about the cmucl-commit
mailing list