diff --git a/src/lisp/GNUmakefile b/src/lisp/GNUmakefile index 55a0b5b872853d72df83524ea981f146bc6987cb..c557d3be43f8d8d90c497d81b57aadfc2027ffcb 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 1d2ac3078bd35b79e68ff141c859774cc2f7d782..dc13feeca815496bcac87791635aa6c20339490b 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 76b3418d09cfffb37521521a0fe97b464716cc84..9d7aec89ab20e22a3c6e8243ce61dc2528e1dedb 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 9d256646c093c7083e0bf25de6d7ef15baaac869..abd6e80d76d82c8cbbc7cb5902e58cc4d15550c5 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 0000000000000000000000000000000000000000..a0f568c054c81aab4a22273cb833bb6a454827d9 --- /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 4f158486910362d5a8bb000ec228f4b2a390456d..18c919908e191a5a0c47c3aec3d2d0d3fede1b99 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*))))) + + +