[Git][cmucl/cmucl][rtoy-setexception-inexact] 3 commits: Use setexception to raise the inexact exception for sin.

[Raymond Toy]

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


Commits:
71bdff74 by Raymond Toy at 2015-12-24T08:54:03Z
Use setexception to raise the inexact exception for sin.

- - - - -
a31150c5 by Raymond Toy at 2015-12-24T08:59:29Z
Use setexception to raise the inexact exception for tan.

- - - - -
ae70cdd3 by Raymond Toy at 2015-12-24T09:06:54Z
Use setexception to raise the inexact exception for atan.

- - - - -


4 changed files:

- src/lisp/k_sin.c
- src/lisp/k_tan.c
- src/lisp/s_atan.c
- tests/fdlibm.lisp


Changes:

=====================================
src/lisp/k_sin.c
=====================================
--- a/src/lisp/k_sin.c
+++ b/src/lisp/k_sin.c
@@ -67,8 +67,14 @@ S6  =  1.58969099521155010221e-10; /* 0x3DE5D93A, 0x5ACFD57C */
 
         ux.d = x;
 	ix = ux.i[HIWORD]&0x7fffffff;	/* high word of x */
-	if(ix<0x3e400000)			/* |x| < 2**-27 */
-	   {if((int)x==0) return x;}		/* generate inexact */
+	if(ix<0x3e400000) {			/* |x| < 2**-27 */
+            /* return x inexact except 0 */
+            if (x != 0) {
+                fdlibm_setexception(x, FDLIBM_INEXACT);
+            }
+
+            return x;
+        }
 	z	=  x*x;
 	v	=  z*x;
 	r	=  S2+z*(S3+z*(S4+z*(S5+z*S6)));


=====================================
src/lisp/k_tan.c
=====================================
--- a/src/lisp/k_tan.c
+++ b/src/lisp/k_tan.c
@@ -78,31 +78,34 @@ __kernel_tan(double x, double y, int iy) {
 	hx = ux.i[HIWORD];		/* high word of x */
 	ix = hx & 0x7fffffff;			/* high word of |x| */
 	if (ix < 0x3e300000) {			/* x < 2**-28 */
-		if ((int) x == 0) {		/* generate inexact */
-			if (((ix | ux.i[LOWORD]) | (iy + 1)) == 0)
-				return one / fabs(x);
-			else {
-				if (iy == 1)
-					return x;
-				else {	/* compute -1 / (x+y) carefully */
-					double a, t;
+            /* return x inexact except 0 */
+            if (x != 0) {
+                fdlibm_setexception(x, FDLIBM_INEXACT);
+            }
 
-					z = w = x + y;
-                                        uz.d = z;
-					uz.i[LOWORD] = 0;
-                                        z = ux.d;
+	    if (((ix | ux.i[LOWORD]) | (iy + 1)) == 0)
+		return one / fabs(x);
+	    else {
+		if (iy == 1)
+		    return x;
+		else {	/* compute -1 / (x+y) carefully */
+		    double a, t;
+
+		    z = w = x + y;
+		    uz.d = z;
+		    uz.i[LOWORD] = 0;
+		    z = ux.d;
                                         
-					v = y - (z - x);
-					t = a = -one / w;
-                                        uz.d = t;
-                                        uz.i[LOWORD] = 0;
-                                        t = uz.d;
+		    v = y - (z - x);
+		    t = a = -one / w;
+		    uz.d = t;
+		    uz.i[LOWORD] = 0;
+		    t = uz.d;
                                         
-					s = one + t * z;
-					return t + a * (s + t * v);
-				}
-			}
+		    s = one + t * z;
+		    return t + a * (s + t * v);
 		}
+	    }
 	}
 	if (ix >= 0x3FE59428) {	/* |x| >= 0.6744 */
 		if (hx < 0) {


=====================================
src/lisp/s_atan.c
=====================================
--- a/src/lisp/s_atan.c
+++ b/src/lisp/s_atan.c
@@ -104,7 +104,12 @@ huge   = 1.0e300;
 	    else     return -atanhi[3]-atanlo[3];
 	} if (ix < 0x3fdc0000) {	/* |x| < 0.4375 */
 	    if (ix < 0x3e200000) {	/* |x| < 2^-29 */
-		if(huge+x>one) return x;	/* raise inexact */
+		/* return x inexact except 0 */
+		if (x != 0) {
+		    fdlibm_setexception(x, FDLIBM_INEXACT);
+		}
+
+		return x;
 	    }
 	    id = -1;
 	} else {


=====================================
tests/fdlibm.lisp
=====================================
--- a/tests/fdlibm.lisp
+++ b/tests/fdlibm.lisp
@@ -258,7 +258,19 @@
 		(kernel:%atan *snan*))
   (assert-true (ext:float-nan-p (kernel:%atan *qnan*)))
   (kernel::with-float-traps-masked (:invalid)
-    (assert-true (ext:float-nan-p (kernel:%atan *snan*)))))
+    (assert-true (ext:float-nan-p (kernel:%atan *snan*))))
+  ;; atan(x) = x for |x| < 2^-29, signaling inexact.
+  (let ((x (scale-float 1d0 -30))
+	(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:%atan 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:%atan x)))))
 
 (define-test %log10.exceptions
   (:tag :fdlibm)
@@ -622,3 +634,34 @@
 	;; though the result is exactly x.
 	(assert-error 'floating-point-inexact
 		      (kernel:%cos x)))))
+
+(define-test %sin.exceptions
+    (:tag :fdlibm)
+  ;; sin(x) = x for |x| < 2^-27.  Signal inexact unless x = 0
+  (let ((x (scale-float 1d0 -28))
+	(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:%sin 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:%sin x)))))
+
+(define-test %tan.exceptions
+    (:tag :fdlibm)
+  ;; tan(x) = x for |x| < 2^-28.  Signal inexact unless x = 0
+  (let ((x (scale-float 1d0 -29))
+	(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:%tan 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:%tan x)))))
+



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/d448ca78228ea8b9173a4b42d24d16c8e9a4ef55...ae70cdd320e8e0cae0abae3f5f7d593d2f9d7018
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20151224/3fa6677d/attachment.html>