From 63929ee776996a45c97444ffe807316ae6187e3c Mon Sep 17 00:00:00 2001 From: Raymond Toy <toy.raymond@gmail.com> Date: Sat, 23 Aug 2014 08:22:58 -0700 Subject: [PATCH] Make atanh signal errors using fdlibm_setexception. * src/lisp/e_atanh.c * Use fdlibm_setexception * tests/trig.lisp: * Add tests for atanh --- src/lisp/e_atanh.c | 9 +++++---- tests/trig.lisp | 20 ++++++++++++++++++++ 2 files changed, 25 insertions(+), 4 deletions(-) diff --git a/src/lisp/e_atanh.c b/src/lisp/e_atanh.c index 358843698..aed70d465 100644 --- a/src/lisp/e_atanh.c +++ b/src/lisp/e_atanh.c @@ -57,10 +57,11 @@ static double zero = 0.0; lx = ux.i[LOWORD]; /* low word */ ix = hx&0x7fffffff; if ((ix|((lx|(-lx))>>31))>0x3ff00000) /* |x|>1 */ - return (x-x)/(x-x); - if(ix==0x3ff00000) - return x/zero; - if(ix<0x3e300000&&(huge+x)>zero) return x; /* x<2**-28 */ + return fdlibm_setexception(x, FDLIBM_INVALID); + if(ix==0x3ff00000) + return fdlibm_setexception(x, FDLIBM_DIVIDE_BY_ZERO); + + if(ix<0x3e300000&&(huge+x)>zero) return x; /* x<2**-28 */ ux.d = x; ux.i[HIWORD] = ix; /* x <- |x| */ x = ux.d; diff --git a/tests/trig.lisp b/tests/trig.lisp index d95db71c9..1b6102d9c 100644 --- a/tests/trig.lisp +++ b/tests/trig.lisp @@ -888,6 +888,26 @@ (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 -- GitLab