From: Taylor R Campbell <campbell@mumble.net>
Date: Fri, 30 Nov 2018 18:06:44 +0000 (+0000)
Subject: Implement and fix fenceposts in inf and NaN encoding.
X-Git-Tag: mit-scheme-pucked-10.1.7~3^2~82
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7f120815a76607b4bacdf7340ec6b38aac29e33b;p=mit-scheme.git

Implement and fix fenceposts in inf and NaN encoding.
---

diff --git a/src/runtime/ieee754.scm b/src/runtime/ieee754.scm
index d878fb966..9ca331c27 100644
--- a/src/runtime/ieee754.scm
+++ b/src/runtime/ieee754.scm
@@ -46,28 +46,27 @@ USA.
 (define (decompose-ieee754-binary x exponent-bits precision)
   (receive (base emin emax bias exp-subnormal exp-inf/nan)
            (ieee754-binary-parameters exponent-bits precision)
-    (decompose-ieee754 x base emax precision
-      (lambda (sign)                    ;if-zero
-        (values sign 0 0))
-      (lambda (sign significand)        ;if-subnormal
-        (assert (= 0 (shift-right significand (- precision 1))))
-        (values sign (+ exp-subnormal bias) significand))
-      (lambda (sign exponent significand) ;if-normal
-        (assert (<= emin exponent emax))
-        ;; The integer part is always 1.  Strip it for the binary
-        ;; interchange format.
-        (assert (= 1 (shift-right significand (- precision 1))))
-        (values sign
-                (+ exponent bias)
-                (extract-bit-field (- precision 1) 0 significand)))
-      (lambda (sign)                    ;if-infinite
-        (values sign exp-inf/nan 0))
-      (lambda (sign quiet payload)      ;if-nan
-        (assert (not (and (zero? quiet) (zero? payload))))
-        (assert (zero? (extract-bit-field (- precision 1) 1 payload)))
-        (values sign
-                exp-inf/nan
-                (replace-bit-field (- precision 1) 1 payload quiet))))))
+    (let ((t (- precision 1)))
+      (decompose-ieee754 x base emax precision
+        (lambda (sign)                  ;if-zero
+          (values sign 0 0))
+        (lambda (sign significand)      ;if-subnormal
+          (assert (= 0 (shift-right significand t)))
+          (values sign (+ exp-subnormal bias) significand))
+        (lambda (sign exponent significand) ;if-normal
+          (assert (<= emin exponent emax))
+          ;; The integer part is always 1.  Strip it for the binary
+          ;; interchange format.
+          (assert (= 1 (shift-right significand t)))
+          (values sign (+ exponent bias) (extract-bit-field t 0 significand)))
+        (lambda (sign)                  ;if-infinite
+          (values sign (+ exp-inf/nan bias) 0))
+        (lambda (sign quiet payload)    ;if-nan
+          (assert (not (and (zero? quiet) (zero? payload))))
+          (assert (zero? (extract-bit-field 1 (- t 1) payload)))
+          (values sign
+                  (+ exp-inf/nan bias)
+                  (replace-bit-field 1 (- t 1) payload quiet)))))))
 
 (define (ieee754-sign x)
   (cond ((< 0 x) 0)
@@ -82,12 +81,9 @@ USA.
 (define (decompose-ieee754 x base emax precision
           if-zero if-subnormal if-normal if-infinite if-nan)
   (cond ((not (= x x))
-         ;; There are, of course, b^p different NaNs.  There is no
-         ;; obvious way to computationally detect the sign of a NaN,
-         ;; and no portable way to get at the quiet bit or the payload
-         ;; bits, so we'll just assume every NaN is a trivial positive
-         ;; signalling NaN and hope the caller has a good story...
-         (if-nan 0 0 1))
+         (if-nan (if (flo:sign-negative? x) 1 0)
+                 (if (flo:nan-quiet? x) 1 0)
+                 (flo:nan-payload x)))
         ((and (< 1 (abs x)) (= x (/ x 2)))
          (if-infinite (if (< 0. x) 0 1)))
         (else
@@ -138,9 +134,9 @@ USA.
             ((= exponent exp-inf/nan)
              (if (zero? trailing-significand)
                  (compose-ieee754-infinity sign)
-                 (let ((quiet   (extract-bit-field 1 t trailing-significand))
-                       (payload (extract-bit-field t 0 trailing-significand)))
-                   (compose-ieee754-nan sign quiet payload))))
+                 (let ((q (extract-bit-field 1 (- t 1) trailing-significand))
+                       (p (extract-bit-field (- t 1) 0 trailing-significand)))
+                   (compose-ieee754-nan sign q p))))
             (else
              (assert (<= emin exponent emax))
              (let ((significand
@@ -165,8 +161,12 @@ USA.
      (flo:+inf.0)))
 
 (define (compose-ieee754-nan sign quiet payload)
-  (declare (ignore sign quiet payload))
-  (flo:nan.0))
+  ;; XXX Using the native microcode's idea of NaN is a little hokey:
+  ;; if, for example, we wanted to use this for cross-compilation of
+  ;; a Scheme with binary128 floating-point using a Scheme with
+  ;; binary64 floating-point, many NaNs that could appear in the
+  ;; source code would be unrepresentable in the host.
+  (flo:make-nan (= sign 1) (= quiet 1) payload))
 
 (define (ieee754-binary-parameters exponent-bits precision)
   (assert (zero? (modulo (+ exponent-bits precision) 32)))
diff --git a/tests/runtime/test-ieee754.scm b/tests/runtime/test-ieee754.scm
index 4b36d8363..c71e364d6 100644
--- a/tests/runtime/test-ieee754.scm
+++ b/tests/runtime/test-ieee754.scm
@@ -43,23 +43,19 @@ USA.
 (define ((test-ieee754-roundtrip exponent-bits precision
                                  compose exact? decompose)
          bits)
-  (receive (base emin emax bias exp-subnormal exp-inf/nan)
-           (ieee754-binary-parameters exponent-bits precision)
-    base emin emax exp-subnormal
-    (let ((w exponent-bits)             ;Width of exponent
-          (t (- precision 1)))          ;Trailing significand width
-      (let ((sign (extract-bit-field 1 (+ w t) bits))
-            (biased-exponent (extract-bit-field w t bits))
-            (trailing-significand (extract-bit-field t 0 bits)))
-        (if (not (= (- biased-exponent bias) exp-inf/nan))
-            (let ((x (compose sign biased-exponent trailing-significand)))
-              (assert (exact? x))
-              ;; Confirm that it yields the same bits.
-              (receive (sign* biased-exponent* trailing-significand*)
-                       (decompose x)
-                (assert-= sign* sign)
-                (assert-= biased-exponent* biased-exponent)
-                (assert-= trailing-significand* trailing-significand))))))))
+  (let ((w exponent-bits)             ;Width of exponent
+        (t (- precision 1)))          ;Trailing significand width
+    (let ((sign (extract-bit-field 1 (+ w t) bits))
+          (biased-exponent (extract-bit-field w t bits))
+          (trailing-significand (extract-bit-field t 0 bits)))
+      (let ((x (compose sign biased-exponent trailing-significand)))
+        (assert (or (not (finite? x)) (exact? x)))
+        ;; Confirm that it yields the same bits.
+        (receive (sign* biased-exponent* trailing-significand*)
+                 (decompose x)
+          (assert-= sign* sign)
+          (assert-= biased-exponent* biased-exponent)
+          (assert-= trailing-significand* trailing-significand))))))
 
 (define-test 'binary32-roundtrip-exhaustive
   (lambda ()
@@ -110,7 +106,9 @@ USA.
     (-2 (normal - 1 #x10000000000000))
     (,(flo:+inf.0) (infinity +))
     (,(flo:-inf.0) (infinity -))
-    (,(flo:nan.0) (nan + s 1)))
+    (,(flo:qnan 12345) (nan + q 12345))
+    (,(flo:snan 54321) (nan + s 54321))
+    (,(flo:make-nan #t #t 0) (nan - q 0)))
   (lambda (x y)
     (define (signify sign)
       (case sign