Fix broken hexadecimal floating-point printing.

diff --git a/src/runtime/ieee754.scm b/src/runtime/ieee754.scm
index 1a258c019f3c1ee60301b85a408ab1697e704e12..d878fb9669e36013276f6e9a3b8636dd66e253a4 100644 (file)
--- a/src/runtime/ieee754.scm
+++ b/src/runtime/ieee754.scm
@@ -205,40 +205,57 @@ USA.
       (assert (<= 0 extra))
       (let ((extra (number->string extra #x10)))
         (string-append (if (zero? sign) "+" "-") name "." extra)))
-    (define (numeric sign integer fractional exponent)
+    (define (numeric sign integer width fractional exponent)
       (assert (or (= sign 0) (= sign 1)))
       (assert (or (= integer 0) (= integer 1)))
       (assert (<= 0 fractional))
       (let ((sign (if (zero? sign) "" "-"))
             (integer (if (zero? integer) "0" "1"))
             (dot (if (zero? fractional) "" "."))
-            (fractional
-             (if (zero? fractional) "" (number->string fractional #x10)))
+            (frac (if (zero? fractional) "" (format-frac width fractional)))
             (expsign (if (< exponent 0) "-" "+"))
             (exponent (number->string (abs exponent) #d10))
             (mark (if (default-object? mark) "0x" mark)))
-        (string-append sign mark integer dot fractional "p" expsign exponent)))
+        (string-append sign mark integer dot frac "p" expsign exponent)))
+    (define (format-frac width fractional)
+      (assert (not (zero? fractional)))
+      (assert (<= (integer-length fractional) width))
+      (receive (width fractional)
+               (let ((misalign (remainder width 4)))
+                 (if (zero? misalign)
+                     (values width fractional)
+                     (let ((s (- 4 misalign)))
+                       (values (+ width s) (shift-left fractional s)))))
+        (assert (<= (integer-length fractional) width))
+        (receive (width fractional)
+                 (let* ((lsb (first-set-bit fractional))
+                        (lo-zeros (quotient lsb 4))
+                        (s (* 4 lo-zeros)))
+                   (values (- width s) (shift-right fractional s)))
+          (assert (<= (integer-length fractional) width))
+          (let ((hi-zeros (quotient (- width (integer-length fractional)) 4)))
+            (string-append (make-string hi-zeros #\0)
+                           (number->string fractional #x10))))))
     (decompose-ieee754 x base emax precision
       (lambda (sign)                    ;if-zero
-        (numeric sign 0 0 0))
+        (numeric sign 0 0 0 0))
       (lambda (sign significand)        ;if-subnormal
         (assert (< 0 significand))
         (assert (= 0 (shift-right significand (- precision 1))))
-        (let ((start (first-set-bit significand))
-              (end (integer-length significand)))
-          (let ((fracbits (- (- end 1) start)))
-            (let ((exponent (- emin (- precision end)))
-                  ;; Strip the integer part (1) and the trailing zeros.
-                  (fractional
-                   (extract-bit-field fracbits start significand)))
-              (numeric sign 1 fractional exponent)))))
+        ;; Find the position of the 1 bit.
+        (let* ((msb (integer-length significand))
+               (width (- msb 1)))
+          ;; Extract bits below that, and subtract the from the exponent.
+          (let ((fractional (extract-bit-field width 0 significand))
+                (exponent (- emin (- precision msb))))
+            (numeric sign 1 width fractional exponent))))
       (lambda (sign exponent significand)
         (assert (< 0 significand))
         (assert (= 1 (shift-right significand (- precision 1))))
-        (let ((useless-zeros (round-down (first-set-bit significand) 4))
-              (fractional
-               (extract-bit-field (- precision 1) 0 significand)))
-          (numeric sign 1 (shift-right fractional useless-zeros) exponent)))
+        ;; We know where the 1 bit is.
+        (let* ((width (- precision 1))
+               (fractional (extract-bit-field width 0 significand)))
+          (numeric sign 1 width fractional exponent)))
       (lambda (sign)
         (symbolic sign "inf" 0))
       (lambda (sign quiet payload)

diff --git a/tests/runtime/test-ieee754.scm b/tests/runtime/test-ieee754.scm
index 9dd060979f581a9daf36bd0d8efb6e775dc44af3..4f78ec105f003edd87b86ba0af80655159bed356 100644 (file)
--- a/tests/runtime/test-ieee754.scm
+++ b/tests/runtime/test-ieee754.scm
@@ -139,42 +139,22 @@ USA.
 (define-enumerated-test 'ieee754-binary64-hex
   `((0 "0x0p+0")
     (-0. "-0x0p+0")
-    (,(+ (expt 2 -1050) (* (expt 16 -2) (expt 2 -1050)))
-     "0x1.01p-1050"
-     ,expect-failure)
-    (,(- (+ (expt 2 -1050) (* (expt 16 -2) (expt 2 -1050))))
-     "-0x1.01p-1050"
-     ,expect-failure)
-    (,(+ (expt 2 -1022) (expt 2 -1074))
-     "0x1.0000000000001p-1022"
-     ,expect-failure)
-    (,(- (+ (expt 2 -1022) (expt 2 -1074)))
-     "-0x1.0000000000001p-1022"
-     ,expect-failure)
-    (,(+ (expt 2 -1021) (expt 2 -1073))
-     "0x1.0000000000001p-1021"
-     ,expect-failure)
-    (,(- (+ (expt 2 -1021) (expt 2 -1073)))
-     "-0x1.0000000000001p-1021"
-     ,expect-failure)
-    (,(+ (expt 2 -1021) (expt 2 -1072))
-     "0x1.0000000000002p-1021"
-     ,expect-failure)
-    (,(+ (expt 2 -1021) (expt 2 -1071))
-     "0x1.0000000000004p-1021"
-     ,expect-failure)
-    (,(+ (expt 2 -1021) (expt 2 -1070))
-     "0x1.0000000000008p-1021"
-     ,expect-failure)
-    (,(+ (expt 2 -1021) (expt 2 -1069))
-     "0x1.000000000001p-1021"
-     ,expect-failure)
+    (,(+ (expt 2 -1050) (* (expt 16 -2) (expt 2 -1050))) "0x1.01p-1050")
+    (,(- (+ (expt 2 -1050) (* (expt 16 -2) (expt 2 -1050)))) "-0x1.01p-1050")
+    (,(+ (expt 2 -1022) (expt 2 -1074)) "0x1.0000000000001p-1022")
+    (,(- (+ (expt 2 -1022) (expt 2 -1074))) "-0x1.0000000000001p-1022")
+    (,(+ (expt 2 -1021) (expt 2 -1073)) "0x1.0000000000001p-1021")
+    (,(- (+ (expt 2 -1021) (expt 2 -1073))) "-0x1.0000000000001p-1021")
+    (,(+ (expt 2 -1021) (expt 2 -1072)) "0x1.0000000000002p-1021")
+    (,(+ (expt 2 -1021) (expt 2 -1071)) "0x1.0000000000004p-1021")
+    (,(+ (expt 2 -1021) (expt 2 -1070)) "0x1.0000000000008p-1021")
+    (,(+ (expt 2 -1021) (expt 2 -1069)) "0x1.000000000001p-1021")
     (1/2 "0x1p-1")
     (-1/2 "-0x1p-1")
     (1 "0x1p+0")
     (-1 "-0x1p+0")
-    (257/256 "0x1.01p+0" ,expect-failure)
-    (-257/256 "-0x1.01p+0" ,expect-failure)
+    (257/256 "0x1.01p+0")
+    (-257/256 "-0x1.01p+0")
     (12345 "0x1.81c8p+13")
     (123456 "0x1.e24p+16")
     (1.2061684984132626e-11 "0x1.a862p-37"))