Add support for C99 floating-point predicates.

Also expose those predicates in Scheme, and implement flo:eqv? properly.

diff --git a/src/microcode/artutl.c b/src/microcode/artutl.c
index dcb6a0cfecfddb6773df76ab0b4f7010e758aa6e..0c429170651d080d080b56b4f973a188f4a0fdc9 100644 (file)
--- a/src/microcode/artutl.c
+++ b/src/microcode/artutl.c
@@ -223,16 +223,7 @@ finite_flonum_p (SCHEME_OBJECT x)
 bool
 flonum_is_finite_p (SCHEME_OBJECT x)
 {
-  return double_is_finite_p (FLONUM_TO_DOUBLE (x));
-}
-
-bool
-double_is_finite_p (double x)
-{
-  return
-    (((x > 1.0) || (x < -1.0))
-     ? (x != (x / 2.0))
-     : ((x <= 1.0) && (x >= -1.0)));
+  return (isfinite (FLONUM_TO_DOUBLE (x)));
 }
 
 bool

diff --git a/src/microcode/extern.h b/src/microcode/extern.h
index bedf025d2045e5b9d2ec7e5c9eebe22bf28ed841..1f1fa877bd49f28f1b6a84cb5fad08e378067e61 100644 (file)
--- a/src/microcode/extern.h
+++ b/src/microcode/extern.h
@@ -271,7 +271,6 @@ extern SCHEME_OBJECT integer_negative_zero_bits (unsigned long, unsigned long);
 extern SCHEME_OBJECT integer_shift_left (SCHEME_OBJECT, unsigned long);
 extern SCHEME_OBJECT integer_shift_right (SCHEME_OBJECT, unsigned long);
 
-extern bool double_is_finite_p (double);
 extern SCHEME_OBJECT double_to_flonum (double);
 extern bool real_number_to_double_p (SCHEME_OBJECT);
 extern double real_number_to_double (SCHEME_OBJECT);

diff --git a/src/microcode/flonum.c b/src/microcode/flonum.c
index 40d4f5f7497655a0f20cbe0c640c18619ee7d33a..1b66da4c97b23e98464d9effd1334aed81bcc498 100644 (file)
--- a/src/microcode/flonum.c
+++ b/src/microcode/flonum.c
@@ -476,6 +476,80 @@ DEFINE_PRIMITIVE ("CAST-INTEGER-TO-IEEE754-SINGLE", Prim_cast_integer_to_ieee754
   }
 }
 \f
+/* C99 flonum predicates */
+
+DEFINE_PRIMITIVE ("FLONUM-IS-FINITE?", Prim_flonum_is_finite_p, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (isfinite (arg_flonum (1))));
+}
+
+DEFINE_PRIMITIVE ("FLONUM-IS-INFINITE?", Prim_flonum_is_infinite_p, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (isinf (arg_flonum (1))));
+}
+
+DEFINE_PRIMITIVE ("FLONUM-IS-NAN?", Prim_flonum_is_nan_p, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (isnan (arg_flonum (1))));
+}
+
+DEFINE_PRIMITIVE ("FLONUM-IS-NORMAL?", Prim_flonum_is_normal_p, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (isnormal (arg_flonum (1))));
+}
+
+DEFINE_PRIMITIVE ("FLONUM-IS-NEGATIVE?", Prim_flonum_is_negative_p, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (signbit (arg_flonum (1))));
+}
+
+DEFINE_PRIMITIVE ("FLONUM-IS-GREATER?", Prim_flonum_is_greater_p, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  PRIMITIVE_RETURN
+    (BOOLEAN_TO_OBJECT (isgreater ((arg_flonum (1)), (arg_flonum (2)))));
+}
+
+DEFINE_PRIMITIVE ("FLONUM-IS-GREATER-OR-EQUAL?", Prim_flonum_is_greater_or_equal_p, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  PRIMITIVE_RETURN
+    (BOOLEAN_TO_OBJECT (isgreaterequal ((arg_flonum (1)), (arg_flonum (2)))));
+}
+
+DEFINE_PRIMITIVE ("FLONUM-IS-LESS-OR-EQUAL?", Prim_flonum_is_less_or_equal_p, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  PRIMITIVE_RETURN
+    (BOOLEAN_TO_OBJECT (islessequal ((arg_flonum (1)), (arg_flonum (2)))));
+}
+
+DEFINE_PRIMITIVE ("FLONUM-IS-LESS?", Prim_flonum_is_less_p, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  PRIMITIVE_RETURN
+    (BOOLEAN_TO_OBJECT (isless ((arg_flonum (1)), (arg_flonum (2)))));
+}
+
+DEFINE_PRIMITIVE ("FLONUM-IS-LESS-OR-GREATER?", Prim_flonum_is_less_or_greater_p, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  PRIMITIVE_RETURN
+    (BOOLEAN_TO_OBJECT (islessgreater ((arg_flonum (1)), (arg_flonum (2)))));
+}
+
+DEFINE_PRIMITIVE ("FLONUM-IS-UNORDERED?", Prim_flonum_is_unordered_p, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  PRIMITIVE_RETURN
+    (BOOLEAN_TO_OBJECT (isunordered ((arg_flonum (1)), (arg_flonum (2)))));
+}
+\f
 /* Miscellaneous floating-point operations */
 
 DEFINE_PRIMITIVE ("FLONUM-COPYSIGN", Prim_flonum_copysign, 2, 2, 0)

diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm
index 01dd548d9e1730d19984ba41d3f49701a87e0060..5fd209f29c500d8f40ec6059764c0baff2b8aa72 100644 (file)
--- a/src/runtime/arith.scm
+++ b/src/runtime/arith.scm
@@ -912,11 +912,6 @@ USA.
       (let ((p flo:significand-digits-base-2))
        (rat:* (flo:->integer (flo:denormalize f p))
               (rat:expt 2 (int:- e-p p)))))))
-
-(define (flo:nan? x)
-  (not (or (flo:positive? x)
-          (flo:negative? x)
-          (flo:zero? x))))
 \f
 (define (real:real? object)
   (or (flonum? object)

diff --git a/src/runtime/primitive-arithmetic.scm b/src/runtime/primitive-arithmetic.scm
index 971beef6a2aa58a775a082ca2238931d4c7fac7d..9b1b386e0d92aaf1c0d1ad088c4369d22af5f646 100644 (file)
--- a/src/runtime/primitive-arithmetic.scm
+++ b/src/runtime/primitive-arithmetic.scm
@@ -158,9 +158,20 @@ USA.
   (flo:zero? flonum-zero? 1)
   (flo:positive? flonum-positive? 1)
   (flo:negative? flonum-negative? 1)
+  (flo:finite? flonum-is-finite? 1)
+  (flo:infinite? flonum-is-infinite? 1)
+  (flo:nan? flonum-is-nan? 1)
+  (flo:normal? flonum-is-normal? 1)
+  (flo:safe-negative? flonum-is-negative? 1)
   (flo:= flonum-equal? 2)
   (flo:< flonum-less? 2)
   (flo:> flonum-greater? 2)
+  (flo:safe> flonum-is-greater? 2)
+  (flo:safe>= flonum-is-greater-or-equal? 2)
+  (flo:safe< flonum-is-less? 2)
+  (flo:safe<= flonum-is-less-or-equal? 2)
+  (flo:safe<> flonum-is-less-or-greater? 2)
+  (flo:unordered? flonum-is-unordered? 2)
   (flo:+ flonum-add 2)
   (flo:- flonum-subtract 2)
   (flo:* flonum-multiply 2)
@@ -229,22 +240,13 @@ USA.
        ((flo:= x y) y)
        (else (error:bad-range-argument (if (flo:finite? x) x y) 'flo:max))))
 
-;;; XXX FLO:FINITE?, FLO:NAN?, FLO:EQV?, &c., are cute, but should be
-;;; replaced by primitives.
-
-(define (flo:finite? x)
-  (if (or (flo:> x 1.) (flo:< x -1.))
-      (not (flo:= x (flo:/ x 2.)))
-      (and (flo:<= x 1.) (flo:>= x -1.))))
-
 (define (flo:eqv? x y)
-  ;; (bit-string=? (flo:->bit-string x) (flo:->bit-string y))
-  (if (flo:= x y)
-      (or (not (flo:zero? x))
-          ;; XXX Kludgey but expedient test for zero sign.
-          (flo:= (flo:atan2 x -1.) (flo:atan2 y -1.)))
-      ;; XXX (and (flo:nan? x) (flo:nan? y) ...)
-      #f))
+  (and (not (flo:nan? x))
+       (not (flo:nan? y))
+       (flo:= x y)
+       (or (not (flo:zero? x))
+          (eq? (flo:safe-negative? x)
+               (flo:safe-negative? y)))))
 
 (define (int:->flonum n)
   ((ucode-primitive integer->flonum 2) n #b10))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index d60ba44a50f503b474d065e570741cb58bcfb3f5..378feabb21cfb9f7d2c0104fc90a876e9b43ba35 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -299,6 +299,7 @@ USA.
          flo:floor->exact
          flo:gamma
          flo:hypot
+         flo:infinite?
          flo:j0
          flo:j1
          flo:jn
@@ -308,12 +309,20 @@ USA.
          flo:max
          flo:min
          flo:modulo
+         flo:nan?
          flo:negate
          flo:negative?
          flo:nextafter
+         flo:normal?
          flo:positive?
          flo:round
          flo:round->exact
+         flo:safe-negative?
+         flo:safe<
+         flo:safe<=
+         flo:safe<>
+         flo:safe>
+         flo:safe>=
          flo:sin
          flo:sinh
          flo:sqrt
@@ -321,6 +330,7 @@ USA.
          flo:tanh
          flo:truncate
          flo:truncate->exact
+         flo:unordered?
          flo:vector-cons
          flo:vector-length
          flo:vector-ref
@@ -3311,7 +3321,6 @@ USA.
          cube
          exact-nonnegative-integer?
          exact-positive-integer?
-         flo:nan?
          flo:significand-digits-base-10
          flo:significand-digits-base-2
          flonum-unparser-cutoff