mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-04-25 02:50:24 -07:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'format-e-issues' into 'develop'

Browse source 
Fix several issues with the format ~e directive

Closes #499 and #632

See merge request embeddable-common-lisp/ecl!274
This commit is contained in:
Daniel Kochmański 2022-10-02 19:28:00 +00:00
commit e760e9182b
3 changed files with 92 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

42
src/c/printer/float_to_digits.d
View file

@ -2,6 +2,7 @@
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
/*
* float_to_digits.d: floating point printer functions
*
* Copyright (c) 2010 Juan Jose Garcia Ripoll
*
@ -14,6 +15,11 @@
#include <ecl/ecl.h>
#include <ecl/ecl-inl.h>
/*
* The following algorithm is based on Burger, Dybvig (1996)
* (available at http://www.cs.indiana.edu/~dyb/pubs/FP-Printing-PLDI96.pdf)
*/
#define PRINT_BASE ecl_make_fixnum(10)
#define EXPT_RADIX(x) ecl_ash(ecl_make_fixnum(1),x)
@ -196,6 +202,42 @@ change_precision(float_approx *approx, cl_object position, cl_object relativep)
}
}
/*
* si_float_to_digits: create a correctly rounded approximation for a
* floating point number in the form of a string of (base 10) digits.
* Zero digits at the end or beginning of the string are omitted.
*
* Arguments:
*
* - digits: an adjustable base-string to store the digits in or NIL
* to allocate a new base-string
* - number: the floating point number to approximate
* - position: specifies the number of digits to generate. If position
* is NIL create as many digits as necessary to reconstruct the
* number without error; otherwise:
* - if relativep is false, position specifies the position relative
* to the decimal point up to which to generate digits. Example: a
* number of the form (d_n)...(d_0).(d_{-1})...*10^0 is translated
* into a string (d_n)...(d_{position}) and then rounded. Here,
* (d_i) is the digit at position i relative to the decimal point.
* - if replativep is true, the number is normalized such that the
* decimal point lies behind the first digit and position
* specifies the number of digits to generate after this shifted
* decimal point. Example: for k >= 0, a number of the form
* (d_1).(d_2)...(d_n)*10^(-k) is translated into a string
* (d_1)(d_2)...(d_{position+1}) and then rounded irrespective of
* the value of k. For k < 0, the result is a string of the form
* (d_1)(d_2)..(d_{position-k+1}) (k leading zeros are omitted).
* - relativep: a generalized boolean
*
* Return values:
*
* - k: a scale factor such that the string of digits multiplied with
* 10^k is (up to rounding) equal to number. To be precise, for
* return values k and (d_1)...(d_n), number ≅ 10^(k-n)*int((d_1)...(d_n)).
* - digits: the created digits
*/
cl_object
si_float_to_digits(cl_object digits, cl_object number, cl_object position,
cl_object relativep)

55
src/lsp/format.lsp
View file

@ -66,7 +66,7 @@
;;; used by the printer.
;;;
;;; Returns:
;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT)
;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT POINT-POS EXPONENT)
;;; where the results have the following interpretation:
;;;
;;; DIGIT-STRING - The decimal representation of X, with decimal point.
@ -77,6 +77,8 @@
;;; decimal point.
;;; POINT-POS - The position of the digit preceding the decimal
;;; point. Zero indicates point before first digit.
;;; EXPONENT - The exponent of the number in base 10 after rounding
;;; (excluding the scale factor)
;;;
;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee accuracy.
;;; Specifically, the decimal number printed is the closest possible
@ -114,11 +116,11 @@
(declare (type float x))
(if (zerop x)
;; Zero is a special case which FLOAT-STRING cannot handle.
(cond ((null fdigits) (values ".0" 2 t nil 0))
((zerop fdigits) (values "0." 2 nil t 1))
(cond ((null fdigits) (values ".0" 2 t nil 0 1))
((zerop fdigits) (values "0." 2 nil t 1 1))
(T (let ((s (make-string (1+ fdigits) :initial-element #\0)))
(setf (schar s 0) #\.)
(values s (length s) t nil 0))))
(values s (length s) t nil 0 1))))
(multiple-value-bind (e string zero?)
(cond (fdigits
(float-to-digits* nil x
@ -127,19 +129,20 @@
nil))
((null width)
(float-to-digits* nil x nil nil))
(T (let ((w (multiple-value-list
(T (let (;; w: the width-1 leading non-zero digits
(w (multiple-value-list
(float-to-digits* nil x
(max 0
(+ (- width 2)
(if (minusp scale)
scale 0)))
(max 0 scale)))
t)))
;; f: the fmin+1 leading non-zero digits; this
;; is used if w is empty (not enough space)
(f (multiple-value-list
(float-to-digits* nil x
(- (+ fmin scale))
nil))))
(if (>= (length (cadr w))
(length (cadr f)))
(if (>= (first f) (first w))
(values-list w)
(values-list f)))))
(let* ((exp (+ e scale))
@ -188,7 +191,8 @@
length
(= position 0)
(= position (1- length))
position))))))
position
e))))))
(defun exponent-in-base10 (x)
(if (= x 0)
@ -1381,8 +1385,9 @@
(or (float-infinity-p number)
(float-nan-p number)))
(prin1 number stream)
(let* ((expt (- (sys::exponent-in-base10 number) k))
(estr (decimal-string (abs expt)))
(let* ((expt (sys::exponent-in-base10 number))
(rescaled-expt (- expt k))
(estr (decimal-string (abs rescaled-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) 0))
@ -1393,14 +1398,31 @@
nil)))
(if (and w ovf e (> elen e)) ;exponent overflow
(dotimes (i w) (write-char ovf stream))
(multiple-value-bind (fstr flen lpoint)
(sys::flonum-to-string number spaceleft fdig (- expt) fmin)
(multiple-value-bind (fstr flen lpoint tpoint ppos expt-after-rounding)
(sys::flonum-to-string number spaceleft fdig (- rescaled-expt) fmin)
(declare (ignore ppos))
(when (/= expt-after-rounding expt)
(setf rescaled-expt (- expt-after-rounding k)
estr (decimal-string (abs rescaled-expt))
elen (if e (max (length estr) e) (length estr))
spaceleft (if w
(- w 2 elen
(if (or atsign (minusp number))
1 0))
nil)
(values fstr flen lpoint tpoint)
(sys::flonum-to-string number spaceleft fdig (- rescaled-expt) fmin)))
(when (eql fdig 0) (setq tpoint nil))
(when w
(decf spaceleft flen)
(when lpoint
(if (> spaceleft 0)
(decf spaceleft)
(setq lpoint nil))))
(setq lpoint nil)))
(when tpoint
(if (<= spaceleft 0)
(setq tpoint nil)
(decf spaceleft))))
(cond ((and w (< spaceleft 0) ovf)
;;significand overflow
(dotimes (i w) (write-char ovf stream)))
@ -1411,11 +1433,12 @@
(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)
(write-char (if (minusp rescaled-expt) #\- #\+) stream)
(when e
;;zero-fill before exponent if necessary
(dotimes (i (- e (length estr)))

11
src/tests/normal-tests/ansi.lsp
View file

@ -231,6 +231,17 @@
(is-equal expected-2 (format nil "~1,v:/fmt/" nil t))
(is-equal expected-2 (format nil "~1,v,:/fmt/" nil t))))
;;; Tests for correct rounding in ~e directive with k parameter
(test ansi.22.format-e
(is-equal (format nil "~,2,,-1e" 0.9) "0.09e+1")
(is-equal (format nil "~,2,,-1e" 0.99) "0.01e+2")
(is-equal (format nil "~,1,,0e" 0.9) "0.9e+0")
(is-equal (format nil "~,1,,0e" 0.99) "0.1e+1")
(is-equal (format nil "~,1,,1e" 9.9) "9.9e+0")
(is-equal (format nil "~,1,,1e" 9.99) "1.0e+1")
(is-equal (format nil "~6e" 9.9) "9.9e+0")
(is-equal (format nil "~6e" 9.99) "1.0e+1"))
;;;;;;;;;;;;;;;;;;;;;;;
;; 23.* Reader tests ;;