mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-06-25 07:16:41 +02:00
Alex Shinn
GitHub
commit
060cfd550e
8 changed files with 254 additions and 52 deletions
43
bignum.c
43
bignum.c
|
|
@ -67,6 +67,8 @@ sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) {
|
|||
#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0)
|
||||
#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f))
|
||||
|
||||
#define double_16s_digit(f) fmod(f,16.0)
|
||||
|
||||
sexp sexp_double_to_bignum (sexp ctx, double f) {
|
||||
int sign;
|
||||
sexp_gc_var3(res, scale, tmp);
|
||||
|
|
@ -74,10 +76,10 @@ sexp sexp_double_to_bignum (sexp ctx, double f) {
|
|||
res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO);
|
||||
scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE);
|
||||
sign = (f < 0 ? -1 : 1);
|
||||
for (f=fabs(f); f >= 1.0; f=trunc(f/10)) {
|
||||
tmp = sexp_bignum_fxmul(ctx, NULL, scale, (sexp_uint_t)double_10s_digit(f), 0);
|
||||
for (f=fabs(f); f >= 1.0; f=trunc(f/16)) {
|
||||
tmp = sexp_bignum_fxmul(ctx, NULL, scale, (sexp_uint_t)double_16s_digit(f), 0);
|
||||
res = sexp_bignum_add(ctx, res, res, tmp);
|
||||
scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0);
|
||||
scale = sexp_bignum_fxmul(ctx, NULL, scale, 16, 0);
|
||||
}
|
||||
sexp_bignum_sign(res) = sign;
|
||||
sexp_gc_release3(ctx);
|
||||
|
|
@ -730,6 +732,41 @@ sexp sexp_double_to_ratio (sexp ctx, double f) {
|
|||
return res;
|
||||
}
|
||||
|
||||
//
|
||||
// For conversion that does not introduce round-off error,
|
||||
// no matter what FLT_RADIX is.
|
||||
//
|
||||
sexp sexp_double_to_ratio_2 (sexp ctx, double f) {
|
||||
int sign,i;
|
||||
sexp_gc_var3(res, whole, scale);
|
||||
if (f == trunc(f))
|
||||
return sexp_bignum_normalize(sexp_double_to_bignum(ctx, f));
|
||||
sexp_gc_preserve3(ctx, res, whole, scale);
|
||||
whole = sexp_double_to_bignum(ctx, trunc(f));
|
||||
res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO);
|
||||
scale = SEXP_ONE;
|
||||
sign = (f < 0 ? -1 : 1);
|
||||
f = fabs(f-trunc(f));
|
||||
while(f) {
|
||||
res = sexp_bignum_fxmul(ctx, NULL, res, FLT_RADIX, 0);
|
||||
scale = sexp_mul(ctx, scale, sexp_make_fixnum(FLT_RADIX));
|
||||
f *= FLT_RADIX;
|
||||
i = trunc(f);
|
||||
if (i) {
|
||||
f -= i;
|
||||
res = sexp_bignum_fxadd(ctx, res, i);
|
||||
}
|
||||
}
|
||||
sexp_bignum_sign(res) = sign;
|
||||
res = sexp_bignum_normalize(res);
|
||||
scale = sexp_bignum_normalize(scale);
|
||||
res = sexp_make_ratio(ctx, res, scale);
|
||||
res = sexp_ratio_normalize(ctx, res, SEXP_FALSE);
|
||||
res = sexp_add(ctx, res, whole);
|
||||
sexp_gc_release3(ctx);
|
||||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_ratio_add (sexp ctx, sexp a, sexp b) {
|
||||
sexp_gc_var3(res, num, den);
|
||||
sexp_gc_preserve3(ctx, res, num, den);
|
||||
|
|
|
|||
2
eval.c
2
eval.c
|
|
@ -1817,7 +1817,7 @@ sexp sexp_inexact_to_exact (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
|
|||
res = sexp_xtype_exception(ctx, self, "exact: not a finite number", z);
|
||||
} else if (sexp_flonum_value(z) != trunc(sexp_flonum_value(z))) {
|
||||
#if SEXP_USE_RATIOS
|
||||
res = sexp_double_to_ratio(ctx, sexp_flonum_value(z));
|
||||
res = sexp_double_to_ratio_2(ctx, sexp_flonum_value(z));
|
||||
#else
|
||||
res = sexp_xtype_exception(ctx, self, "exact: not an integer", z);
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -44,6 +44,7 @@ SEXP_API sexp sexp_quotient (sexp ctx, sexp a, sexp b);
|
|||
SEXP_API sexp sexp_remainder (sexp ctx, sexp a, sexp b);
|
||||
#if SEXP_USE_RATIOS
|
||||
SEXP_API sexp sexp_double_to_ratio (sexp ctx, double f);
|
||||
SEXP_API sexp sexp_double_to_ratio_2 (sexp ctx, double f);
|
||||
SEXP_API double sexp_ratio_to_double (sexp rat);
|
||||
SEXP_API sexp sexp_make_ratio (sexp ctx, sexp num, sexp den);
|
||||
SEXP_API sexp sexp_ratio_normalize (sexp ctx, sexp rat, sexp in);
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
(define-library (chibi show-test)
|
||||
(export run-tests)
|
||||
(import (scheme base) (scheme char) (scheme read)
|
||||
(import (scheme base) (scheme char) (scheme read) (scheme file)
|
||||
(only (srfi 1) circular-list)
|
||||
(chibi test)
|
||||
(chibi show) (chibi show base) (chibi show color)
|
||||
(chibi show column) (chibi show pretty)
|
||||
|
|
@ -26,6 +27,9 @@
|
|||
(test "ABC" (show #f (upcased "abc")))
|
||||
(test "abc" (show #f (downcased "ABC")))
|
||||
|
||||
(test "a b" (show #f "a" (space-to 5) "b"))
|
||||
(test "ab" (show #f "a" (space-to 0) "b"))
|
||||
|
||||
(test "abc def" (show #f "abc" (tab-to) "def"))
|
||||
(test "abc def" (show #f "abc" (tab-to 5) "def"))
|
||||
(test "abcdef" (show #f "abc" (tab-to 3) "def"))
|
||||
|
|
@ -33,6 +37,8 @@
|
|||
(test "abc\ndef\n" (show #f "abc" fl "def" nl fl))
|
||||
(test "abc\ndef\n" (show #f "abc" fl "def" fl fl))
|
||||
|
||||
(test "ab" (show #f "a" nothing "b"))
|
||||
|
||||
;; numbers
|
||||
|
||||
(test "-1" (show #f -1))
|
||||
|
|
@ -142,6 +148,100 @@
|
|||
(test "100,000.00"
|
||||
(show #f (with ((comma-rule 3) (precision 2)) (numeric 100000))))
|
||||
|
||||
;; radix argument:
|
||||
(test "0" (show #f (numeric 0 2)))
|
||||
(test "0" (show #f (numeric 0 10)))
|
||||
(test "0" (show #f (numeric 0 36)))
|
||||
|
||||
(test "0.0" (show #f (numeric 0.0 2)))
|
||||
(test "0.0" (show #f (numeric 0.0 10)))
|
||||
(test "0.0" (show #f (numeric 0.0 36)))
|
||||
|
||||
(test "1" (show #f (numeric 1 2)))
|
||||
(test "1" (show #f (numeric 1 10)))
|
||||
(test "1" (show #f (numeric 1 36)))
|
||||
|
||||
(test "1.0" (show #f (numeric 1.0 2)))
|
||||
(test "1.0" (show #f (numeric 1.0 10)))
|
||||
(test "1.0" (show #f (numeric 1.0 36)))
|
||||
|
||||
(test "0" (show #f (numeric 0.0 10 0)))
|
||||
(test "0" (show #f (numeric 0.0 9 0)))
|
||||
(test "3/4" (show #f (numeric #e.75)))
|
||||
|
||||
(test "0.0000000000000001" (show #f (numeric 1e-25 36)))
|
||||
(test "100000000000000000000000000000000000000000000000000000000000000000000000000000000.0"
|
||||
(show #f (numeric (expt 2.0 80) 2)))
|
||||
|
||||
;; numeric, radix=2
|
||||
(test "10" (show #f (numeric 2 2)))
|
||||
(test "10.0" (show #f (numeric 2.0 2)))
|
||||
(test "11/10" (show #f (numeric 3/2 2)))
|
||||
(test "1001" (show #f (numeric 9 2)))
|
||||
(test "1001.0" (show #f (numeric 9.0 2)))
|
||||
(test "1001.01" (show #f (numeric 9.25 2)))
|
||||
|
||||
;; numeric, radix=3
|
||||
(test "11" (show #f (numeric 4 3)))
|
||||
(test "10.0" (show #f (numeric 3.0 3)))
|
||||
(test "11/10" (show #f (numeric 4/3 3)))
|
||||
(test "1001" (show #f (numeric 28 3)))
|
||||
(test "1001.0" (show #f (numeric 28.0 3)))
|
||||
(test "1001.01" (show #f (numeric #i253/9 3 2)))
|
||||
|
||||
;; radix 36
|
||||
(test "zzz" (show #f (numeric (- (* 36 36 36) 1) 36)))
|
||||
|
||||
;; Precision:
|
||||
(test "1.1250" (show #f (numeric 9/8 10 4)))
|
||||
(test "1.125" (show #f (numeric 9/8 10 3)))
|
||||
(test "1.12" (show #f (numeric 9/8 10 2)))
|
||||
(test "1.1" (show #f (numeric 9/8 10 1)))
|
||||
(test "1" (show #f (numeric 9/8 10 0)))
|
||||
|
||||
(test "1.1250" (show #f (numeric #i9/8 10 4)))
|
||||
(test "1.125" (show #f (numeric #i9/8 10 3)))
|
||||
(test "1.12" (show #f (numeric #i9/8 10 2)))
|
||||
(test "1.1" (show #f (numeric #i9/8 10 1)))
|
||||
(test "1" (show #f (numeric #i9/8 10 0)))
|
||||
|
||||
;; precision-show, base-4
|
||||
(test "1.1230" (show #f (numeric 91/64 4 4)))
|
||||
(test "1.123" (show #f (numeric 91/64 4 3)))
|
||||
(test "1.13" (show #f (numeric 91/64 4 2)))
|
||||
(test "1.2" (show #f (numeric 91/64 4 1)))
|
||||
(test "1" (show #f (numeric 91/64 4 0)))
|
||||
|
||||
(test "1.1230" (show #f (numeric #i91/64 4 4)))
|
||||
(test "1.123" (show #f (numeric #i91/64 4 3)))
|
||||
(test "1.13" (show #f (numeric #i91/64 4 2)))
|
||||
(test "1.2" (show #f (numeric #i91/64 4 1)))
|
||||
(test "1" (show #f (numeric #i91/64 4 0)))
|
||||
|
||||
;; sign
|
||||
(test "+1" (show #f (numeric 1 10 #f #t)))
|
||||
(test "+1" (show #f (with ((sign-rule #t)) (numeric 1))))
|
||||
(test "-0.0" (show #f (with ((sign-rule #t)) (numeric -0.0))))
|
||||
(test "+0.0" (show #f (with ((sign-rule #t)) (numeric +0.0))))
|
||||
|
||||
;; comma
|
||||
(test "1,234,567" (show #f (numeric 1234567 10 #f #f 3)))
|
||||
(test "567" (show #f (numeric 567 10 #f #f 3)))
|
||||
(test "1,23,45,67" (show #f (numeric 1234567 10 #f #f 2)))
|
||||
|
||||
;; comma-sep
|
||||
(test "1|234|567" (show #f (numeric 1234567 10 #f #f 3 #\|)))
|
||||
(test "1&234&567" (show #f (with ((comma-sep #\&)) (numeric 1234567 10 #f #f 3))))
|
||||
(test "1*234*567" (show #f (with ((comma-sep #\&)) (numeric 1234567 10 #f #f 3 #\*))))
|
||||
(test "567" (show #f (numeric 567 10 #f #f 3 #\|)))
|
||||
(test "1,23,45,67" (show #f (numeric 1234567 10 #f #f 2)))
|
||||
|
||||
;; decimal
|
||||
(test "1_5" (show #f (with ((decimal-sep #\_)) (numeric 1.5))))
|
||||
(test "1,5" (show #f (with ((comma-sep #\.)) (numeric 1.5))))
|
||||
(test "1,5" (show #f (numeric 1.5 10 #f #f #f #\.)))
|
||||
(test "1%5" (show #f (numeric 1.5 10 #f #f #f #\. #\%)))
|
||||
|
||||
(cond-expand
|
||||
(complex
|
||||
(test "1+2i" (show #f (string->number "1+2i")))
|
||||
|
|
@ -151,6 +251,7 @@
|
|||
(show #f (with ((precision 2)) (string->number "3.14159+2i"))))))
|
||||
|
||||
(test "608" (show #f (numeric/si 608)))
|
||||
(test "608 B" (show #f (numeric/si 608 1000 " ") "B"))
|
||||
(test "3.9Ki" (show #f (numeric/si 3986)))
|
||||
(test "4kB" (show #f (numeric/si 3986 1000) "B"))
|
||||
(test "1.2Mm" (show #f (numeric/si 1.23e6 1000) "m"))
|
||||
|
|
@ -160,12 +261,14 @@
|
|||
(test "123m" (show #f (numeric/si 1.23e2 1000) "m"))
|
||||
(test "12.3m" (show #f (numeric/si 1.23e1 1000) "m"))
|
||||
(test "1.2m" (show #f (numeric/si 1.23 1000) "m"))
|
||||
(test "1.2 m" (show #f (numeric/si 1.23 1000 " ") "m"))
|
||||
(test "123mm" (show #f (numeric/si 0.123 1000) "m"))
|
||||
(test "12.3mm" (show #f (numeric/si 1.23e-2 1000) "m")) ;?
|
||||
(test "1.2mm" (show #f (numeric/si 1.23e-3 1000) "m"))
|
||||
(test "123µm" (show #f (numeric/si 1.23e-4 1000) "m")) ;?
|
||||
(test "12.3µm" (show #f (numeric/si 1.23e-5 1000) "m")) ;?
|
||||
(test "1.2µm" (show #f (numeric/si 1.23e-6 1000) "m"))
|
||||
(test "1.2 µm" (show #f (numeric/si 1.23e-6 1000 " ") "m"))
|
||||
|
||||
(test "1,234,567" (show #f (numeric/comma 1234567)))
|
||||
|
||||
|
|
@ -177,7 +280,9 @@
|
|||
|
||||
(test "abc " (show #f (padded 5 "abc")))
|
||||
(test " abc" (show #f (padded/left 5 "abc")))
|
||||
(test "abcdefghi" (show #f (padded/left 5 "abcdefghi")))
|
||||
(test " abc " (show #f (padded/both 5 "abc")))
|
||||
(test " abc " (show #f (padded/both 6 "abc")))
|
||||
(test "abcde" (show #f (padded 5 "abcde")))
|
||||
(test "abcdef" (show #f (padded 5 "abcdef")))
|
||||
|
||||
|
|
@ -204,6 +309,9 @@
|
|||
(test "abc :suffix" (show #f (trimmed/lazy 3 "abcde") " :suffix"))
|
||||
(test "abc :suffix" (show #f (trimmed/lazy 3 "abc\nde") " :suffix"))
|
||||
|
||||
(test "abc" (show #f (trimmed/lazy 10 (trimmed/lazy 3 "abcdefghijklmnopqrstuvwxyz"))))
|
||||
(test "abc" (show #f (trimmed/lazy 3 (trimmed/lazy 10 "abcdefghijklmnopqrstuvwxyz"))))
|
||||
|
||||
(test "abcde"
|
||||
(show #f (with ((ellipsis "...")) (trimmed 5 "abcde"))))
|
||||
(test "ab..."
|
||||
|
|
@ -286,9 +394,21 @@
|
|||
|
||||
(test "hi, bob!" (show #f (escaped "hi, bob!")))
|
||||
(test "hi, \\\"bob!\\\"" (show #f (escaped "hi, \"bob!\"")))
|
||||
(test "hi, \\'bob\\'" (show #f (escaped "hi, 'bob'" #\')))
|
||||
(test "hi, ''bob''" (show #f (escaped "hi, 'bob'" #\' #\')))
|
||||
(test "hi, ''bob''" (show #f (escaped "hi, 'bob'" #\' #f)))
|
||||
(test "line1\\nline2\\nkapow\\a\\n"
|
||||
(show #f (escaped "line1\nline2\nkapow\a\n"
|
||||
#\" #\\
|
||||
(lambda (c) (case c ((#\newline) #\n) ((#\alarm) #\a) (else #f))))))
|
||||
|
||||
(test "bob" (show #f (maybe-escaped "bob" char-whitespace?)))
|
||||
(test "\"hi, bob!\""
|
||||
(show #f (maybe-escaped "hi, bob!" char-whitespace?)))
|
||||
(test "\"foo\\\"bar\\\"baz\"" (show #f (maybe-escaped "foo\"bar\"baz" char-whitespace?)))
|
||||
(test "'hi, ''bob'''" (show #f (maybe-escaped "hi, 'bob'" (lambda (c) #f) #\' #f)))
|
||||
(test "\\" (show #f (maybe-escaped "\\" (lambda (c) #f) #\' #f)))
|
||||
(test "''''" (show #f (maybe-escaped "'" (lambda (c) #f) #\' #f)))
|
||||
|
||||
;; shared structures
|
||||
|
||||
|
|
@ -426,6 +546,18 @@
|
|||
(ones ',ones))
|
||||
(append zeros ones))))))
|
||||
|
||||
;; pretty-simply
|
||||
(let* ((d (let ((d (list 'a 'b #f)))
|
||||
(list-set! d 2 d)
|
||||
(list d)))
|
||||
(ca (circular-list 'a)))
|
||||
(test "((a b (a b (a b" (show #f (trimmed/lazy 15 (pretty-simply '((a b (a b (a b (a b)))))))))
|
||||
(test "((a b\n (a b\n" (show #f (trimmed/lazy 15 (pretty-simply d))))
|
||||
(test "'(a a\n a\n " (show #f (trimmed/lazy 15 (pretty-simply `(quote ,ca)))))
|
||||
(test "(foo\n (a a\n " (show #f (trimmed/lazy 15 (pretty-simply `(foo ,ca)))))
|
||||
(test "(with-x \n (a a" (show #f (trimmed/lazy 15 (pretty-simply `(with-x ,ca)))))
|
||||
)
|
||||
|
||||
;; columns
|
||||
|
||||
(test "abc\ndef\n"
|
||||
|
|
@ -596,4 +728,16 @@ def | 6
|
|||
(test "日本語"
|
||||
(show #f (as-unicode (with ((pad-char #\〜)) (padded/both 5 "日本語")))))
|
||||
|
||||
;; from-file
|
||||
;; for reference, filesystem-test relies on creating files under /tmp
|
||||
(let* ((tmp-file "/tmp/chibi-show-test-0123456789")
|
||||
(content-string "first line\nsecond line\nthird line"))
|
||||
(with-output-to-file tmp-file (lambda () (write-string content-string)))
|
||||
(test (string-append content-string "\n")
|
||||
(show #f (from-file tmp-file)))
|
||||
(test
|
||||
" 1 first line\n 2 second line\n 3 third line\n"
|
||||
(show #f (columnar 4 'right 'infinite (line-numbers) " " (from-file tmp-file))))
|
||||
(delete-file tmp-file))
|
||||
|
||||
(test-end))))
|
||||
|
|
|
|||
|
|
@ -464,15 +464,15 @@
|
|||
cons))
|
||||
"\n"))))))
|
||||
|
||||
(define (from-file path)
|
||||
(define (from-file path . ls)
|
||||
(let-optionals* ls ((sep nl))
|
||||
(fn ()
|
||||
(call-with-input-file path
|
||||
(lambda (in)
|
||||
(let ((in (open-input-file path)))
|
||||
(let lp ()
|
||||
(let ((line (read-line in)))
|
||||
(if (eof-object? line)
|
||||
nothing
|
||||
(each line
|
||||
(begin (close-input-port in) nothing)
|
||||
(each line sep
|
||||
(fn () (lp))))))))))
|
||||
|
||||
(define (line-numbers . o)
|
||||
|
|
|
|||
|
|
@ -63,7 +63,7 @@
|
|||
((> col width)
|
||||
(abort fail))
|
||||
(else
|
||||
(output str)))))))))
|
||||
(output-default str)))))))))
|
||||
(fn-fork
|
||||
(with ((output output*)
|
||||
(port out))
|
||||
|
|
@ -151,7 +151,7 @@
|
|||
=> cdr)
|
||||
(else #f))))
|
||||
(if (and (number? indent) (negative? indent))
|
||||
(max 0 (- (+ (length+ form) indent) 1))
|
||||
(max 0 (- (+ (or (length+ form) +inf.0) indent) 1))
|
||||
indent)))
|
||||
|
||||
(define (with-reset-shares shares proc)
|
||||
|
|
@ -182,9 +182,11 @@
|
|||
;; reset in case we don't fit on the first line
|
||||
(reset-shares (with-reset-shares shares nothing)))
|
||||
(call-with-output
|
||||
(trimmed/lazy (- width col2)
|
||||
(each " "
|
||||
(joined/shares
|
||||
(lambda (x) (pp-flat x pp shares)) fixed shares " "))
|
||||
)
|
||||
(lambda (first-line)
|
||||
(cond
|
||||
((< (+ col2 (string-width first-line)) width)
|
||||
|
|
@ -195,7 +197,7 @@
|
|||
(cond
|
||||
((not (or (null? tail) (pair? tail)))
|
||||
(each ". " (pp tail pp shares)))
|
||||
((> (length+ (cdr ls)) (or indent-rule 1))
|
||||
((> (or (length+ (cdr ls)) +inf.0) (or indent-rule 1))
|
||||
(each sep (joined/shares pp tail shares sep)))
|
||||
(else
|
||||
nothing)))))
|
||||
|
|
@ -299,7 +301,7 @@
|
|||
(cond
|
||||
;; one element list, no lines to break
|
||||
((null? (cdr ls))
|
||||
(each "(" (pretty (car ls)) ")"))
|
||||
(each "(" (pp (car ls)) ")"))
|
||||
;; quote or other abbrev
|
||||
((and (pair? (cdr ls)) (null? (cddr ls))
|
||||
(assq (car ls) syntax-abbrevs))
|
||||
|
|
@ -362,7 +364,5 @@
|
|||
|
||||
(define (pretty-simply obj)
|
||||
(fn ()
|
||||
(call-with-output
|
||||
(each (pp obj (extract-shared-objects #f #f))
|
||||
fl)
|
||||
displayed)))
|
||||
fl)))
|
||||
|
|
|
|||
|
|
@ -115,7 +115,7 @@
|
|||
(right (if (even? diff)
|
||||
left
|
||||
(make-string (+ 1 diff/2) pad-char))))
|
||||
(each right str left))
|
||||
(each left str right))
|
||||
(displayed str)))))))
|
||||
|
||||
;;> As \scheme{padded/both} but only applies padding on the right.
|
||||
|
|
@ -136,7 +136,7 @@
|
|||
(lambda (str)
|
||||
(fn (string-width pad-char)
|
||||
(let ((diff (- width (string-width str))))
|
||||
(each (make-string diff pad-char) str))))))
|
||||
(each (make-string (max 0 diff) pad-char) str))))))
|
||||
|
||||
;; General buffered trim - capture the output apply a trimmer.
|
||||
(define (trimmed/buffered width producer proc)
|
||||
|
|
@ -211,7 +211,7 @@
|
|||
;;> (e.g. \scheme{write-simple} on an infinite list). The nature of
|
||||
;;> this procedure means only truncating on the right is meaningful.
|
||||
(define (trimmed/lazy width . ls)
|
||||
(fn (orig-output string-width)
|
||||
(fn ((orig-output output) string-width)
|
||||
(call-with-current-continuation
|
||||
(lambda (return)
|
||||
(let ((chars-written 0)
|
||||
|
|
|
|||
|
|
@ -41,8 +41,9 @@
|
|||
(let-optionals* o ((quot #\")
|
||||
(esc #\\)
|
||||
(rename (lambda (x) #f)))
|
||||
(let ((quot-str (if (char? quot) (string quot) quot))
|
||||
(esc-str (if (char? esc) (string esc) esc)))
|
||||
(let ((esc-str (cond ((char? esc) (string esc))
|
||||
((not esc) (string quot))
|
||||
(else esc))))
|
||||
(fn (output)
|
||||
(define (output* str)
|
||||
(let ((start (string-cursor-start str))
|
||||
|
|
@ -97,7 +98,10 @@
|
|||
(define (integer-log a base)
|
||||
(if (zero? a)
|
||||
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
|
||||
;; Numbers Quickly and Accurately" by Burger and Dybvig
|
||||
|
|
@ -116,11 +120,11 @@
|
|||
(comma unspec) (commasep unspec) (decsep unspec))
|
||||
(fn (radix precision sign-rule
|
||||
comma-rule comma-sep decimal-sep decimal-align)
|
||||
(let ((radix (default rad radix))
|
||||
(let* ((radix (default rad radix))
|
||||
(precision (default prec precision))
|
||||
(sign-rule (default sgn sign-rule))
|
||||
(comma-rule (default comma comma-rule))
|
||||
(comma-sep (default comma-sep commasep))
|
||||
(comma-sep (default commasep comma-sep))
|
||||
(dec-sep (default decsep
|
||||
(or decimal-sep (if (eqv? comma-sep #\.) #\, #\.)))))
|
||||
;; General formatting utilities.
|
||||
|
|
@ -155,23 +159,26 @@
|
|||
(and prev (odd? prev)))))
|
||||
(round-up ls)
|
||||
ls)))
|
||||
(define (maybe-trim-zeros i res)
|
||||
(define (maybe-trim-zeros i res inexact?)
|
||||
(if (and (not precision) (positive? i))
|
||||
(let lp ((res res))
|
||||
(cond
|
||||
((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)))
|
||||
res))
|
||||
;; General slow loop to generate digits one at a time, for
|
||||
;; non-standard radixes or writing rationals with a fixed
|
||||
;; precision.
|
||||
(define (gen-general n)
|
||||
(let* ((p (exact n))
|
||||
(define (gen-general n-orig)
|
||||
(let* ((p (exact n-orig))
|
||||
(n (numerator p))
|
||||
(d (denominator p)))
|
||||
(let lp ((n n)
|
||||
(i (- (integer-log p radix)))
|
||||
(i (if (zero? p) -1 (- (integer-log p radix))))
|
||||
(res '()))
|
||||
(cond
|
||||
;; Use a fixed precision if specified, otherwise generate
|
||||
|
|
@ -182,8 +189,8 @@
|
|||
res))
|
||||
(q (quotient n d)))
|
||||
(cond
|
||||
((>= q radix)
|
||||
(let* ((scale (get-scale q))
|
||||
((< i -1)
|
||||
(let* ((scale (expt radix (- -1 i)))
|
||||
(digit (quotient q scale))
|
||||
(n2 (- n (* d digit scale))))
|
||||
(lp n2 (+ i 1) (cons digit res))))
|
||||
|
|
@ -194,7 +201,7 @@
|
|||
(else
|
||||
(list->string
|
||||
(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
|
||||
;; result of string->number.
|
||||
(define (gen-fixed n)
|
||||
|
|
@ -242,11 +249,11 @@
|
|||
(precision
|
||||
(gen-fixed 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)))
|
||||
(number->string n))
|
||||
(number->string n radix))
|
||||
(else
|
||||
(gen-general n))))
|
||||
;; Insert commas according to the current comma-rule.
|
||||
|
|
@ -272,14 +279,26 @@
|
|||
(if comma-rule (insert-commas s1) s1)))
|
||||
;; Wrap the sign of a real number, forcing a + prefix or using
|
||||
;; 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)
|
||||
(cond
|
||||
((negative? n)
|
||||
((negative?* n)
|
||||
(if (char? sign-rule)
|
||||
(string-append (string sign-rule)
|
||||
(wrap-comma (abs n))
|
||||
(wrap-comma (- n))
|
||||
(string (char-mirror sign-rule)))
|
||||
(string-append "-" (wrap-comma (abs n)))))
|
||||
(string-append "-" (wrap-comma (- n)))))
|
||||
((eq? #t sign-rule)
|
||||
(string-append "+" (wrap-comma n)))
|
||||
(else
|
||||
|
|
@ -335,7 +354,8 @@
|
|||
(each (if (integer? n2)
|
||||
(number->string (exact n2))
|
||||
(inexact n2))
|
||||
(if (zero? k) "" separator)
|
||||
;; (if (zero? k) "" separator)
|
||||
separator
|
||||
(vector-ref names k)))))))
|
||||
|
||||
;; Force a number into a fixed width, print as #'s if doesn't fit.
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue