Teach (number->string x 16) to use radix 16, base 2 exponent notation.

diff --git a/src/runtime/dragon4.scm b/src/runtime/dragon4.scm
index 2155d02ab2b00d80d902071de4fe7edd586fea0f..73c69a9b9ba7fc692170e4826621ac4212ef1d36 100644 (file)
--- a/src/runtime/dragon4.scm
+++ b/src/runtime/dragon4.scm
@@ -66,41 +66,44 @@ not much different to numbers within a few orders of magnitude of 1.
   unspecific)
 \f
 (define (flo:->string x radix)
-  (let ((x>0
-        (lambda (x)
-          (let ((p flo:significand-digits-base-2))
-            (call-with-values (lambda () (dragon4-normalize x p))
-              (lambda (f e)
-                (call-with-values flonum-printer-cutoff-args
-                  (lambda (cutoff-mode cutoff display-procedure)
-                    (dragon4 f e p radix cutoff-mode cutoff
-                      (lambda (u k generate)
-                        (let ((digits
-                               (list->string
-                                (let loop ((u u) (k k) (generate generate))
-                                  k    ;ignore
-                                  (if (negative? u)
-                                      '()
-                                      (cons (digit->char u radix)
-                                            (generate loop)))))))
-                          (display-procedure digits k radix))))))))))))
-    (or (and flonum-printer-hook
-            (flonum-printer-hook x radix))
-       (cond ((flo:nan? x)
-              (string-copy "+nan.0"))
-             ((flo:positive? x)
+  (define (x>0 x signify)
+    (let ((p flo:significand-digits-base-2))
+      (call-with-values flonum-printer-cutoff-args
+       (lambda (cutoff-mode cutoff display-procedure)
+         (if (int:= radix #x10)
+             (string-append "#x" (signify (ieee754-binary64-hex-string x "")))
+             (signify
+              (call-with-values (lambda () (dragon4-normalize x p))
+                (lambda (f e)
+                  (dragon4 f e p radix cutoff-mode cutoff
+                    (lambda (u k generate)
+                      (let ((digits
+                             (list->string
+                              (let loop
+                                  ((u u) (k k) (generate generate))
+                                k      ;ignore
+                                (if (negative? u)
+                                    '()
+                                    (cons (digit->char u radix)
+                                          (generate loop)))))))
+                        (display-procedure digits k radix))))))))))))
+  (or (and flonum-printer-hook
+          (flonum-printer-hook x radix))
+      (cond ((flo:nan? x)
+            (string-copy "+nan.0"))
+           ((flo:positive? x)
+            (if (flo:infinite? x)
+                (string-copy "+inf.0")
+                (x>0 x (lambda (s) s))))
+           ((flo:negative? x)
+            (let ((x (flo:negate x)))
               (if (flo:infinite? x)
-                  (string-copy "+inf.0")
-                  (x>0 x)))
-             ((flo:negative? x)
-              (let ((x (flo:negate x)))
-                (if (flo:infinite? x)
-                    (string-copy "-inf.0")
-                    (string-append "-" (x>0 x)))))
-             ((flo:zero? x)
-              (string-copy (if (flo:safe-negative? x) "-0." "0.")))
-             (else
-              (string-copy "+nan.0"))))))
+                  (string-copy "-inf.0")
+                  (x>0 x (lambda (s) (string-append "-" s))))))
+           ((flo:zero? x)
+            (string-copy (if (flo:safe-negative? x) "-0." "0.")))
+           (else
+            (string-copy "+nan.0")))))
 
 (define (flonum-printer:normal-output digits k radix)
   (let ((k+1 (+ k 1)))

diff --git a/src/runtime/ieee754.scm b/src/runtime/ieee754.scm
index 3a77ba11a919c3033b3656140044f72cb002a9c5..1a258c019f3c1ee60301b85a408ab1697e704e12 100644 (file)
--- a/src/runtime/ieee754.scm
+++ b/src/runtime/ieee754.scm
@@ -196,7 +196,7 @@ USA.
               (decompose-ieee754-binary64 x)
        (compose-ieee754-binary128 sign biased-exponent trailing-significand))))
 \f
-(define (ieee754-binary-hex-string x exponent-bits precision)
+(define (ieee754-binary-hex-string x exponent-bits precision #!optional mark)
   (receive (base emin emax bias exp-subnormal exp-inf/nan)
            (ieee754-binary-parameters exponent-bits precision)
     bias exp-subnormal exp-inf/nan
@@ -215,8 +215,9 @@ USA.
             (fractional
              (if (zero? fractional) "" (number->string fractional #x10)))
             (expsign (if (< exponent 0) "-" "+"))
-            (exponent (number->string (abs exponent) #d10)))
-        (string-append sign "0x" integer dot fractional "p" expsign exponent)))
+            (exponent (number->string (abs exponent) #d10))
+            (mark (if (default-object? mark) "0x" mark)))
+        (string-append sign mark integer dot fractional "p" expsign exponent)))
     (decompose-ieee754 x base emax precision
       (lambda (sign)                    ;if-zero
         (numeric sign 0 0 0))
@@ -243,14 +244,14 @@ USA.
       (lambda (sign quiet payload)
         (symbolic sign (if (zero? quiet) "sNaN" "qNaN") payload)))))
 
-(define (ieee754-binary32-hex-string x)
-  (ieee754-binary-hex-string x 8 24))
+(define (ieee754-binary32-hex-string x #!optional mark)
+  (ieee754-binary-hex-string x 8 24 mark))
 
-(define (ieee754-binary64-hex-string x)
-  (ieee754-binary-hex-string x 11 53))
+(define (ieee754-binary64-hex-string x #!optional mark)
+  (ieee754-binary-hex-string x 11 53 mark))
 
-(define (ieee754-binary128-hex-string x)
-  (ieee754-binary-hex-string x 15 113))
+(define (ieee754-binary128-hex-string x #!optional mark)
+  (ieee754-binary-hex-string x 15 113 mark))
 
 (define (round-up x n)
   (* n (quotient (+ x (- n 1)) n)))

diff --git a/tests/runtime/test-dragon4.scm b/tests/runtime/test-dragon4.scm
index d019424dc5ba020faa1311bcc39ecdecc3d39026..83bd9c967a2fc1e08fe8da1acc0c91ae00b46a0a 100644 (file)
--- a/tests/runtime/test-dragon4.scm
+++ b/tests/runtime/test-dragon4.scm
@@ -80,4 +80,23 @@ USA.
     (try 0.00500   '(absolute  2 normal) ".01") ; (rounds up in binary)
     (try 0.00501   '(absolute  2 normal) ".01")
     (try 0.00499   '(absolute -3 normal) "0.")
-    ))
\ No newline at end of file
+    ))
+
+(define (define-hex-tests name . cases)
+  (define-test name
+    (map (lambda (case0)
+           (let ((x (car case0))
+                 (s (cadr case0)))
+             (lambda ()
+               (assert-string= (number->string x #x10) s))))
+         cases)))
+
+(define-hex-tests 'hex
+  '(0. "0.")
+  '(-0. "-0.")
+  '(1. "#x1p+0")
+  '(-1. "#x-1p+0")
+  '(1.5 "#x1.8p+0")
+  '(-1.5 "#x-1.8p+0")
+  '(15. "#x1.ep+3")
+  '(16. "#x1p+4"))
\ No newline at end of file