Provide notation for NaN payload and signalling NaN.

Reader has various edge cases we fail to make errors still.

diff --git a/src/runtime/dragon4.scm b/src/runtime/dragon4.scm
index e10ba149876c0efdf2b2795d0a85b4bf1f753400..a4178d7ee79cf4c206e315ecce9d62229f973a8c 100644 (file)
--- a/src/runtime/dragon4.scm
+++ b/src/runtime/dragon4.scm
@@ -90,7 +90,10 @@ not much different to numbers within a few orders of magnitude of 1.
     (or (and flonum-printer-hook
             (flonum-printer-hook x radix))
        (cond ((flo:nan? x)
-              (if (flo:sign-negative? x) "-nan.0" "+nan.0"))
+              (string-append (if (flo:sign-negative? x) "-" "+")
+                             (if (flo:nan-quiet? x) "nan" "snan")
+                             "."
+                             (number->string (flo:nan-payload x) radix)))
              ((flo:positive? x)
               (if (flo:infinite? x)
                   "+inf.0"

diff --git a/src/runtime/numpar.scm b/src/runtime/numpar.scm
index 1c65a9e7a3eb802b7828d93913a4448605de9412..1157e3ddfbdc0bfb45cb579b9275da94d9031d40 100644 (file)
--- a/src/runtime/numpar.scm
+++ b/src/runtime/numpar.scm
@@ -118,15 +118,19 @@ USA.
                               (if (eq? #\- sign) (flo:-inf.0) (flo:+inf.0))
                               exactness radix sign))
               ((and (char-ci=? #\n char)
-                    (string-prefix-ci? "an.0" string start end))
-               (parse-complex string (+ start 4) end
-                              (apply-sign sign (flo:nan.0))
-                              exactness radix sign))
+                    (string-prefix-ci? "an." string start end))
+                (parse-nan-payload string (+ start 3) end exactness radix
+                                   #t sign))
+              ((and (char-ci=? #\s char)
+                    (string-prefix-ci? "nan." string start end))
+               (parse-nan-payload string (+ start 4) end exactness radix
+                                  #f sign))
               ((i? char)
                (and (fix:= start end)
                     (make-rectangular 0 (if (eq? #\- sign) -1 1))))
               (else #f)))))
 
+
 (define (parse-integer string start end integer exactness radix sign)
   ;; State: at least one digit has been seen.
   (parse-digits string start end integer exactness radix
@@ -312,6 +316,23 @@ USA.
              (else #f)))
       real))
 
+(define (parse-nan-payload string start end exactness radix quiet? sign)
+  (let loop ((payload 0) (start start))
+    (define (finish)
+      (and (or quiet? (not (zero? payload)))
+          (apply-sign sign (flo:make-nan #f quiet? payload))))
+    (if (fix:< start end)
+        (let ((char (string-ref string start)))
+          (cond ((char->digit char radix)
+                 => (lambda (digit)
+                      (loop (+ (* payload radix) digit) (fix:+ start 1))))
+                ((finish)
+                => (lambda (nan)
+                     (parse-complex string start end nan
+                                    exactness radix sign)))
+               (else #f)))
+        (finish))))
+
 (define (finish-integer integer exactness sign)
   ;; State: result is integer, apply exactness and sign.
   (finish integer exactness sign))

diff --git a/tests/runtime/test-numpar.scm b/tests/runtime/test-numpar.scm
index ce35dc0b44b0ca80b666170f63bbc5dd77e7bc4a..3f6c9fe7b826fbdbfe9fee1225c8199976d05a8d 100644 (file)
--- a/tests/runtime/test-numpar.scm
+++ b/tests/runtime/test-numpar.scm
@@ -168,16 +168,38 @@ USA.
 
 (define-eqv-test "+nan.0" (flo:make-nan #f #t 0))
 (define-eqv-test "-nan.0" (flo:make-nan #t #t 0))
+(define-eqv-test "+nan.1" (flo:make-nan #f #t 1))
+(define-eqv-test "-nan.1" (flo:make-nan #t #t 1))
+(define-eqv-test "+nan.123" (flo:make-nan #f #t 123))
+(define-eqv-test "-nan.123" (flo:make-nan #t #t 123))
+(define-eqv-test "#x+nan.123" (flo:make-nan #f #t #x123))
+(define-eqv-test "#x-nan.123" (flo:make-nan #t #t #x123))
+(define-eqv-test "#x+nan.deadbeef" (flo:make-nan #f #t #xdeadbeef))
+(define-eqv-test "#x-nan.deadbeef" (flo:make-nan #t #t #xdeadbeef))
+(define-error-test "+snan.0")
+(define-error-test "-snan.0")
+(define-eqv-test "+snan.1" (flo:make-nan #f #f 1))
+(define-eqv-test "-snan.1" (flo:make-nan #t #f 1))
+(define-eqv-test "+snan.123" (flo:make-nan #f #f 123))
+(define-eqv-test "-snan.123" (flo:make-nan #t #f 123))
+(define-eqv-test "#x+snan.123" (flo:make-nan #f #f #x123))
+(define-eqv-test "#x-snan.123" (flo:make-nan #t #f #x123))
+(define-eqv-test "#x+snan.deadbeef" (flo:make-nan #f #f #xdeadbeef))
+(define-eqv-test "#x-snan.deadbeef" (flo:make-nan #t #f #xdeadbeef))
 (define-eqv-test "+inf.0" (flo:+inf.0))
 (define-eqv-test "-inf.0" (flo:-inf.0))
 
 (define-eqv-test "#i+nan.0" (flo:make-nan #f #t 0))
 (define-eqv-test "#i-nan.0" (flo:make-nan #t #t 0))
+(define-error-test "#i+snan.0")
+(define-error-test "#i-snan.0")
 (define-eqv-test "#i+inf.0" (flo:+inf.0))
 (define-eqv-test "#i-inf.0" (flo:-inf.0))
 
 (define-error-test "#e+nan.0" expect-failure)
 (define-error-test "#e-nan.0" expect-failure)
+(define-error-test "#e+snan.0")         ;correctly errors by accident
+(define-error-test "#e-snan.0")
 (define-error-test "#e+inf.0" expect-failure)
 (define-error-test "#e-inf.0" expect-failure)
 

diff --git a/tests/runtime/test-readwrite.scm b/tests/runtime/test-readwrite.scm
index 0109790b77b3b8df49f51a32eba45d7efe2e36e2..fedc3905c90153cf12ee62d81f56e68d60a85327 100644 (file)
--- a/tests/runtime/test-readwrite.scm
+++ b/tests/runtime/test-readwrite.scm
@@ -41,8 +41,17 @@ USA.
       (body)
       (xfail body)))
 
-(define assert-nan
-  (predicate-assertion nan? "NaN"))
+(define (qnan? x)
+  (and (nan? x) (flo:nan-quiet? x)))
+
+(define assert-qnan
+  (predicate-assertion qnan? "qNaN"))
+
+(define (snan? x)
+  (and (nan? x) (not (flo:nan-quiet? x))))
+
+(define assert-snan
+  (predicate-assertion snan? "sNaN"))
 
 (define assert-inf
   (predicate-assertion infinite? "infinity"))
@@ -92,8 +101,17 @@ USA.
     ("-inf.0" ,assert-inf-)
     ("inf.0" ,assert-symbol)
     ("nan.0" ,assert-symbol)
-    ("+nan.0" ,assert-nan)
-    ("-nan.0" ,assert-nan)
+    ("+nan.0" ,assert-qnan)
+    ("-nan.0" ,assert-qnan)
+    ("+nan.1" ,assert-qnan)
+    ("-nan.1" ,assert-qnan)
+    ("+nan.123" ,assert-qnan)
+    ("-nan.123" ,assert-qnan)
+    ("snan.1" ,assert-symbol)
+    ("+snan.1" ,assert-snan)
+    ("-snan.1" ,assert-snan)
+    ("+snan.123" ,assert-snan)
+    ("-snan.123" ,assert-snan)
     ("123" ,assert-exact-integer)
     ("1/34" ,assert-exact-rational)
     ("123+456i" ,assert-complex-nonreal)
@@ -137,8 +155,17 @@ USA.
     ("-inf.0" ,assert-inf-)
     ("inf.0" ,assert-symbol)
     ("nan.0" ,assert-symbol)
-    ("+nan.0" ,assert-nan)
-    ("-nan.0" ,assert-nan)
+    ("+nan.0" ,assert-qnan)
+    ("-nan.0" ,assert-qnan)
+    ("+nan.1" ,assert-qnan)
+    ("-nan.1" ,assert-qnan)
+    ("+nan.deadbeef" ,assert-qnan)
+    ("-nan.deadbeef" ,assert-qnan)
+    ("snan.1" ,assert-symbol)
+    ("+snan.1" ,assert-snan)
+    ("-snan.1" ,assert-snan)
+    ("+snan.deadbeef" ,assert-snan)
+    ("-snan.deadbeef" ,assert-snan)
     ("#x123" ,assert-exact-integer)
     ("#x1/34" ,assert-exact-rational)
     ("#x123+456i" ,assert-complex-nonreal)
@@ -181,10 +208,14 @@ USA.
            (assert-equal string* string)))))))
 
 (define-enumerated-test 'read
-  `(("+nan.0" ,assert-nan)
-    ("-nan.0" ,assert-nan)
-    ("#i+nan.0" ,assert-nan)
-    ("#i-nan.0" ,assert-nan)
+  `(("+nan.0" ,assert-qnan)
+    ("-nan.0" ,assert-qnan)
+    ("#i+nan.0" ,assert-qnan)
+    ("#i-nan.0" ,assert-qnan)
+    ("+snan.1" ,assert-snan)
+    ("-snan.1" ,assert-snan)
+    ("#i+snan.1" ,assert-snan)
+    ("#i-snan.1" ,assert-snan)
     ("#i+inf.0" ,assert-inf+)
     ("#i-inf.0" ,assert-inf-))
   (lambda (string assertion #!optional xfail)
@@ -193,10 +224,38 @@ USA.
        (assertion (read-from-string string))))))
 
 (define-enumerated-test 'read-error
-  `(("#e+nan.0" ,expect-failure)
+  `(("+nan.deadbeef" ,expect-failure)
+    ("-nan.deadbeef" ,expect-failure)
+    ("+snan.0" ,expect-failure)
+    ("-snan.0" ,expect-failure)
+    ("+snan.deadbeef" ,expect-failure)
+    ("-snan.deadbeef" ,expect-failure)
+    ("#i+snan.0")
+    ("#i-snan.0")
+    ("#e+nan.0" ,expect-failure)
     ("#e-nan.0" ,expect-failure)
+    ("#e+nan.1" ,expect-failure)
+    ("#e-nan.1" ,expect-failure)
+    ("#e+nan.123" ,expect-failure)
+    ("#e-nan.123" ,expect-failure)
+    ("#e+nan.deadbeef")
+    ("#e-nan.deadbeef")
+    ("#e+snan.1" ,expect-failure)
+    ("#e-snan.1" ,expect-failure)
+    ("#e+snan.123" ,expect-failure)
+    ("#e-snan.123" ,expect-failure)
+    ("#e+snan.deadbeef")
+    ("#e-snan.deadbeef")
     ("#e+inf.0" ,expect-failure)
-    ("#e-inf.0" ,expect-failure))
+    ("#e-inf.0" ,expect-failure)
+    ("+inf.0+snan.0i" ,expect-failure)
+    ("+snan.0+inf.0i" ,expect-failure)
+    ("+inf.0-snan.0i" ,expect-failure)
+    ("-snan.0+inf.0i" ,expect-failure)
+    ("#x+inf.0+snan.0i")
+    ("#x+snan.0+inf.0i")
+    ("#x+inf.0-snan.0i")
+    ("#x-snan.0+inf.0i"))
   (lambda (string #!optional xfail)
     (with-expected-failure xfail
       (lambda ()