From 64ba7b87ce20a88092326e43f51421639df55b31 Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Wed, 28 Nov 2018 17:07:36 +0000
Subject: [PATCH] Implement flo:safe-zero? and flo:safe=.

---
 src/microcode/flonum.c               | 22 ++++++++++++++++++-
 src/runtime/primitive-arithmetic.scm |  2 ++
 src/runtime/runtime.pkg              |  2 ++
 tests/runtime/test-flonum.scm        | 32 ++++++++++++++++++++++------
 4 files changed, 50 insertions(+), 8 deletions(-)

diff --git a/src/microcode/flonum.c b/src/microcode/flonum.c
index e0c1bfd1e..b4aaa392f 100644
--- 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
   }
 }
 
-/* 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));
+  }
+}
 
 /* Miscellaneous floating-point operations */
 
diff --git a/src/runtime/primitive-arithmetic.scm b/src/runtime/primitive-arithmetic.scm
index d1ab3c8ce..3f12d6ccb 100644
--- 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 4c0f7d2ec..738bcdba7 100644
--- 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 83c5f3cc0..8aa2cfe1a 100644
--- 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)
-- 
2.25.1