Menu
▾
▴
[Sbcl-commits] master: FLONUM-TO-DIGITS handles non-negative input properly
|
From: Nikodemus S. <de...@us...> - 2011-06-11 18:44:28
|
The branch "master" has been updated in SBCL:
via 58187b3f2ab87bce54657c9c94ac2b3090103ba1 (commit)
from 25692c34027ea51a6b51057bf803f19fe3a575d7 (commit)
- Log -----------------------------------------------------------------
commit 58187b3f2ab87bce54657c9c94ac2b3090103ba1
Author: David Vázquez <da...@es...>
Date: Mon Jun 28 17:28:08 2010 +0200
FLONUM-TO-DIGITS handles non-negative input properly
lp#308961, part 1.
SBCL has an extended version of the Burger & Dybwig fp printer, which
supports rounding.
It did not however support zero -- but in eg.
(format nil "~,1F" 0.001)
0.001 is rounded to zero, which leads FLONUM-TO-DIGITS giving us one zero too
many. Ie. it should be
=> "0.0"
but prior to this we got "0.00" instead.
This patch removes the special casing for 0, and instead tests that the lower
limit of the interval (- r m-) is positive in order not to generate extra
zeros.
---
src/code/print.lisp | 127 ++++++++++++++++++++++++---------------------------
1 files changed, 60 insertions(+), 67 deletions(-)
diff --git a/src/code/print.lisp b/src/code/print.lisp
index fd90bd2..50de743 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -1277,71 +1277,63 @@
;; 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
- (let ((s (make-string (1+ fdigits) :initial-element #\0)))
- (setf (schar s 0) #\.)
- (values s (length s) t (zerop fdigits) 0))
- (values "." 1 t t 0)))
- (t
- (multiple-value-bind (e string)
- (if fdigits
- (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
- (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))
- (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))))))))
+ (multiple-value-bind (e string)
+ (if fdigits
+ (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
+ (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))
+ (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 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.
+;;; implementation of figure 1 from Burger and Dybvig, 1996. It is
+;;; extended in order to handle rounding.
+;;;
+;;; As the 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
@@ -1384,9 +1376,10 @@
(r r (* r print-base))
(m+ m+ (* m+ print-base))
(m- m- (* m- print-base)))
- ((not (or (< (* (+ r m+) print-base) s)
- (and (not high-ok)
- (= (* (+ r m+) print-base) s))))
+ ((not (and (plusp (- r m-)) ; Extension to handle zero
+ (or (< (* (+ r m+) print-base) s)
+ (and (not high-ok)
+ (= (* (+ r m+) print-base) s)))))
(values k (generate r s m+ m-)))))))
(generate (r s m+ m-)
(let (d tc1 tc2)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|