From cd0975b46e46cf6edcbec977616a475df9768bf9 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 28 Jan 2005 16:48:58 +0000 Subject: [PATCH] 0.8.19.3: DELETE THE DRAGON Implement fixed-format floating point through FLONUM-TO-DIGITS. Essentially this means a whole heap of hairy logic in FLONUM-TO-STRING, and the deletion of the Steele & White Dragon algorithm. ... fixes (format nil "~@F" 1.23) ... fixes (format nil "~3F" -0.0) ... fixes (format nil "~G" 1d23) ... fixes (format nil "~E" 1d23) ... fixes bug 317 ... does not fix bug 19, which I think is not a bug ... fixes all sorts of other stuff It probably also breaks something, because test coverage of this area is definitely patchy. --- BUGS | 16 --- NEWS | 3 + src/code/print.lisp | 267 +++++++++++++++++-------------------------- src/code/target-format.lisp | 43 ++++--- tests/print.impure.lisp | 15 ++- version.lisp-expr | 2 +- 6 files changed, 148 insertions(+), 198 deletions(-) diff --git a/BUGS b/BUGS index 08a6dc8..cac2152 100644 --- a/BUGS +++ b/BUGS @@ -89,12 +89,6 @@ WORKAROUND: Perhaps any number of such consecutive lines ought to turn into a single "compiling top-level forms:" line. -19: - (I *think* this is a bug. It certainly seems like strange behavior. But - the ANSI spec is scary, dark, and deep.. -- WHN) - (FORMAT NIL "~,1G" 1.4) => "1. " - (FORMAT NIL "~3,1G" 1.4) => "1. " - 27: Sometimes (SB-EXT:QUIT) fails with Argh! maximum interrupt nesting depth (4096) exceeded, exiting @@ -1152,16 +1146,6 @@ WORKAROUND: Expected: (2 6 15 38) Got: ERROR -317: "FORMAT of floating point numbers" - reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP - test suite. - (format nil "~1F" 10) => "0." ; "10." expected - (format nil "~0F" 10) => "0." ; "10." expected - (format nil "~2F" 1234567.1) => "1000000." ; "1234567." expected - it would be nice if whatever fixed this also untangled the two - competing implementations of floating point printing (Steele and - White, and Burger and Dybvig) present in src/code/print.lisp - 318: "stack overflow in compiler warning with redefined class" reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP test suite. diff --git a/NEWS b/NEWS index 1bf195b..68ac90b 100644 --- a/NEWS +++ b/NEWS @@ -1,6 +1,9 @@ changes in sbcl-0.8.20 (0.9alpha.0?) relative to sbcl-0.8.18: * fixed disassembly of SHLD and SHRD on x86. (thanks to David Lichteblau) + * fixed bugs 19 and 317: fixed-format floating point printing is + more accurate. This also fixes a bug reported by Adam Warner + related to the ~@F format directive. * fixed some bugs related to Unicode integration: ** portions of multibyte characters at the end of buffers for character-based file input are correctly transferred to the diff --git a/src/code/print.lisp b/src/code/print.lisp index 4c945e8..d327a3d 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -1152,10 +1152,10 @@ ;;;; float printing ;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does -;;; most of the work for all printing of floating point numbers in the -;;; printer and in FORMAT. It converts a floating point number to a -;;; string in a free or fixed format with no exponent. The -;;; interpretation of the arguments is as follows: +;;; most of the work for all printing of floating point numbers in +;;; FORMAT. It converts a floating point number to a string in a free +;;; or fixed format with no exponent. The interpretation of the +;;; arguments is as follows: ;;; ;;; X - The floating point number to convert, which must not be ;;; negative. @@ -1181,9 +1181,6 @@ ;;; significance in the printed value due to a bogus choice of ;;; scale factor. ;;; -;;; Most of the optional arguments are for the benefit for FORMAT and are not -;;; used by the printer. -;;; ;;; Returns: ;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT) ;;; where the results have the following interpretation: @@ -1208,14 +1205,14 @@ ;;; representation. Furthermore, only as many digits as necessary to ;;; satisfy this condition will be printed. ;;; -;;; FLOAT-STRING actually generates the digits for positive numbers. -;;; The algorithm is essentially that of algorithm Dragon4 in "How to -;;; Print Floating-Point Numbers Accurately" by Steele and White. The -;;; current (draft) version of this paper may be found in -;;; [CMUC]tradix.press. DO NOT EVEN THINK OF ATTEMPTING TO -;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER! +;;; FLOAT-DIGITS actually generates the digits for positive numbers; +;;; see below for comments. (defun flonum-to-string (x &optional width fdigits scale fmin) + (declare (type float x)) + ;; FIXME: I think only FORMAT-DOLLARS calls FLONUM-TO-STRING with + ;; possibly-negative X. + (setf x (abs x)) (cond ((zerop x) ;; Zero is a special case which FLOAT-STRING cannot handle. (if fdigits @@ -1224,148 +1221,56 @@ (values s (length s) t (zerop fdigits) 0)) (values "." 1 t t 0))) (t - (multiple-value-bind (sig exp) (integer-decode-float x) - (let* ((precision (float-precision x)) - (digits (float-digits x)) - (fudge (- digits precision)) - (width (if width (max width 1) nil))) - (float-string (ash sig (- fudge)) (+ exp fudge) precision width - fdigits scale fmin)))))) - -(defun float-string (fraction exponent precision width fdigits scale fmin) - (let ((r fraction) (s 1) (m- 1) (m+ 1) (k 0) - (digits 0) (decpnt 0) (cutoff nil) (roundup nil) u low high - (digit-characters "0123456789") - (digit-string (make-array 50 - :element-type 'base-char - :fill-pointer 0 - :adjustable t))) - ;; Represent fraction as r/s, error bounds as m+/s and m-/s. - ;; Rational arithmetic avoids loss of precision in subsequent - ;; calculations. - (cond ((> exponent 0) - (setq r (ash fraction exponent)) - (setq m- (ash 1 exponent)) - (setq m+ m-)) - ((< exponent 0) - (setq s (ash 1 (- exponent))))) - ;; Adjust the error bounds m+ and m- for unequal gaps. - (when (= fraction (ash 1 precision)) - (setq m+ (ash m+ 1)) - (setq r (ash r 1)) - (setq s (ash s 1))) - ;; Scale value by requested amount, and update error bounds. - (when scale - (if (minusp scale) - (let ((scale-factor (expt 10 (- scale)))) - (setq s (* s scale-factor))) - (let ((scale-factor (expt 10 scale))) - (setq r (* r scale-factor)) - (setq m+ (* m+ scale-factor)) - (setq m- (* m- scale-factor))))) - ;; Scale r and s and compute initial k, the base 10 logarithm of r. - (do () - ((>= r (ceiling s 10))) - (decf k) - (setq r (* r 10)) - (setq m- (* m- 10)) - (setq m+ (* m+ 10))) - (do ()(nil) - (do () - ((< (+ (ash r 1) m+) (ash s 1))) - (setq s (* s 10)) - (incf k)) - ;; Determine number of fraction digits to generate. - (cond (fdigits - ;; Use specified number of fraction digits. - (setq cutoff (- fdigits)) - ;;don't allow less than fmin fraction digits - (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin)))) - (width - ;; Use as many fraction digits as width will permit but - ;; force at least fmin digits even if width will be - ;; exceeded. - (if (< k 0) - (setq cutoff (- 1 width)) - (setq cutoff (1+ (- k width)))) - (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin))))) - ;; If we decided to cut off digit generation before precision - ;; has been exhausted, rounding the last digit may cause a carry - ;; propagation. We can prevent this, preserving left-to-right - ;; digit generation, with a few magical adjustments to m- and - ;; m+. Of course, correct rounding is also preserved. - (when (or fdigits width) - (let ((a (- cutoff k)) - (y s)) - (if (>= a 0) - (dotimes (i a) (setq y (* y 10))) - (dotimes (i (- a)) (setq y (ceiling y 10)))) - (setq m- (max y m-)) - (setq m+ (max y m+)) - (when (= m+ y) (setq roundup t)))) - (when (< (+ (ash r 1) m+) (ash s 1)) (return))) - ;; Zero-fill before fraction if no integer part. - (when (< k 0) - (setq decpnt digits) - (vector-push-extend #\. digit-string) - (dotimes (i (- k)) - (incf digits) (vector-push-extend #\0 digit-string))) - ;; Generate the significant digits. - (do ()(nil) - (decf k) - (when (= k -1) - (vector-push-extend #\. digit-string) - (setq decpnt digits)) - (multiple-value-setq (u r) (truncate (* r 10) s)) - (setq m- (* m- 10)) - (setq m+ (* m+ 10)) - (setq low (< (ash r 1) m-)) - (if roundup - (setq high (>= (ash r 1) (- (ash s 1) m+))) - (setq high (> (ash r 1) (- (ash s 1) m+)))) - ;; Stop when either precision is exhausted or we have printed as - ;; many fraction digits as permitted. - (when (or low high (and cutoff (<= k cutoff))) (return)) - (vector-push-extend (char digit-characters u) digit-string) - (incf digits)) - ;; If cutoff occurred before first digit, then no digits are - ;; generated at all. - (when (or (not cutoff) (>= k cutoff)) - ;; Last digit may need rounding - (vector-push-extend (char digit-characters - (cond ((and low (not high)) u) - ((and high (not low)) (1+ u)) - (t (if (<= (ash r 1) s) u (1+ u))))) - digit-string) - (incf digits)) - ;; Zero-fill after integer part if no fraction. - (when (>= k 0) - (dotimes (i k) (incf digits) (vector-push-extend #\0 digit-string)) - (vector-push-extend #\. digit-string) - (setq decpnt digits)) - ;; Add trailing zeroes to pad fraction if fdigits specified. - (when fdigits - (dotimes (i (- fdigits (- digits decpnt))) - (incf digits) - (vector-push-extend #\0 digit-string))) - ;; all done - (values digit-string (1+ digits) (= decpnt 0) (= decpnt digits) decpnt))) + (multiple-value-bind (e string) + (if fdigits + (flonum-to-digits x (min (- fdigits) (- (or fmin 0)))) + (if (and width (> width 1)) + (let ((w (multiple-value-list (flonum-to-digits x (1- width) t))) + (f (multiple-value-list (flonum-to-digits x (- (or fmin 0)))))) + (cond + ((>= (length (cadr w)) (length (cadr f))) + (values-list w)) + (t (values-list f)))) + (flonum-to-digits x))) + (let ((e (+ e (or scale 0))) + (stream (make-string-output-stream))) + (if (plusp e) + (progn + (write-string string stream :end (min (length string) e)) + (dotimes (i (- e (length string))) + (write-char #\0 stream)) + (write-char #\. stream) + (write-string string stream :start (min (length string) e)) + (when fdigits + (dotimes (i (- fdigits + (- (length string) + (min (length string) e)))) + (write-char #\0 stream)))) + (progn + (write-string "." stream) + (dotimes (i (- e)) + (write-char #\0 stream)) + (write-string string stream) + (when fdigits + (dotimes (i (+ fdigits e (- (length string)))) + (write-char #\0 stream))))) + (let ((string (get-output-stream-string stream))) + (values string (length string) + (char= (char string 0) #\.) + (char= (char string (1- (length string))) #\.) + (position #\. string)))))))) ;;; implementation of figure 1 from Burger and Dybvig, 1996. As the -;;; implementation of the Dragon from Classic CMUCL (and above, -;;; FLONUM-TO-STRING) says: "DO NOT EVEN THINK OF ATTEMPTING TO -;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER!", and in this case -;;; we have to add that even reading the paper might not bring -;;; immediate illumination as CSR has attempted to turn idiomatic -;;; Scheme into idiomatic Lisp. +;;; implementation of the Dragon from Classic CMUCL (and previously in +;;; SBCL above FLONUM-TO-STRING) says: "DO NOT EVEN THINK OF +;;; ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING THE PAPER!", +;;; and in this case we have to add that even reading the paper might +;;; not bring immediate illumination as CSR has attempted to turn +;;; idiomatic Scheme into idiomatic Lisp. ;;; ;;; FIXME: figure 1 from Burger and Dybvig is the unoptimized ;;; algorithm, noticeably slow at finding the exponent. Figure 2 has -;;; an improved algorithm, but CSR ran out of energy -;;; -;;; FIXME: Burger and Dybvig also provide an algorithm for -;;; fixed-format floating point printing. If it were implemented, -;;; then we could delete the Dragon altogether (see FLONUM-TO-STRING). +;;; an improved algorithm, but CSR ran out of energy. ;;; ;;; possible extension for the enthusiastic: printing floats in bases ;;; other than base 10. @@ -1377,7 +1282,7 @@ (defconstant long-float-min-e (nth-value 1 (decode-float least-positive-long-float))) -(defun flonum-to-digits (v) +(defun flonum-to-digits (v &optional position relativep) (let ((print-base 10) ; B (float-radix 2) ; b (float-digits (float-digits v)) ; p @@ -1430,18 +1335,54 @@ (t ; (and tc1 tc2) (if (< (* r 2) s) d (1+ d)))))) (vector-push-extend (char digit-characters d) result) - (return-from generate result)))))) - (if (>= e 0) - (if (/= f (expt float-radix (1- float-digits))) - (let ((be (expt float-radix e))) - (scale (* f be 2) 2 be be)) - (let* ((be (expt float-radix e)) - (be1 (* be float-radix))) - (scale (* f be1 2) (* float-radix 2) be1 be))) - (if (or (= e min-e) (/= f (expt float-radix (1- float-digits)))) - (scale (* f 2) (* (expt float-radix (- e)) 2) 1 1) - (scale (* f float-radix 2) - (* (expt float-radix (- 1 e)) 2) float-radix 1)))))))) + (return-from generate result))))) + (initialize () + (let (r s m+ m-) + (if (>= e 0) + (let* ((be (expt float-radix e)) + (be1 (* be float-radix))) + (if (/= f (expt float-radix (1- float-digits))) + (setf r (* f be 2) + s 2 + m+ be + m- be) + (setf r (* f be1 2) + s (* float-radix 2) + m+ be1 + m- be))) + (if (or (= e min-e) + (/= f (expt float-radix (1- float-digits)))) + (setf r (* f 2) + s (* (expt float-radix (- e)) 2) + m+ 1 + m- 1) + (setf r (* f float-radix 2) + s (* (expt float-radix (- 1 e)) 2) + m+ float-radix + m- 1))) + (when position + (when relativep + (aver (> position 0)) + (do ((k 0 (1+ k)) + ;; running out of letters here + (l 1 (* l print-base))) + ((>= (* s l) (+ r m+)) + ;; k is now \hat{k} + (if (< (+ r (* s (/ (expt print-base (- k position)) 2))) + (* s (expt print-base k))) + (setf position (- k position)) + (setf position (- k position 1)))))) + (let ((low (max m- (/ (* s (expt print-base position)) 2))) + (high (max m+ (/ (* s (expt print-base position)) 2)))) + (when (<= m- low) + (setf m- low) + (setf low-ok t)) + (when (<= m+ high) + (setf m+ high) + (setf high-ok t)))) + (values r s m+ m-)))) + (multiple-value-bind (r s m+ m-) (initialize) + (scale r s m+ m-))))))) ;;; Given a non-negative floating point number, SCALE-EXPONENT returns ;;; a new floating point number Z in the range (0.1, 1.0] and an diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index d05cb98..b15183f 100644 --- a/src/code/target-format.lisp +++ b/src/code/target-format.lisp @@ -494,16 +494,17 @@ ;;; We return true if we overflowed, so that ~G can output the overflow char ;;; instead of spaces. (defun format-fixed-aux (stream number w d k ovf pad atsign) + (declare (type float number)) (cond - ((or (not (or w d)) - (and (floatp number) - (or (float-infinity-p number) - (float-nan-p number)))) + ((and (floatp number) + (or (float-infinity-p number) + (float-nan-p number))) (prin1 number stream) nil) (t (let ((spaceleft w)) - (when (and w (or atsign (minusp number))) (decf spaceleft)) + (when (and w (or atsign (minusp (float-sign number)))) + (decf spaceleft)) (multiple-value-bind (str len lpoint tpoint) (sb!impl::flonum-to-string (abs number) spaceleft d k) ;;if caller specifically requested no fraction digits, suppress the @@ -527,7 +528,7 @@ t) (t (when w (dotimes (i spaceleft) (write-char pad stream))) - (if (minusp number) + (if (minusp (float-sign number)) (write-char #\- stream) (if atsign (write-char #\+ stream))) (when lpoint (write-char #\0 stream)) @@ -580,9 +581,9 @@ ;;; silent here, so let's just print out infinities and NaN's instead ;;; of causing an error. (defun format-exp-aux (stream number w d e k ovf pad marker atsign) - (if (and (floatp number) - (or (float-infinity-p number) - (float-nan-p number))) + (declare (type float number)) + (if (or (float-infinity-p number) + (float-nan-p number)) (prin1 number stream) (multiple-value-bind (num expt) (sb!impl::scale-exponent (abs number)) (let* ((expt (- expt k)) @@ -592,29 +593,35 @@ (fmin (if (minusp k) (- 1 k) nil)) (spaceleft (if w (- w 2 elen - (if (or atsign (minusp number)) + (if (or atsign (minusp (float-sign number))) 1 0)) nil))) (if (and w ovf e (> elen e)) ;exponent overflow (dotimes (i w) (write-char ovf stream)) - (multiple-value-bind (fstr flen lpoint) + (multiple-value-bind (fstr flen lpoint tpoint) (sb!impl::flonum-to-string num spaceleft fdig k fmin) + (when (and d (zerop d)) (setq tpoint nil)) (when w (decf spaceleft flen) (when lpoint + (if (or (> spaceleft 0) tpoint) + (decf spaceleft) + (setq lpoint nil))) + (when tpoint (if (> spaceleft 0) (decf spaceleft) - (setq lpoint nil)))) + (setq tpoint nil)))) (cond ((and w (< spaceleft 0) ovf) ;;significand overflow (dotimes (i w) (write-char ovf stream))) (t (when w (dotimes (i spaceleft) (write-char pad stream))) - (if (minusp number) + (if (minusp (float-sign number)) (write-char #\- stream) (if atsign (write-char #\+ stream))) (when lpoint (write-char #\0 stream)) (write-string fstr stream) + (when tpoint (write-char #\0 stream)) (write-char (if marker marker (format-exponent-marker number)) @@ -651,9 +658,9 @@ ;;; Raymond Toy writes: same change as for format-exp-aux (defun format-general-aux (stream number w d e k ovf pad marker atsign) - (if (and (floatp number) - (or (float-infinity-p number) - (float-nan-p number))) + (declare (type float number)) + (if (or (float-infinity-p number) + (float-nan-p number)) (prin1 number stream) (multiple-value-bind (ignore n) (sb!impl::scale-exponent (abs number)) (declare (ignore ignore)) @@ -692,7 +699,9 @@ ;; thing, and at least the user shouldn't be surprised. (setq number (coerce number 'single-float))) (if (floatp number) - (let* ((signstr (if (minusp number) "-" (if atsign "+" ""))) + (let* ((signstr (if (minusp (float-sign number)) + "-" + (if atsign "+" ""))) (signlen (length signstr))) (multiple-value-bind (str strlen ig2 ig3 pointplace) (sb!impl::flonum-to-string number nil d nil) diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp index ab25c65..4fbe7c1 100644 --- a/tests/print.impure.lisp +++ b/tests/print.impure.lisp @@ -315,7 +315,20 @@ ;;; CSR inserted a bug into Burger & Dybvig's float printer. Caught ;;; by Raymond Toy -(assert (string= (format nil "~F" 1d23) "1.0d+23")) +(assert (string= (format nil "~E" 1d23) "1.0d+23")) + +;;; Fixed-format bugs from CLISP's test suite (reported by Bruno +;;; Haible, bug 317) +(assert (string= (format nil "~1F" 10) "10.")) +(assert (string= (format nil "~0F" 10) "10.")) +(assert (string= (format nil "~2F" 1234567.1) "1234567.")) + +;;; here's one that seems to fail most places. I think this is right, +;;; and most of the other answers I've seen are definitely wrong. +(assert (string= (format nil "~G" 1d23) "100000000000000000000000. ")) + +;;; Adam Warner's test case +(assert (string= (format nil "~@F" 1.23) "+1.23")) ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 5e928f5..c99b334 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.19.2" +"0.8.19.3" -- 1.7.10.4