From 30dead5c07df93b21cff732fc907392bb0c631be Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Fri, 7 Dec 2018 15:51:28 +0000 Subject: [PATCH] Provide notation for NaN payload and signalling NaN. Reader has various edge cases we fail to make errors still. --- src/runtime/dragon4.scm | 5 +- src/runtime/numpar.scm | 29 +++++++++-- tests/runtime/test-numpar.scm | 22 +++++++++ tests/runtime/test-readwrite.scm | 83 +++++++++++++++++++++++++++----- 4 files changed, 122 insertions(+), 17 deletions(-) diff --git a/src/runtime/dragon4.scm b/src/runtime/dragon4.scm index e10ba1498..a4178d7ee 100644 --- 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 1c65a9e7a..1157e3ddf 100644 --- 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 ce35dc0b4..3f6c9fe7b 100644 --- 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 0109790b7..fedc3905c 100644 --- 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 () -- 2.25.1