From: Taylor R Campbell <campbell@mumble.net>
Date: Fri, 16 Nov 2018 08:02:22 +0000 (+0000)
Subject: Teach (number->string x 16) to use radix 16, base 2 exponent notation.
X-Git-Tag: mit-scheme-pucked-10.1.2~16^2~78
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9c41fb3689b6c78d5514aaa2c9798f84b72ab59e;p=mit-scheme.git

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 2155d02ab..73c69a9b9 100644
--- 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)
 
 (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 3a77ba11a..1a258c019 100644
--- 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))))
 
-(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 d019424dc..83bd9c967 100644
--- 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