[git] CMU Common Lisp branch master updated. snapshot-2014-08-17-ga206017

Raymond Toy rtoy at common-lisp.net
Fri Aug 22 03:41:23 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  a206017de697d0bd41545b300669138d5d5533ff (commit)
       via  7758900b5e12172d7b0306e67a9dc045e7c33643 (commit)
      from  81ebae1c1af846d41fd128703b2357e83736d90d (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 a206017de697d0bd41545b300669138d5d5533ff
Author: Raymond Toy <toy.raymond at gmail.com>
Date:   Thu Aug 21 20:41:10 2014 -0700

    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.

diff --git a/src/lisp/s_expm1.c b/src/lisp/s_expm1.c
index 7431885..4e9bae8 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 62ac377..07cd6bd 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*)))))

commit 7758900b5e12172d7b0306e67a9dc045e7c33643
Author: Raymond Toy <toy.raymond at gmail.com>
Date:   Thu Aug 21 20:32:32 2014 -0700

    Handle invalid correctly.
    
    If the argument is a quiet NaN, then we don't want to signal an
    invalid operation. For all other floats, we do want to signal
    that. Add function isQNaN to detect quiet NaN.

diff --git a/src/lisp/setexception.c b/src/lisp/setexception.c
index a0f568c..a77a9d8 100644
--- a/src/lisp/setexception.c
+++ b/src/lisp/setexception.c
@@ -5,6 +5,37 @@
 #include "fdlibm.h"
 
 /*
+ * Test if the given number is a quiet NaN
+ */
+
+int
+isQNaN(double x)
+{
+    int hx;
+    union { int i[2]; double d; } ux;
+
+    ux.d = x;
+    hx = ux.i[HIWORD] & 0x7fffffff;
+
+    if (hx >= 0x7ff00000) {
+        /*
+         * We have some kind of infinity or NaN. Get the (top)
+         * mantissa bits. We have a quiet NaN if the most significant
+         * bit is 1. The other bits of the mantissa don't matter. We
+         * also don't distinguish this from the quiet NaN
+         * floating-point indefinite which only has the most
+         * significant bit set. These are all considered NaNs for our
+         * purposes.
+         */
+        hx &= 0xfffff;
+        
+        return hx & 0x80000;
+    }
+
+    return 0;
+}
+
+/*
  * Signal the floating-point exception of the given |type|, based on
  * the value of |x|.
  */
@@ -36,13 +67,21 @@ fdlibm_setexception(double x, enum FDLIBM_EXCEPTION type)
       case 3:
       {
           /* invalid */
-          feraiseexcept(FE_INVALID);
+
+          if (!isQNaN(x)) {
+              /*
+               * If it's not a quiet NaN, we want to signal an invalid
+               * operation. Otherwise, we silently return a NaN.
+               */
+              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[HIWORD] = 0x7ff80000;
           ux.i[LOWORD] = 0xdeadbeef;
           
           ret = ux.d;

-----------------------------------------------------------------------

Summary of changes:
 src/lisp/s_expm1.c      |   10 +++++++---
 src/lisp/setexception.c |   43 +++++++++++++++++++++++++++++++++++++++++--
 tests/trig.lisp         |   41 ++++++++++++++++++++++++++++++++++-------
 3 files changed, 82 insertions(+), 12 deletions(-)


hooks/post-receive
-- 
CMU Common Lisp



More information about the cmucl-cvs mailing list