* 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.
(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))
(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)
;;; 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))
(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)
(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)))))
\f
;;;; other leaf objects
(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
;;; 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)
;;; 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
;;; 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"
projects / sbcl.git / commitdiff