Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 14:19:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Fixed integer-log-base to use exact arithmetic so rounding doesn't cause

Browse source 
a wrong result to things like (numeric (- (* 36 36 36) 1) 36).

Fixed a bug in numeric that caused comma-sep and dec-sep to get
initialized wrongly.

Fixed maybe-trim-zeros to leave behind at least a ".0" on
inexact numbers that otherwise would have been output without
the decimal point.  This is for consistency with number->string
which is used when the radix is 10.

In gen-general, fixed a bug in the digit-generating loop for the
whole part of the number.  Previously, an integer that should
have looked like 5003 would be emitted as 5300.

Switched the order of application of maybe-round and
maybe-trim-zeros so that a number that should round to
.0000000000000001 doesn't get emitted as 0.1.

In gen-positive-real, fixed the ratio case to not call
number->string with a radix that might not be in {2,8,10,16}.

Also in gen-positive-real, fixed the call to number->string to
include the radix which was missing previously.

Fixed wrap-sign to correctly handle the case of -0.0.

In numeric/si, always emit the supplied separator even if the
number is too small for an SI-suffix to be emitted.  The
examples in the SRFI document depend on this.
This commit is contained in:
Jim Rees 2018-03-23 12:22:03 -04:00
parent 17eb19e43d
commit 88e8d89460
1 changed files with 42 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

65
lib/chibi/show/write.scm
View file

@ -97,7 +97,10 @@
(define (integer-log a base) (define (integer-log a base)
(if (zero? a) (if (zero? a)
0 0
(exact (ceiling (/ (log (+ a 1)) (log base)))))) ;; (exact (ceiling (/ (log (+ a 1)) (log base))))
(do ((ndigits 1 (+ ndigits 1))
(p base (* p base)))
((> p a) ndigits))))
;; The original fmt algorithm was based on "Printing Floating-Point ;; The original fmt algorithm was based on "Printing Floating-Point
;; Numbers Quickly and Accurately" by Burger and Dybvig ;; Numbers Quickly and Accurately" by Burger and Dybvig
@ -116,13 +119,13 @@
(comma unspec) (commasep unspec) (decsep unspec)) (comma unspec) (commasep unspec) (decsep unspec))
(fn (radix precision sign-rule (fn (radix precision sign-rule
comma-rule comma-sep decimal-sep decimal-align) comma-rule comma-sep decimal-sep decimal-align)
(let ((radix (default rad radix)) (let* ((radix (default rad radix))
(precision (default prec precision)) (precision (default prec precision))
(sign-rule (default sgn sign-rule)) (sign-rule (default sgn sign-rule))
(comma-rule (default comma comma-rule)) (comma-rule (default comma comma-rule))
(comma-sep (default comma-sep commasep)) (comma-sep (default commasep comma-sep))
(dec-sep (default decsep (dec-sep (default decsep
(or decimal-sep (if (eqv? comma-sep #\.) #\, #\.))))) (or decimal-sep (if (eqv? comma-sep #\.) #\, #\.)))))
;; General formatting utilities. ;; General formatting utilities.
(define (get-scale q) (define (get-scale q)
(expt radix (- (integer-log q radix) 1))) (expt radix (- (integer-log q radix) 1)))
@ -155,23 +158,26 @@
(and prev (odd? prev))))) (and prev (odd? prev)))))
(round-up ls) (round-up ls)
ls))) ls)))
(define (maybe-trim-zeros i res) (define (maybe-trim-zeros i res inexact?)
(if (and (not precision) (positive? i)) (if (and (not precision) (positive? i))
(let lp ((res res)) (let lp ((res res))
(cond (cond
((and (pair? res) (eqv? 0 (car res))) (lp (cdr res))) ((and (pair? res) (eqv? 0 (car res))) (lp (cdr res)))
((and (pair? res) (eqv? dec-sep (car res))) (cdr res)) ((and (pair? res) (eqv? dec-sep (car res)))
(if inexact?
(cons 0 res) ; "1.0"
(cdr res))) ; "1"
(else res))) (else res)))
res)) res))
;; General slow loop to generate digits one at a time, for ;; General slow loop to generate digits one at a time, for
;; non-standard radixes or writing rationals with a fixed ;; non-standard radixes or writing rationals with a fixed
;; precision. ;; precision.
(define (gen-general n) (define (gen-general n-orig)
(let* ((p (exact n)) (let* ((p (exact n-orig))
(n (numerator p)) (n (numerator p))
(d (denominator p))) (d (denominator p)))
(let lp ((n n) (let lp ((n n)
(i (- (integer-log p radix))) (i (if (zero? p) -1 (- (integer-log p radix))))
(res '())) (res '()))
(cond (cond
;; Use a fixed precision if specified, otherwise generate ;; Use a fixed precision if specified, otherwise generate
@ -182,8 +188,8 @@
res)) res))
(q (quotient n d))) (q (quotient n d)))
(cond (cond
((>= q radix) ((< i -1)
(let* ((scale (get-scale q)) (let* ((scale (expt radix (- -1 i)))
(digit (quotient q scale)) (digit (quotient q scale))
(n2 (- n (* d digit scale)))) (n2 (- n (* d digit scale))))
(lp n2 (+ i 1) (cons digit res)))) (lp n2 (+ i 1) (cons digit res))))
@ -194,7 +200,7 @@
(else (else
(list->string (list->string
(map char-digit (map char-digit
(reverse (maybe-round n d (maybe-trim-zeros i res)))))))))) (reverse (maybe-trim-zeros i (maybe-round n d res) (inexact? n-orig))))))))))
;; Generate a fixed precision decimal result by post-editing the ;; Generate a fixed precision decimal result by post-editing the
;; result of string->number. ;; result of string->number.
(define (gen-fixed n) (define (gen-fixed n)
@ -242,11 +248,11 @@
(precision (precision
(gen-fixed n)) (gen-fixed n))
((and (exact? n) (not (integer? n))) ((and (exact? n) (not (integer? n)))
(string-append (number->string (numerator n) radix) (string-append (gen-positive-real (numerator n))
"/" "/"
(number->string (denominator n) radix))) (gen-positive-real (denominator n))))
((memv radix (if (exact? n) '(2 8 10 16) '(10))) ((memv radix (if (exact? n) '(2 8 10 16) '(10)))
(number->string n)) (number->string n radix))
(else (else
(gen-general n)))) (gen-general n))))
;; Insert commas according to the current comma-rule. ;; Insert commas according to the current comma-rule.
@ -272,14 +278,26 @@
(if comma-rule (insert-commas s1) s1))) (if comma-rule (insert-commas s1) s1)))
;; Wrap the sign of a real number, forcing a + prefix or using ;; Wrap the sign of a real number, forcing a + prefix or using
;; parentheses (n) for negatives according to sign-rule. ;; parentheses (n) for negatives according to sign-rule.
(define-syntax is-neg-zero?
(syntax-rules ()
((_ n)
(is-neg-zero? (-0.0) n))
((_ (0.0) n) ; -0.0 is not distinguished?
#f)
((_ (-0.0) n)
(eqv? -0.0 n))))
(define (negative?* n)
(or (negative? n)
(is-neg-zero? n)))
(define (wrap-sign n sign-rule) (define (wrap-sign n sign-rule)
(cond (cond
((negative? n) ((negative?* n)
(if (char? sign-rule) (if (char? sign-rule)
(string-append (string sign-rule) (string-append (string sign-rule)
(wrap-comma (abs n)) (wrap-comma (- n))
(string (char-mirror sign-rule))) (string (char-mirror sign-rule)))
(string-append "-" (wrap-comma (abs n))))) (string-append "-" (wrap-comma (- n)))))
((eq? #t sign-rule) ((eq? #t sign-rule)
(string-append "+" (wrap-comma n))) (string-append "+" (wrap-comma n)))
(else (else
@ -335,7 +353,8 @@
(each (if (integer? n2) (each (if (integer? n2)
(number->string (exact n2)) (number->string (exact n2))
(inexact n2)) (inexact n2))
(if (zero? k) "" separator) ;; (if (zero? k) "" separator)
separator
(vector-ref names k))))))) (vector-ref names k)))))))
;; Force a number into a fixed width, print as #'s if doesn't fit. ;; Force a number into a fixed width, print as #'s if doesn't fit.