Implement flo:safe-zero? and flo:safe=.

diff --git a/src/microcode/flonum.c b/src/microcode/flonum.c
index e0c1bfd1e5a9d16f746cdf72239ba5a1bc6f419c..b4aaa392ff1986b5cfc2ee1f380a9ba606810ee8 100644 (file)
--- a/src/microcode/flonum.c
+++ b/src/microcode/flonum.c
@@ -450,7 +450,7 @@ DEFINE_PRIMITIVE ("CAST-INTEGER-TO-IEEE754-SINGLE", Prim_cast_integer_to_ieee754
   }
 }
 \f
-/* C99 flonum predicates */
+/* IEEE 754 quiet predicates */
 
 DEFINE_PRIMITIVE ("FLONUM-IS-FINITE?", Prim_flonum_is_finite_p, 1, 1, 0)
 {
@@ -523,6 +523,26 @@ DEFINE_PRIMITIVE ("FLONUM-IS-UNORDERED?", Prim_flonum_is_unordered_p, 2, 2, 0)
   PRIMITIVE_RETURN
     (BOOLEAN_TO_OBJECT (isunordered ((arg_flonum (1)), (arg_flonum (2)))));
 }
+
+DEFINE_PRIMITIVE ("FLONUM-IS-EQUAL?", Prim_flonum_is_equal_p, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  {
+    double x = (arg_flonum (1));
+    double y = (arg_flonum (2));
+    PRIMITIVE_RETURN
+      (BOOLEAN_TO_OBJECT ((islessequal (x, y)) && (isgreaterequal (x, y))));
+  }
+}
+
+DEFINE_PRIMITIVE ("FLONUM-IS-ZERO?", Prim_flonum_is_zero_p, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  {
+    double x = (arg_flonum (1));
+    PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((fpclassify (x)) == FP_ZERO));
+  }
+}
 \f
 /* Miscellaneous floating-point operations */
 

diff --git a/src/runtime/primitive-arithmetic.scm b/src/runtime/primitive-arithmetic.scm
index d1ab3c8cedac05dcc3a99c3d2470ed8539fb90b1..3f12d6ccbee1255e11cc2f59415d7071f9e97214 100644 (file)
--- a/src/runtime/primitive-arithmetic.scm
+++ b/src/runtime/primitive-arithmetic.scm
@@ -163,6 +163,7 @@ USA.
   (flo:nan? flonum-is-nan? 1)
   (flo:normal? flonum-is-normal? 1)
   (flo:safe-negative? flonum-is-negative? 1)
+  (flo:safe-zero? flonum-is-zero? 1)
   (flo:= flonum-equal? 2)
   (flo:< flonum-less? 2)
   (flo:> flonum-greater? 2)
@@ -171,6 +172,7 @@ USA.
   (flo:safe< flonum-is-less? 2)
   (flo:safe<= flonum-is-less-or-equal? 2)
   (flo:safe<> flonum-is-less-or-greater? 2)
+  (flo:safe= flonum-is-equal? 2)
   (flo:unordered? flonum-is-unordered? 2)
   (flo:+ flonum-add 2)
   (flo:- flonum-subtract 2)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 4c0f7d2ecd516b6bf4d99c61c745d2d243d6fd86..738bcdba75fad2b6134ea5d1aac58213cac65a04 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -342,9 +342,11 @@ USA.
          flo:round
          flo:round->exact
          flo:safe-negative?
+         flo:safe-zero?
          flo:safe<
          flo:safe<=
          flo:safe<>
+         flo:safe=
          flo:safe>
          flo:safe>=
          flo:sin

diff --git a/tests/runtime/test-flonum.scm b/tests/runtime/test-flonum.scm
index 83c5f3cc0959f2c79d3a2bb73f3ccdaeccb0c9e0..8aa2cfe1ac2a32f6aa0ab4f2a1671085d8f91a45 100644 (file)
--- a/tests/runtime/test-flonum.scm
+++ b/tests/runtime/test-flonum.scm
@@ -107,14 +107,9 @@ USA.
     (,subnormal+ #f)
     (+1. #f)
     (+inf.0 #f)
-    ;; (+nan.0 #f)      ; exception
-    )
+    (+nan.0 #f))
   (lambda (x v)
-    (assert-eqv (yes-traps (lambda () (flo:zero? x))) v)))
-
-(define-test 'nan-is-not-zero
-  (lambda ()
-    (assert-false (no-traps (lambda () (flo:zero? (flo:nan.0)))))))
+    (assert-eqv (yes-traps (lambda () (flo:safe-zero? x))) v)))
 
 (define-enumerated-test 'subnormal?
   `((-inf.0 #f)
@@ -241,6 +236,7 @@ USA.
   (define-comparison-test '>= flo:safe>= flo:>= cases)
   (define-comparison-test '<= flo:safe<= flo:<= cases)
   (define-comparison-test '<> flo:safe<> flo:<> cases)
+  (define-comparison-test '= flo:safe= flo:= cases)
   (define-test 'unordered?
     (map (lambda (x)
            (map (lambda (y)
@@ -379,6 +375,17 @@ USA.
     (+inf.0 #f #t)
     (+nan.0 #f #f)))
 
+(define-constcomp-test '= flo:safe= flo:= 0.
+  `((-inf.0 #f #f)
+    (-1. #f #f)
+    (,subnormal- #f #f)
+    (-0. #t #t)
+    (+0. #t #t)
+    (,subnormal+ #f #f)
+    (+1. #f #f)
+    (+inf.0 #f #f)
+    (+nan.0 #f #f)))
+
 (define-constcomp-test '<> flo:safe<> flo:<> 0.
   `((-inf.0 #t #t)
     (-1. #t #t)
@@ -434,6 +441,17 @@ USA.
     (+inf.0 #f #t)
     (+nan.0 #f #f)))
 
+(define-constcomp-test '= flo:safe= flo:= 1.
+  `((-inf.0 #f #f)
+    (-1. #f #f)
+    (,subnormal- #f #f)
+    (-0. #f #f)
+    (+0. #f #f)
+    (,subnormal+ #f #f)
+    (+1. #t #t)
+    (+inf.0 #f #f)
+    (+nan.0 #f #f)))
+
 (define-constcomp-test '<> flo:safe<> flo:<> 1.
   `((-inf.0 #t #t)
     (-1. #t #t)