From 9c41fb3689b6c78d5514aaa2c9798f84b72ab59e Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Fri, 16 Nov 2018 08:02:22 +0000 Subject: [PATCH] Teach (number->string x 16) to use radix 16, base 2 exponent notation. --- src/runtime/dragon4.scm | 71 ++++++++++++++++++---------------- src/runtime/ieee754.scm | 19 ++++----- tests/runtime/test-dragon4.scm | 21 +++++++++- 3 files changed, 67 insertions(+), 44 deletions(-) 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 -- 2.25.1