From f8d2e30156f2d2de2f058878442d2b5bf6cfc666 Mon Sep 17 00:00:00 2001 From: Robert Dodier Date: Mon, 17 Apr 2023 00:28:07 -0700 Subject: [PATCH] Print floats readably when fpprintprec = 0 or fpprintprec > 16. * Update Texinfo documentation about fpprintprec. * src/commac.lisp: in EXPLODEN-FORMAT-FLOAT-READABLY, call PRIN1-TO-STRING to ensure readable output in EXPLODEN-FORMAT-FLOAT-PRETTY, simplify handling of fpprintprec in FORMAT arguments * src/testsuite.lisp: rtest6: cut out references to old ECL versions, and cut out expected failure for test 46, as there are only 45 tests at present rtest16: renumber expected failures * tests/rtest6.mac: allow additional variation in displayed exponents since FORMAT "~e" always outputs a sign on the exponent, and PRIN1-TO-STRING might or might not additional test cases for parse_string(string(foo)) in the presence of fpprintprec = 0, for foo = least_positive_float and friends * tests/rtest16.mac: separate tests for fpprintprec into cases 0 or > 16 versus 2 to 16, and output some additional detail for failed tests Fixes SF bug #4107: "least_positive_float doesn't print/read correctly in float/bfloat" --- doc/info/DataTypes.texi | 3 ++- src/commac.lisp | 63 +++++++++++++++++++++++++++++++++++++++---------- src/testsuite.lisp | 12 ++++------ tests/rtest16.mac | 32 ++++++++----------------- tests/rtest6.mac | 30 +++++++++++++++++++++-- 5 files changed, 95 insertions(+), 45 deletions(-) diff --git a/doc/info/DataTypes.texi b/doc/info/DataTypes.texi index daf82b9e3..603bdb722 100644 --- a/doc/info/DataTypes.texi +++ b/doc/info/DataTypes.texi @@ -402,7 +402,8 @@ For ordinary floating point numbers, when @code{fpprintprec} has a value between 2 and 16 (inclusive), the number of digits printed is equal to @code{fpprintprec}. Otherwise, @code{fpprintprec} is 0, or greater than 16, -and the number of digits printed is 16. +and the number is printed "readably": +that is, it is printed with sufficient digits to exactly reconstruct the number on input. For bigfloat numbers, when @code{fpprintprec} has a value between 2 and @code{fpprec} (inclusive), diff --git a/src/commac.lisp b/src/commac.lisp index 97cb85a38..1094fb479 100644 --- a/src/commac.lisp +++ b/src/commac.lisp @@ -299,13 +299,52 @@ (defvar *exploden-strip-float-zeros* t) ;; NIL => allow trailing zeros (defun exploden-format-float (symb) - (declare (special $maxfpprintprec)) - (let ((a (abs symb)) - string - (effective-printprec (if (or (= $fpprintprec 0) - (> $fpprintprec $maxfpprintprec)) - $maxfpprintprec - $fpprintprec))) + (if (or (= $fpprintprec 0) (> $fpprintprec 16.)) + (exploden-format-float-readably symb) + (exploden-format-float-pretty symb))) + +(defun exploden-format-float-readably (x) + (let ((*print-readably* t)) + (let ((s (prin1-to-string x))) + ;; Skip the fix up unless we know it's needed for the Lisp implementation. + #+(or clisp abcl) (fix-up-exponent-in-place s) + #+ecl (insert-zero-before-exponent s) + #-(or clisp abcl ecl) s))) + +;; (1) If string looks like "n.nnnD0" or "n.nnnd0", return just "n.nnn". +;; (2) Otherwise, replace #\D or #\d (if present) with #\E or #\e, respectively. +;; (3) Otherwise, return S unchanged. + +(defun fix-up-exponent-in-place (s) + (let ((n (length s)) i) + (if (> n 2) + (cond + ((and (or (eql (aref s (- n 2)) #\D) (eql (aref s (- n 2)) #\d)) (eql (aref s (- n 1)) #\0)) + (subseq s 0 (- n 2))) + ((setq i (position #\D s)) + (setf (aref s i) #\E) + s) + ((setq i (position #\d s)) + (setf (aref s i) #\e) + s) + (t s)) + s))) + +;; Replace "nnnn.Ennn" or "nnn.ennn" with "nnn.0Ennn" or nnn.0ennn", respectively. +;; (Decimal immediately before exponent without intervening digits is +;; explicitly allowed by CLHS; see Section 2.3.1, "Numbers as Tokens". + +(defun insert-zero-before-exponent (s) + (let ((n (length s)) (i (position #\. s))) + (if (and i (< i (1- n))) + (let ((c (aref s (1+ i)))) + (if (or (eql c #\E) (eql c #\e)) + (concatenate 'string (subseq s 0 (1+ i)) "0" (subseq s (1+ i) n)) + s)) + s))) + +(defun exploden-format-float-pretty (symb) + (let ((a (abs symb)) string) ;; When printing out something for Fortran, we want to be ;; sure to print the exponent marker so that Fortran ;; knows what kind of number it is. It turns out that @@ -327,13 +366,13 @@ (let* ((integer-log10 (floor (/ (log a) #.(log 10.0)))) (scale (1+ integer-log10))) - (if (< scale effective-printprec) - (values "~,vf" (- effective-printprec scale)) - (values "~,ve" (1- effective-printprec))))) + (if (< scale $fpprintprec) + (values "~,vf" (- $fpprintprec scale)) + (values "~,ve" (1- $fpprintprec))))) ((or (float-inf-p symb) (float-nan-p symb)) - (return-from exploden-format-float (format nil "~a" symb))) + (return-from exploden-format-float-pretty (format nil "~a" symb))) (t - (values "~,ve" (1- effective-printprec)))) + (values "~,ve" (1- $fpprintprec)))) ;; Call FORMAT using format string chosen above. (setq string (format nil form digits a)) diff --git a/src/testsuite.lisp b/src/testsuite.lisp index 8829b1d64..8de40b3d4 100644 --- a/src/testsuite.lisp +++ b/src/testsuite.lisp @@ -33,11 +33,7 @@ ,@(and (boundp '*autoconf-lisp-only-build*) (symbol-value '*autoconf-lisp-only-build*) (list (list '(mlist simp) 80)))) - ;; 46 = ECL bug #437: mishandling float format - ;; 45 sporadically fails in all tested ECL versions (15.3.7-16.1.3) - ;; 43 fails in ECL up to version 15.3.7 - ((mlist simp) "rtest6" - #+ecl ((mlist simp) 46)) + "rtest6" "rtest6a" "rtest6b" "rtest7" @@ -62,9 +58,9 @@ ;; bug #329. Fixed post-16.1.3. ;; Test 50 still sometimes fails in ecl 16.1.2 ((mlist simp) "rtest16" - #-(or ecl allegro) ((mlist simp) 524 525) - #+ecl ((mlist simp) 524 525) - #+allegro ((mlist simp) 50 241 524 525)) + #-(or ecl allegro) ((mlist simp) 525 526) + #+ecl ((mlist simp) 525 526) + #+allegro ((mlist simp) 50 242 525 526)) "rtestode" "rtestode_zp" ((mlist simp) "rtest3" ((mlist simp) 146)) diff --git a/tests/rtest16.mac b/tests/rtest16.mac index e03631d87..b0d18a423 100644 --- a/tests/rtest16.mac +++ b/tests/rtest16.mac @@ -241,33 +241,21 @@ block ([L1 : [["1.2E-10","1.2E-9","1.2E-8","1.2E-7","1.2E-6","1.2E-5","1.2E-4"," "1.234432112344321E-5","1.234432112344321E-4","0.001234432112344321","0.01234432112344321","0.1234432112344321", "1.234432112344321","12.34432112344321","123.4432112344321","1234.432112344321","12344.32112344321", "123443.2112344321","1234432.112344321","1.234432112344321E+7","1.234432112344321E+8","1.234432112344321E+9", - "1.234432112344321E+10"], - ["1.234432112344321E-10","1.234432112344321E-9","1.234432112344321E-8","1.234432112344321E-7","1.234432112344321E-6", - "1.234432112344321E-5","1.234432112344321E-4","0.001234432112344321","0.01234432112344321","0.1234432112344321", - "1.234432112344321","12.34432112344321","123.4432112344321","1234.432112344321","12344.32112344321", - "123443.2112344321","1234432.112344321","1.234432112344321E+7","1.234432112344321E+8","1.234432112344321E+9", - "1.234432112344321E+10"], - ["1.234432112344321E-10","1.234432112344321E-9","1.234432112344321E-8","1.234432112344321E-7","1.234432112344321E-6", - "1.234432112344321E-5","1.234432112344321E-4","0.001234432112344321","0.01234432112344321","0.1234432112344321", - "1.234432112344321","12.34432112344321","123.4432112344321","1234.432112344321","12344.32112344321", - "123443.2112344321","1234432.112344321","1.234432112344321E+7","1.234432112344321E+8","1.234432112344321E+9", - "1.234432112344321E+10"], - ["1.234432112344321E-10","1.234432112344321E-9","1.234432112344321E-8","1.234432112344321E-7","1.234432112344321E-6", - "1.234432112344321E-5","1.234432112344321E-4","0.001234432112344321","0.01234432112344321","0.1234432112344321", - "1.234432112344321","12.34432112344321","123.4432112344321","1234.432112344321","12344.32112344321", - "123443.2112344321","1234432.112344321","1.234432112344321E+7","1.234432112344321E+8","1.234432112344321E+9", - "1.234432112344321E+10"], - ["1.234432112344321E-10","1.234432112344321E-9","1.234432112344321E-8","1.234432112344321E-7","1.234432112344321E-6", - "1.234432112344321E-5","1.234432112344321E-4","0.001234432112344321","0.01234432112344321","0.1234432112344321", - "1.234432112344321","12.34432112344321","123.4432112344321","1234.432112344321","12344.32112344321", - "123443.2112344321","1234432.112344321","1.234432112344321E+7","1.234432112344321E+8","1.234432112344321E+9", "1.234432112344321E+10"]], L2 : block ([foo : 1.2344321123443211234], - makelist (block ([fpprintprec : m], makelist (string (foo*10^n), n, -10, 10)), m, 2, 20))], - map (lambda ([s1, s2], if sequalignore (s1, s2) then true else s2 # s1), flatten (L1), flatten (L2)), + makelist (block ([fpprintprec : m], makelist ([m, string (foo*10^n)], n, -10, 10)), m, 2, 16))], + map (lambda ([s1, s2], if sequalignore (s1, second (s2)) then true else ['fpprintprec = first (s2), 'expected = s1, 'actual = second (s2)]), apply (append, L1), apply (append, L2)), delete (true, %%)); []; +/* verify that fpprintprec = 0 or fpprintprec > 16 prints readably */ + +block ([foo: float (%pi), L], + L: makelist (block ([fpprintprec: m], makelist ([m, foo*10^n, string (foo*10^n)], n, -10, 10)), m, [0, 17, 18, 19, 20]), + map (lambda ([L1], if parse_string (L1[3]) = L1[2] then true else ['fpprintprec = first (L1), 'expected = L1[2], 'actual = L1[3]]), apply (append, L)), + delete (true, %%)); +[]; + /* SF bug #3213: "fpprintprec do not round bfloat correctly." */ (reset (fpprec, bftrunc), diff --git a/tests/rtest6.mac b/tests/rtest6.mac index 3acdc8099..22379bc49 100644 --- a/tests/rtest6.mac +++ b/tests/rtest6.mac @@ -160,14 +160,40 @@ string (25.0); string(1/16.0); "0.0625"; -(string(2e7), %% = "2.0e+7" or %% = "2.0E+7" or %%); +(string(2e7), %% = "2.0e+7" or %% = "2.0E+7" or %% = "2.0e7" or %% = "2.0E7" or %%); true; (string(2e-7), %% = "2.0e-7" or %% = "2.0E-7" or %%); true; -(string(12345000000.0), %% = "1.2345e+10" or %% = "1.2345E+10" or %%); +(string(12345000000.0), %% = "1.2345e+10" or %% = "1.2345E+10" or %% = "1.2345e10" or %% = "1.2345E10" or %%); true; (string(1/1024.0), %% = "9.765625e-4" or %% = "9.765625E-4" or %%); true; + +/* SF bug #4107: "least_positive_float doesn't print/read correctly in float/bfloat" */ + +(reset (fpprintprec), 0); +0; + +is (parse_string (string (most_positive_float)) = most_positive_float); +true; + +is (parse_string (string (least_positive_float)) = least_positive_float); +true; + +is (parse_string (string (least_positive_normalized_float)) = least_positive_normalized_float); +true; + +is (parse_string (string (most_negative_float)) = most_negative_float); +true; + +is (parse_string (string (least_negative_float)) = least_negative_float); +true; + +is (parse_string (string (least_negative_normalized_float)) = least_negative_normalized_float); +true; + +is (parse_string (string (float_eps ())) = float_eps ()); +true; -- 2.11.4.GIT