From da7702961c41023905a8195a6750d9fc1eab2668 Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Wed, 28 Nov 2018 17:55:03 +0000
Subject: [PATCH] New primitives for creating and examining NaNs.

- (flo:make-nan negative? quiet? payload)
- (flo:nan-quiet? nan)
- (flo:nan-payload nan)
---
 src/microcode/flonum.c               | 62 ++++++++++++++++++++++++++++
 src/runtime/primitive-arithmetic.scm |  5 ++-
 src/runtime/runtime.pkg              |  3 ++
 tests/runtime/test-flonum.scm        | 31 ++++++++++++++
 4 files changed, 100 insertions(+), 1 deletion(-)

diff --git a/src/microcode/flonum.c b/src/microcode/flonum.c
index b4aaa392f..4b24e1d7e 100644
--- 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)
   }
 }
 
+/* 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)));
+  }
+}
+
 /* 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 3f12d6ccb..42eff46dc 100644
--- 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))
 
 (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 738bcdba7..052695e9f 100644
--- 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 8aa2cfe1a..953cfcb68 100644
--- 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))))
-- 
2.25.1