From c7a4509f2aeba703f2b23b67f0ff29e79379bbc5 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Tue, 29 Jan 2008 19:24:20 +0000
Subject: [PATCH] o (format nil "~9,3,2,-2,'%@E" 1100.0) was printing %%%%%%. 
 It should   print "+.001e+06" o Major changes for ~g.  See the comments in
 format-general-aux for   more details.   - ~g will choose ~e more often now,
 especially for large numbers.   - ~g when using ~F as the output format won't
 overflow if the number     has lots of significant digits.   - Excessive
 number of digits has been suppressed.   - The original d value is used for
 ~g, instead of the computed     value.

Here is the test suite used.  All tests passed.

(assert (string= (format nil "~9,3,2,0,'%G" 0.0314159) "0.314e-01"))
(assert (string= (format nil "~9,3,2,-2,'%@e" 3.14159) "+.003e+03"))
(assert (string= (format nil "~6,2,1,'*F" 3.14159) " 31.42"))
(assert (string= (format nil "~9,0,6f" 3.14159) " 3141590."))

;; Make sure a significant digit is printed with the bad choice of
;; scale factor.  Width is exceeded.
(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    "))
;; This test exceeds the specified width, unnecessarily.
;;(assert (string= (format nil "~9,5G" pi) "3.1416    "))
(assert (string= (format nil "~9,5G" pi) "3.142    "))
(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.    "))
;; This test is one interpration of the spec.  We don't use this.
;;(assert (string= (format nil "~g" 1.2d40) "12000000000000000000000000000000000000000.    "))
(assert (string= (format nil "~g" 1.2d40) "1.2d+40"))

(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"))
(assert (string= (format nil "~E" 1.234567890123456789d4) "1.2345678901234567d+4"))

(assert (string= (format nil "~20E" (expt 2d0 120)) "1.32922799578492d+36"))
(assert (string= (format nil "~21,8E" (expt 2d0 120)) "       1.32922800d+36"))
(assert (string= (format nil "~9,,,-2E" 1.2345689d3) ".00123d+6"))
(assert (string= (format nil "~9,,,-2E" -1.2345689d3) "-.0012d+6"))
(assert (string= (format nil "~9,,,-2E" 1.2345689d-3) ".00123d+0"))
(assert (string= (format nil "~9,,,-2E" -1.2345689d-3) "-.0012d+0"))

;; Trac ticket #12:
(assert (string= (format nil "~10,1,2,0,'*,,'DE" 1d-6) "   0.1D-05"))

(assert (string= (format nil "~11f" 1.23456789123456789d-3) ".0012345679"))

;; Don't overflow
(assert (string= (format nil "~12,,,,'%g" 1.2345678d1) "12.34568    "))

;; From CLH 22.3.11
(defun test-f (x)
   (format nil "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F"
           x x x x x x))

(assert (string= (test-f 3.14159) "  3.14| 31.42|  3.14|3.1416|3.14|3.14159"))
(assert (string= (test-f -3.14159) " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159" ))
(assert (string= (test-f 100.0)  "100.00|******|100.00| 100.0|100.00|100.0"))
(assert (string= (test-f 1234.0) "1234.00|******|??????|1234.0|1234.00|1234.0"))
(assert (string= (test-f 0.006) "  0.01|  0.06|  0.01| 0.006|0.01|0.006"))



(defun test-e (x)
    (format nil
           "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~
            ~9,3,2,-2,'%@E|~9,2E"
           x x x x))


(assert (string= (test-e 3.14159)  "  3.14e+0| 31.42$-01|+.003e+03|  3.14e+0"))
(assert (string= (test-e -3.14159)  " -3.14e+0|-31.42$-01|-.003e+03| -3.14e+0"))
(assert (string= (test-e 1100.0)  "  1.10e+3| 11.00$+02|+.001e+06|  1.10e+3"))
(assert (string= (test-e 1100.0d0)  "  1.10d+3| 11.00$+02|+.001d+06|  1.10d+3"))
(assert (string= (test-e 1.1e13)  "*********| 11.00$+12|+.001e+16| 1.10e+13"))
(assert (string= (test-e 1.1d120)  "*********|??????????|%%%%%%%%%|1.10d+120"))

(defun test-g (x)
   (format nil "~9,2,1,,'*G|~9,3,2,3,'?,,'$G|~9,3,2,0,'%G|~9,2G"
	   x x x x))

(assert (string= (test-g 0.0314159)  "  3.14e-2|314.2$-04|0.314e-01|  3.14e-2"))
(assert (string= (test-g 0.314159)  "  0.31   |0.314    |0.314    | 0.31    "))
(assert (string= (test-g 3.14159)  "   3.1   | 3.14    | 3.14    |  3.1    "))
(assert (string= (test-g 31.4159)  "   31.   | 31.4    | 31.4    |  31.    "))
(assert (string= (test-g 314.159)  "  3.14e+2| 314.    | 314.    |  3.14e+2"))
(assert (string= (test-g 3141.59)  "  3.14e+3|314.2$+01|0.314e+04|  3.14e+3"))
(assert (string= (test-g 3141.59d0)  "  3.14d+3|314.2$+01|0.314d+04|  3.14d+3"))
(assert (string= (test-g 3.14e12)  "*********|314.0$+10|0.314e+13| 3.14e+12"))
(assert (string= (test-g 3.14d120)  "*********|?????????|%%%%%%%%%|3.14d+120"))

(defun test-scale (k)
  (format nil "~&Scale factor ~2D: |~13,6,2,VE|"
	  (- k 5) (- k 5) 3.14159))

(assert (string= (test-scale 0) "Scale factor -5: | 0.000003e+06|"))
(assert (string= (test-scale 1) "Scale factor -4: | 0.000031e+05|"))
(assert (string= (test-scale 2) "Scale factor -3: | 0.000314e+04|"))
(assert (string= (test-scale 3) "Scale factor -2: | 0.003142e+03|"))
(assert (string= (test-scale 4) "Scale factor -1: | 0.031416e+02|"))
(assert (string= (test-scale 5) "Scale factor  0: | 0.314159e+01|"))
(assert (string= (test-scale 6) "Scale factor  1: | 3.141590e+00|"))
(assert (string= (test-scale 7) "Scale factor  2: | 31.41590e-01|"))
(assert (string= (test-scale 8) "Scale factor  3: | 314.1590e-02|"))
(assert (string= (test-scale 9) "Scale factor  4: | 3141.590e-03|"))
(assert (string= (test-scale 10) "Scale factor  5: | 31415.90e-04|"))
(assert (string= (test-scale 11) "Scale factor  6: | 314159.0e-05|"))
(assert (string= (test-scale 12) "Scale factor  7: | 3141590.e-06|"))
---
 code/format.lisp | 58 ++++++++++++++++++++++++++++--------------------
 1 file changed, 34 insertions(+), 24 deletions(-)

diff --git a/code/format.lisp b/code/format.lisp
index c386d352b..ec85e0d27 100644
--- a/code/format.lisp
+++ b/code/format.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.77 2008/01/28 22:58:43 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.78 2008/01/29 19:24:20 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1310,15 +1310,10 @@
 		(format t "spaceleft = ~A~%" spaceleft)
 		(format t "expt = ~S~%" expt))
 
-	      ;; For fdig, use the larger of fdig and expt so that we'll
-	      ;; always get at least one digit, even if the scale factor
-	      ;; would have shifted all significant bits out.
 	      (multiple-value-bind (fstr flen lpoint tpoint)
 		  (lisp::flonum-to-string (abs number)
 					  spaceleft
-					  (if (and fdig k (minusp k))
-					      (max expt fdig)
-					      fdig)
+					  fdig
 					  k
 					  fmin
 					  num-expt)
@@ -1423,19 +1418,22 @@
 	   (or (float-infinity-p number)
 	       (float-nan-p number)))
       (prin1 number stream)
-      ;;(multiple-value-bind (ignore n) 
-      ;;  (lisp::scale-exponent (abs number))
-      (let* ((n (accurate-scale-exponent (abs number))))
-	;;Default d if omitted.  The procedure is taken directly
-	;;from the definition given in the manual, and is not
-	;;very efficient, since we generate the digits twice.
-	;;Future maintainers are encouraged to improve on this.
+      (let* ((n (accurate-scale-exponent (abs number)))
+	     (orig-d d))
+	;; Default d if omitted.  The procedure is taken directly from
+	;; the definition given in the manual (CLHS 22.3.3.3), and is
+	;; not very efficient, since we generate the digits twice.
+	;; Future maintainers are encouraged to improve on this.
+	;;
+	;; It's also not very clear whether q in the spec is the
+	;; number of significant digits or not.  I (rtoy) think it
+	;; makes more sense if q is the number of significant digits.
+	;; That way 1d300 isn't printed as 1 followed by 300 zeroes.
+	;; Exponential notation would be used instead.
+	
 	(unless d
-	  (multiple-value-bind (str len) 
-	      (lisp::flonum-to-string (abs number))
-	    (declare (ignore str))
-	    (let ((q (if (= len 1) 1 (1- len))))
-	      (setq d (max q (min n 7))))))
+	  (let* ((q (length (nth-value 1 (lisp::flonum-to-digits (abs number))))))
+	    (setq d (max q (min n 7)))))
 	(let* ((ee (if e (+ e 2) 4))
 	       (ww (if w (- w ee) nil))
 	       (dd (- d n)))
@@ -1446,13 +1444,25 @@
 	    (format t "ww = ~A~%" ww)
 	    (format t "dd = ~A~%" dd))
 	  (cond ((<= 0 dd d)
-		 (let ((char (if (format-fixed-aux stream number ww dd nil
-						   ovf pad atsign)
-				 ovf
-				 #\space)))
+		 ;; Figure out how many fraction digits we really want
+		 ;; to print.  If we can, use dd.  If not, adjust it
+		 ;; so that we print as many fraction digits as
+		 ;; possible without exceeding the width constraint,
+		 ;; if any.
+		 (let* ((ndigits (max 0 (if ww
+					    (min dd (- ww 1 n))
+					    dd)))
+			(char (if (format-fixed-aux stream number ww
+						    ndigits
+						    nil
+						    ovf pad atsign)
+				  ovf
+				  #\space)))
 		   (dotimes (i ee) (write-char char stream))))
 		(t
-		 (format-exp-aux stream number w d e (or k 1)
+		 (format-exp-aux stream number w
+				 orig-d
+				 e (or k 1)
 				 ovf pad marker atsign)))))))
 
 (def-format-directive #\$ (colonp atsignp params)
-- 
GitLab