[Sbcl-commits] master: tests and NEWS for lp#308961

[Nikodemus S. <de...@us...>]

The branch "master" has been updated in SBCL:
       via  bea52212cb688209f31804bc6d4644968ac28246 (commit)
      from  dafa18aa6bd65fe2129a32b0e827141684bb159a (commit)

- Log -----------------------------------------------------------------
commit bea52212cb688209f31804bc6d4644968ac28246
Author: Nikodemus Siivola <nik...@ra...>
Date:   Tue Jun 7 12:29:21 2011 +0300

    tests and NEWS for lp#308961
    
      Also add a random FP read/print consistency tester.
    
      For now it skips denormalized double-floats due to bug 793774.
---
 NEWS                    |    3 ++
 tests/print.impure.lisp |   55 +++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 58 insertions(+), 0 deletions(-)

diff --git a/NEWS b/NEWS
index 7550ee2..1d7f30a 100644
--- a/NEWS
+++ b/NEWS
@@ -26,6 +26,9 @@ changes relative to sbcl-1.0.49:
     are of the order of ARRAY-TOTAL-SIZE-LIMIT. (lp#787237)
   * bug fix: the compiler no longer constant-folds NaNs in
     MAKE-{SINGLE,DOUBLE}-FLOAT. (lp#486812)
+  * bug fix: FORMAT now handles floating point rounding correct, eg.
+    (format nil "~,1F" 0.01) => "0.0" instead of "0.01" as previously.
+    (lp#308961)
 
 changes in sbcl-1.0.49 relative to sbcl-1.0.48:
   * minor incompatible change: WITH-LOCKED-HASH-TABLE no longer disables
diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp
index e17492d..9c3329e 100644
--- a/tests/print.impure.lisp
+++ b/tests/print.impure.lisp
@@ -507,4 +507,59 @@
                 ((and warning (not style-warning)) ()
                   :warned)))))
 
+(with-test (:name :bug-308961)
+  (assert (string= (format nil "~4,1F" 0.001) " 0.0"))
+  (assert (string= (format nil "~4,1@F" 0.001) "+0.0"))
+  (assert (string= (format nil "~E" 0.01) "1.e-2"))
+  (assert (string= (format nil "~G" 0.01) "1.00e-2")))
+
+(with-test (:name (:fp-read/print-consistency single-float))
+  (let ((*random-state* (make-random-state t))
+        (oops))
+    (loop for f = most-positive-single-float then (/ f 2.0)
+          while (> f 0.0)
+          do (loop repeat 10
+                   for fr = (random f)
+                   do (unless (eql fr (read-from-string (prin1-to-string fr)))
+                        (push fr oops)
+                        (return))))
+    (loop for f = most-negative-single-float then (/ f 2.0)
+          while (< f -0.0)
+          do (loop repeat 10
+                   for fr = (- (random (- f)))
+                   do (unless (eql fr (read-from-string (prin1-to-string fr)))
+                        (push fr oops)
+                        (return))))
+    (when oops
+      (error "FP read/print inconsistencies:~%~:{  ~S => ~S~%~}"
+             (mapcar (lambda (f)
+                       (list f (read-from-string (prin1-to-string f))))
+                     oops)))))
+
+(with-test (:name (:fp-read/print-consistency double-float))
+  (let ((*random-state* (make-random-state t))
+        (oops))
+    ;; FIXME skipping denormalized floats due to bug 793774.
+    (loop for f = most-positive-double-float then (/ f 2d0)
+          while (> f 0d0)
+          do (loop repeat 10
+                   for fr = (random f)
+                   do (unless (float-denormalized-p fr)
+                        (unless (eql fr (read-from-string (prin1-to-string fr)))
+                          (push fr oops)
+                          (return)))))
+    (loop for f = most-negative-double-float then (/ f 2d0)
+          while (< f -0d0)
+          do (loop repeat 10
+                   for fr = (- (random (- f)))
+                   do (unless (float-denormalized-p fr)
+                        (unless (eql fr (read-from-string (prin1-to-string fr)))
+                          (push fr oops)
+                          (return)))))
+    (when oops
+      (error "FP read/print inconsistencies:~%~:{  ~S => ~S~%~}"
+             (mapcar (lambda (f)
+                       (list f (read-from-string (prin1-to-string f))))
+                     oops)))))
+
 ;;; success

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL