From: Taylor R Campbell Date: Fri, 30 Nov 2018 17:42:04 +0000 (+0000) Subject: Fix broken hexadecimal floating-point printing. X-Git-Tag: mit-scheme-pucked-10.1.7~3^2~84 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ca195e451a74636ca802d4620216784c4e86fff2;p=mit-scheme.git Fix broken hexadecimal floating-point printing. --- diff --git a/src/runtime/ieee754.scm b/src/runtime/ieee754.scm index 1a258c019..d878fb966 100644 --- 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 9dd060979..4f78ec105 100644 --- 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"))