New primitives for creating and examining NaNs.

- (flo:make-nan negative? quiet? payload)
- (flo:nan-quiet? nan)
- (flo:nan-payload nan)

diff --git a/src/microcode/flonum.c b/src/microcode/flonum.c
index b4aaa392ff1986b5cfc2ee1f380a9ba606810ee8..4b24e1d7eb088fd64f1e5d5ee4cfe1a258fd6fc2 100644 (file)
--- a/src/microcode/flonum.c
+++ b/src/microcode/flonum.c
@@ -26,9 +26,12 @@ USA.
 
 /* Floating Point Arithmetic */
 
+#include <float.h>
+
 #include "scheme.h"
 #include "osscheme.h"          /* error_unimplemented_primitive -- foo */
 #include "prims.h"
+#include "ctassert.h"
 
 double
 arg_flonum (int arg_number)
@@ -544,6 +547,65 @@ DEFINE_PRIMITIVE ("FLONUM-IS-ZERO?", Prim_flonum_is_zero_p, 1, 1, 0)
   }
 }
 \f
+/* NaN utilities */
+
+DEFINE_PRIMITIVE ("FLONUM-MAKE-NAN", Prim_flonum_make_nan, 3, 3, 0)
+{
+  PRIMITIVE_HEADER (3);
+  CTASSERT (FLT_RADIX == 2);
+  CTASSERT (DBL_MANT_DIG == 53);
+  {
+    uint64_t sign = (OBJECT_TO_BOOLEAN (ARG_REF (1)));
+    uint64_t quiet = (OBJECT_TO_BOOLEAN (ARG_REF (2)));
+    uint64_t payload =
+      (arg_index_integer_to_intmax (3, ((UINT64_C (1)) << 51)));
+    union {
+      double d;
+      uint64_t i;
+    } u = { .i = 0 };
+    if ((!quiet) && (payload == 0))
+      error_bad_range_arg (payload);
+    (u.i) |= (sign << 63);
+    (u.i) |= ((UINT64_C (0x7ff)) << 52);
+    (u.i) |= (quiet << 51);
+    (u.i) |= payload;
+    FLONUM_RESULT (u.d);
+  }
+}
+
+DEFINE_PRIMITIVE ("FLONUM-NAN-QUIET?", Prim_flonum_nan_quiet_p, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  CTASSERT (FLT_RADIX == 2);
+  CTASSERT (DBL_MANT_DIG == 53);
+  {
+    union {
+      double d;
+      uint64_t i;
+    } u = { .d = (arg_flonum (1)) };
+    if (((u.i) & ((UINT64_C (0x7ff)) << 52)) != ((UINT64_C (0x7ff)) << 52))
+      error_bad_range_arg (1);
+    PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((u.i) & ((UINT64_C (1)) << 51)));
+  }
+}
+
+DEFINE_PRIMITIVE ("FLONUM-NAN-PAYLOAD", Prim_flonum_nan_payload, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  CTASSERT (FLT_RADIX == 2);
+  CTASSERT (DBL_MANT_DIG == 53);
+  {
+    union {
+      double d;
+      uint64_t i;
+    } u = { .d = (arg_flonum (1)) };
+    if (((u.i) & ((UINT64_C (0x7ff)) << 52)) != ((UINT64_C (0x7ff)) << 52))
+      error_bad_range_arg (1);
+    PRIMITIVE_RETURN
+      (uintmax_to_integer ((u.i) & (((UINT64_C (1)) << 51) - 1)));
+  }
+}
+\f
 /* Miscellaneous floating-point operations */
 
 DEFINE_PRIMITIVE ("FLONUM-COPYSIGN", Prim_flonum_copysign, 2, 2, 0)

diff --git a/src/runtime/primitive-arithmetic.scm b/src/runtime/primitive-arithmetic.scm
index 3f12d6ccbee1255e11cc2f59415d7071f9e97214..42eff46dce3501f40a3d5a63504c756aee61175c 100644 (file)
--- a/src/runtime/primitive-arithmetic.scm
+++ b/src/runtime/primitive-arithmetic.scm
@@ -226,7 +226,10 @@ USA.
   (flo:vector-cons floating-vector-cons 1)
   (flo:vector-length floating-vector-length 1)
   (flo:vector-ref floating-vector-ref 2)
-  (flo:vector-set! floating-vector-set! 3))
+  (flo:vector-set! floating-vector-set! 3)
+  (flo:make-nan flonum-make-nan 3)
+  (flo:nan-quiet? flonum-nan-quiet? 1)
+  (flo:nan-payload flonum-nan-payload 1))
 \f
 (define (flo:<= x y) (or (flo:< x y) (flo:= x y)))
 (define (flo:>= x y) (or (flo:> x y) (flo:= x y)))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 738bcdba75fad2b6134ea5d1aac58213cac65a04..052695e9f72a5feb56bccf382008fc1a1c2556bf 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -330,9 +330,12 @@ USA.
          flo:lgamma
          flo:log
          flo:log1p
+         flo:make-nan
          flo:max
          flo:min
          flo:modulo
+         flo:nan-payload
+         flo:nan-quiet?
          flo:nan?
          flo:negate
          flo:negative?

diff --git a/tests/runtime/test-flonum.scm b/tests/runtime/test-flonum.scm
index 8aa2cfe1ac2a32f6aa0ab4f2a1671085d8f91a45..953cfcb68f30f7a0d6fce1f4bfd3d47a82f34d90 100644 (file)
--- a/tests/runtime/test-flonum.scm
+++ b/tests/runtime/test-flonum.scm
@@ -35,6 +35,12 @@ USA.
              (apply procedure arguments)))
          cases)))
 
+(define assert-flonum
+  (predicate-assertion flo:flonum? "flonum"))
+
+(define assert-nan
+  (predicate-assertion flo:nan? "NaN"))
+
 (define (with-expected-failure xfail body)
   (if (default-object? xfail)
       (body)
@@ -462,3 +468,28 @@ USA.
     (+1. #f #f)
     (+inf.0 #t #t)
     (+nan.0 #f #f)))
+
+(define-enumerated-test 'nan
+  `(;;(#f #f 0)   ; infinity
+    (#f #t 0)
+    ;;(#t #f 0)   ; infinity
+    (#t #t 0)
+    (#f #f 1)
+    (#f #t 1)
+    (#t #f 1)
+    (#t #t 1)
+    (#f #f 12345)
+    (#f #t 12345)
+    (#t #f 12345)
+    (#t #t 12345)
+    (#f #f ,(- (expt 2 51) 1))
+    (#f #t ,(- (expt 2 51) 1))
+    (#t #f ,(- (expt 2 51) 1))
+    (#f #t ,(- (expt 2 51) 1)))
+  (lambda (negative? quiet? payload)
+    (let ((nan (flo:make-nan negative? quiet? payload)))
+      (assert-flonum nan)
+      (assert-nan nan)
+      (assert-eqv (flo:safe-negative? nan) negative?)
+      (assert-eqv (flo:nan-quiet? nan) quiet?)
+      (assert-eqv (flo:nan-payload nan) payload))))