[Git][cmucl/cmucl][rtoy-setexception-inexact] Use setexception to raise the inexact exception for %log1p.

[Raymond Toy]

Raymond Toy pushed to branch rtoy-setexception-inexact at cmucl / cmucl


Commits:
91ff3607 by Raymond Toy at 2015-12-24T09:23:06Z
Use setexception to raise the inexact exception for %log1p.

- - - - -


2 changed files:

- src/lisp/s_log1p.c
- tests/fdlibm.lisp


Changes:

=====================================
src/lisp/s_log1p.c
=====================================
--- a/src/lisp/s_log1p.c
+++ b/src/lisp/s_log1p.c
@@ -123,9 +123,14 @@ static double zero = 0.0;
                 }
 	    }
 	    if(ax<0x3e200000) {			/* |x| < 2**-29 */
-		if(two54+x>zero			/* raise inexact */
-	            &&ax<0x3c900000) 		/* |x| < 2**-54 */
+		if (ax < 0x3c900000) {  /* |x| < 2**-54 */
+		    /* return x inexact except 0 */
+		    if (x != 0) {
+			fdlibm_setexception(x, FDLIBM_INEXACT);
+		    }
+
 		    return x;
+		}
 		else
 		    return x - x*x*0.5;
 	    }


=====================================
tests/fdlibm.lisp
=====================================
--- a/tests/fdlibm.lisp
+++ b/tests/fdlibm.lisp
@@ -181,7 +181,19 @@
     (assert-equal ext:double-float-negative-infinity
 		  (kernel:%log1p -1d0)))
   (kernel::with-float-traps-masked (:invalid)
-    (assert-true (ext:float-nan-p (kernel:%log1p *snan*)))))
+    (assert-true (ext:float-nan-p (kernel:%log1p *snan*))))
+  ;; log1p(x) = x for |x| < 2^-54, signaling inexact except for x = 0.
+  (let ((x (scale-float 1d0 -55))
+	(x0 0d0))
+    (with-inexact-exception-enabled
+	;; This must not throw an inexact exception because the result
+	;; is exact when the arg is 0.
+	(assert-eql 0d0 (kernel:%log1p x0)))
+    (with-inexact-exception-enabled
+	;; This must throw an inexact exception for non-zero x even
+	;; though the result is exactly x.
+	(assert-error 'floating-point-inexact
+		      (kernel:%log1p x)))))
 
 (define-test %exp.exceptions
   (:tag :fdlibm)



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/91ff36070092df5d879081a435bd7d22587c8717
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20151224/1884ca4e/attachment-0001.html>