From d6d76c98535bddabd73c6338f8393b6e698f297f Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 8 Nov 2005 20:31:34 +0000 Subject: [PATCH] 0.9.6.34: Merge floating point printing patch from Simon Alexander ... enough peer review is enough. --- NEWS | 2 + src/code/print.lisp | 33 +++++++++------ src/code/target-format.lisp | 93 ++++++++++++++++++++++++------------------- tests/print.impure.lisp | 37 ++++++++++++++++- version.lisp-expr | 2 +- 5 files changed, 111 insertions(+), 56 deletions(-) diff --git a/NEWS b/NEWS index 0e3aec8..73fc7a7 100644 --- a/NEWS +++ b/NEWS @@ -20,6 +20,8 @@ changes in sbcl-0.9.7 relative to sbcl-0.9.6: * bug fix: the dependent update protocol now works for generic functions. (thanks to Gerd Moellmann; reported by Bruno Haible and Pascal Costanza) + * bug fix: floating point printing is more accurate in some + circumstances. (thanks to Simon Alexander) * bug fix: *COMPILE-FILE-PATHNAME* now contains the user's pathname merged with *DEFAULT-PATHNAME-DEFAULTS*. * bug fix: callbacks on OS X now preserve stack-alignment. diff --git a/src/code/print.lisp b/src/code/print.lisp index aa060d6..9d2ea8e 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -1140,10 +1140,19 @@ (t (multiple-value-bind (e string) (if fdigits - (flonum-to-digits x (min (- fdigits) (- (or fmin 0)))) + (flonum-to-digits x (min (- (+ fdigits (or scale 0))) + (- (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)))))) + (let ((w (multiple-value-list + (flonum-to-digits x + (max 1 + (+ (1- width) + (if (and scale (minusp scale)) + scale 0))) + t))) + (f (multiple-value-list + (flonum-to-digits x (- (+ (or fmin 0) + (if scale scale 0))))))) (cond ((>= (length (cadr w)) (length (cadr f))) (values-list w)) @@ -1153,11 +1162,13 @@ (stream (make-string-output-stream))) (if (plusp e) (progn - (write-string string stream :end (min (length string) e)) + (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)) + (write-string string stream :start (min (length + string) e)) (when fdigits (dotimes (i (- fdigits (- (length string) @@ -1375,18 +1386,17 @@ ;;; Print the appropriate exponent marker for X and the specified exponent. (defun print-float-exponent (x exp stream) (declare (type float x) (type integer exp) (type stream stream)) - (let ((*print-radix* nil) - (plusp (plusp exp))) + (let ((*print-radix* nil)) (if (typep x *read-default-float-format*) (unless (eql exp 0) - (format stream "e~:[~;+~]~D" plusp exp)) - (format stream "~C~:[~;+~]~D" + (format stream "e~D" exp)) + (format stream "~C~D" (etypecase x (single-float #\f) (double-float #\d) (short-float #\s) (long-float #\L)) - plusp exp)))) + exp)))) (defun output-float-infinity (x stream) (declare (float x) (stream stream)) @@ -1429,6 +1439,7 @@ (print-float-exponent x 0 stream)) (t (output-float-aux x stream -3 8))))))) + (defun output-float-aux (x stream e-min e-max) (multiple-value-bind (e string) (flonum-to-digits x) @@ -1453,8 +1464,6 @@ (t (write-string string stream :end 1) (write-char #\. stream) (write-string string stream :start 1) - (when (= (length string) 1) - (write-char #\0 stream)) (print-float-exponent x (1- e) stream))))) ;;;; other leaf objects diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index 0106059..91b8309 100644 --- a/src/code/target-format.lisp +++ b/src/code/target-format.lisp @@ -589,49 +589,58 @@ (let* ((expt (- expt k)) (estr (decimal-string (abs expt))) (elen (if e (max (length estr) e) (length estr))) - (fdig (if d (if (plusp k) (1+ (- d k)) d) nil)) - (fmin (if (minusp k) (- 1 k) nil)) - (spaceleft (if w - (- w 2 elen - (if (or atsign (minusp (float-sign number))) - 1 0)) - nil))) - (if (and w ovf e (> elen e)) ;exponent overflow + spaceleft) + (when w + (setf spaceleft (- w 2 elen)) + (when (or atsign (minusp (float-sign number))) + (decf spaceleft))) + (if (and w ovf e (> elen e)) ;exponent overflow (dotimes (i w) (write-char ovf stream)) - (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 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 (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)) - stream) - (write-char (if (minusp expt) #\- #\+) stream) - (when e - ;;zero-fill before exponent if necessary - (dotimes (i (- e (length estr))) - (write-char #\0 stream))) - (write-string estr stream))))))))) + (let* ((fdig (if d (if (plusp k) (1+ (- d k)) d) nil)) + (fmin (if (minusp k) 1 fdig))) + (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) + ;; See CLHS 22.3.3.2. "If the parameter d is + ;; omitted, ... [and] if the fraction to be + ;; printed is zero then a single zero digit should + ;; appear after the decimal point." So we need to + ;; subtract one from here because we're going to + ;; add an extra 0 digit later. [rtoy] + (when (and (zerop number) (null d)) + (decf spaceleft)) + (when lpoint + (if (or (> spaceleft 0) tpoint) + (decf spaceleft) + (setq lpoint nil))) + (when (and tpoint (<= spaceleft 0)) + (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 (float-sign number)) + (write-char #\- stream) + (if atsign (write-char #\+ stream))) + (when lpoint (write-char #\0 stream)) + (write-string fstr stream) + (when (and (zerop number) (null d)) + ;; It's later and we're adding the zero + ;; digit. + (write-char #\0 stream)) + (write-char (if marker + marker + (format-exponent-marker number)) + stream) + (write-char (if (minusp expt) #\- #\+) stream) + (when e + ;;zero-fill before exponent if necessary + (dotimes (i (- e (length estr))) + (write-char #\0 stream))) + (write-string estr stream)))))))))) (def-format-interpreter #\G (colonp atsignp params) (when colonp diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp index a54996e..c6b23e9 100644 --- a/tests/print.impure.lisp +++ b/tests/print.impure.lisp @@ -322,7 +322,7 @@ ;;; CSR inserted a bug into Burger & Dybvig's float printer. Caught ;;; by Raymond Toy -(assert (string= (format nil "~E" 1d23) "1.0d+23")) +(assert (string= (format nil "~E" 1d23) "1.d+23")) ;;; Fixed-format bugs from CLISP's test suite (reported by Bruno ;;; Haible, bug 317) @@ -337,6 +337,41 @@ ;;; Adam Warner's test case (assert (string= (format nil "~@F" 1.23) "+1.23")) + +;;; New (2005-11-08, also known as CSR House day) float format test +;;; cases. Simon Alexander, Raymond Toy, and others +(assert (string= (format nil "~9,4,,-7E" pi) ".00000003d+8")) +(assert (string= (format nil "~9,4,,-5E" pi) ".000003d+6")) +(assert (string= (format nil "~5,4,,7E" pi) "3141600.d-6")) +(assert (string= (format nil "~11,4,,3E" pi) " 314.16d-2")) +(assert (string= (format nil "~11,4,,5E" pi) " 31416.d-4")) +(assert (string= (format nil "~11,4,,0E" pi) " 0.3142d+1")) +(assert (string= (format nil "~9,,,-1E" pi) ".03142d+2")) +(assert (string= (format nil "~,,,-2E" pi) "0.003141592653589793d+3")) +(assert (string= (format nil "~,,,2E" pi) "31.41592653589793d-1")) +(assert (string= (format nil "~E" pi) "3.141592653589793d+0")) +(assert (string= (format nil "~9,5,,-1E" pi) ".03142d+2")) +(assert (string= (format nil "~11,5,,-1E" pi) " 0.03142d+2")) +(assert (string= (format nil "~G" pi) "3.141592653589793 ")) +(assert (string= (format nil "~9,5G" pi) "3.1416 ")) +(assert (string= (format nil "|~13,6,2,7E|" pi) "| 3141593.d-06|")) +(assert (string= (format nil "~9,3,2,0,'%E" pi) "0.314d+01")) +(assert (string= (format nil "~9,0,6f" pi) " 3141593.")) +(assert (string= (format nil "~6,2,1,'*F" pi) " 31.42")) +(assert (string= (format nil "~6,2,1,'*F" (* 100 pi)) "******")) +(assert (string= (format nil "~9,3,2,-2,'%@E" pi) "+.003d+03")) +(assert (string= (format nil "~10,3,2,-2,'%@E" pi) "+0.003d+03")) +(assert (string= (format nil "~15,3,2,-2,'%,'=@E" pi) "=====+0.003d+03")) +(assert (string= (format nil "~9,3,2,-2,'%E" pi) "0.003d+03")) +(assert (string= (format nil "~8,3,2,-2,'%@E" pi) "%%%%%%%%")) + +(assert (string= (format nil "~g" 1e0) "1. ")) +(assert (string= (format nil "~g" 1.2d40) "12000000000000000000000000000000000000000. ")) + +(assert (string= (format nil "~e" 0) "0.0e+0")) +(assert (string= (format nil "~e" 0d0) "0.0d+0")) +(assert (string= (format nil "~9,,4e" 0d0) "0.0d+0000")) + (let ((table (make-hash-table))) (setf (gethash 1 table) t) (assert diff --git a/version.lisp-expr b/version.lisp-expr index 36a2bd4..76420fb 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.9.6.33" +"0.9.6.34" -- 1.7.10.4