From a206017de697d0bd41545b300669138d5d5533ff Mon Sep 17 00:00:00 2001
From: Raymond Toy <toy.raymond@gmail.com>
Date: Thu, 21 Aug 2014 20:41:10 -0700
Subject: [PATCH] Make expm1 signal errors using fdlibm_setexception. Update
 tests to handle signaling and quite NaN

 * src/lisp/s_expm1.c:
   * Use fdlibm_setexception
 * tests/trig.lisp:
   * Add additional tests to existing testsuite to distinguish
     signaling and quiet NaN. The functions should signal on quiet
     NaN.
   * Add tests for expm1.
---
 src/lisp/s_expm1.c | 10 +++++++---
 tests/trig.lisp    | 41 ++++++++++++++++++++++++++++++++++-------
 2 files changed, 41 insertions(+), 10 deletions(-)

diff --git a/src/lisp/s_expm1.c b/src/lisp/s_expm1.c
index 743188516..4e9bae817 100644
--- a/src/lisp/s_expm1.c
+++ b/src/lisp/s_expm1.c
@@ -150,10 +150,14 @@ Q5  =  -2.01099218183624371326e-07; /* BE8AFDB7 6E09C32D */
 	    if(hx >= 0x40862E42) {		/* if |x|>=709.78... */
                 if(hx>=0x7ff00000) {
 		    if(((hx&0xfffff)|ux.i[LOWORD])!=0) 
-		         return x+x; 	 /* NaN */
-		    else return (xsb==0)? x:-1.0;/* exp(+-inf)={inf,-1} */
+                        return fdlibm_setexception(x, FDLIBM_INVALID); 	 /* NaN */
+                    else return (xsb==0)? x:-1.0;/* exp(+-inf)={inf,-1} */
 	        }
-	        if(x > o_threshold) return huge*huge; /* overflow */
+	        if(x > o_threshold) {
+                    /* overflow */
+                    return fdlibm_setexception(x, FDLIBM_OVERFLOW);
+                }
+                
 	    }
 	    if(xsb!=0) { /* x < -56*ln2, return -1.0 with inexact */
 		if(x+tiny<0.0)		/* raise inexact */
diff --git a/tests/trig.lisp b/tests/trig.lisp
index 62ac377d4..07cd6bd05 100644
--- a/tests/trig.lisp
+++ b/tests/trig.lisp
@@ -794,10 +794,14 @@
 
 ;; Test that fdlibm routines signals exceptions as expected.
 
-(defparameter *nan*
+(defparameter *qnan*
   (kernel::with-float-traps-masked (:invalid)
     (* 0 ext:double-float-positive-infinity))
-  "Some randon MaN value")
+  "Some randon quiet MaN value")
+
+(defparameter *snan*
+  (kernel:make-double-float #x7ff00000 1)
+  "A randon signaling MaN value")
 
 (define-test cosh.exceptions
   (:tag :fdlibm)
@@ -806,7 +810,9 @@
   (assert-error 'floating-point-overflow
 		(kernel:%cosh -1000d0))
   (assert-error 'floating-point-invalid-operation
-		(kernel:%cosh *nan*))
+		(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
@@ -819,7 +825,7 @@
 		  (kernel:%cosh ext:double-float-negative-infinity)))
   ;; Test NaN
   (kernel::with-float-traps-masked (:invalid)
-    (assert-true (ext:float-nan-p (kernel:%cosh *nan*)))))
+    (assert-true (ext:float-nan-p (kernel:%cosh *snan*)))))
 
 (define-test sinh.exceptions
   (:tag :fdlibm)
@@ -828,7 +834,8 @@
   (assert-error 'floating-point-overflow
 		(kernel:%sinh -1000d0))
   (assert-error 'floating-point-invalid-operation
-		(kernel:%sinh *nan*))
+		(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
@@ -841,12 +848,16 @@
 		  (kernel:%sinh ext:double-float-negative-infinity)))
   ;; Test NaN
   (kernel::with-float-traps-masked (:invalid)
-    (assert-true (ext:float-nan-p (kernel:%sinh *nan*)))))
+    (assert-true (ext:float-nan-p (kernel:%sinh *qnan*)))))
 
 
 (define-test tanh.exceptions
   (:tag :fdlibm)
-  (assert-true (ext:float-nan-p (kernel:%tanh *nan*))))
+  (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)
@@ -860,3 +871,19 @@
   (kernel::with-float-traps-masked (:invalid)
     (assert-true (ext:float-nan-p (kernel:%acosh 0d0)))))
   
+(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-true ext:double-float-positive-infinity
+		 (kernel:%expm1 709.8d0))
+    (assert-true ext:double-float-positive-infinity
+		 (kernel:%expm1 ext:double-float-positive-infinity)))
+  (kernel::with-float-traps-masked (:invalid)
+    (assert-true (ext::float-nan-p (kernel:%expm1 *snan*)))))
-- 
GitLab