mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 13:49:17 +02:00
509 lines
21 KiB
Scheme
509 lines
21 KiB
Scheme
;; write.scm - written formatting, the default displayed for non-string/chars
|
|
;; Copyright (c) 2006-2019 Alex Shinn. All rights reserved.
|
|
;; BSD-style license: http://synthcode.com/license.txt
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;> \section{String utilities}
|
|
|
|
(define (write-to-string x)
|
|
(call-with-output-string (lambda (out) (write x out))))
|
|
|
|
(define (string-replace-all str ch1 ch2)
|
|
(let ((out (open-output-string)))
|
|
(string-for-each
|
|
(lambda (ch) (display (if (eqv? ch ch1) ch2 ch) out))
|
|
str)
|
|
(get-output-string out)))
|
|
|
|
(define (string-intersperse-right str sep rule)
|
|
(let ((start (string-cursor-start str)))
|
|
(let lp ((i (string-cursor-end str))
|
|
(rule rule)
|
|
(res '()))
|
|
(let* ((offset (if (pair? rule) (car rule) rule))
|
|
(i2 (if offset (string-cursor-back str i offset) start)))
|
|
(if (string-cursor<=? i2 start)
|
|
(apply string-append (cons (substring/cursors str start i) res))
|
|
(lp i2
|
|
(if (and (pair? rule) (not (null? (cdr rule)))) (cdr rule) rule)
|
|
(cons sep (cons (substring/cursors str i2 i) res))))))))
|
|
|
|
;;> Outputs the string str, escaping any quote or escape characters.
|
|
;;> If esc-ch, which defaults to #\\, is #f, escapes only the
|
|
;;> quote-ch, which defaults to #\", by doubling it, as in SQL strings
|
|
;;> and CSV values. If renamer is provided, it should be a procedure
|
|
;;> of one character which maps that character to its escape value,
|
|
;;> e.g. #\newline => #\n, or #f if there is no escape value.
|
|
|
|
(define (escaped fmt . o)
|
|
(let-optionals* o ((quot #\")
|
|
(esc #\\)
|
|
(rename (lambda (x) #f)))
|
|
(let ((esc-str (cond ((char? esc) (string esc))
|
|
((not esc) (string quot))
|
|
(else esc))))
|
|
(fn ((orig-output output))
|
|
(define (output* str)
|
|
(let ((start (string-cursor-start str))
|
|
(end (string-cursor-end str)))
|
|
(let lp ((i start) (j start))
|
|
(define (collect)
|
|
(if (eq? i j) "" (substring/cursors str i j)))
|
|
(if (string-cursor>=? j end)
|
|
(orig-output (collect))
|
|
(let ((c (string-ref/cursor str j))
|
|
(j2 (string-cursor-next str j)))
|
|
(cond
|
|
((or (eqv? c quot) (eqv? c esc))
|
|
(each (orig-output (collect))
|
|
(orig-output esc-str)
|
|
(fn () (lp j j2))))
|
|
((rename c)
|
|
=> (lambda (c2)
|
|
(each (orig-output (collect))
|
|
(orig-output esc-str)
|
|
(orig-output (if (char? c2) (string c2) c2))
|
|
(fn () (lp j2 j2)))))
|
|
(else
|
|
(lp i j2))))))))
|
|
(with ((output output*))
|
|
fmt)))))
|
|
|
|
;;> Only escape if there are special characters, in which case also
|
|
;;> wrap in quotes. For writing symbols in |...| escapes, or CSV
|
|
;;> fields, etc. The predicate indicates which characters cause
|
|
;;> slashification - this is in addition to automatic slashifying when
|
|
;;> either the quote or escape char is present.
|
|
|
|
(define (maybe-escaped fmt pred . o)
|
|
(let-optionals* o ((quot #\")
|
|
(esc #\\)
|
|
(rename (lambda (x) #f)))
|
|
(define (esc? c) (or (eqv? c quot) (eqv? c esc) (rename c) (pred c)))
|
|
(call-with-output
|
|
fmt
|
|
(lambda (str)
|
|
(if (string-cursor<? (string-index str esc?) (string-cursor-end str))
|
|
(each quot (escaped str quot esc rename) quot)
|
|
(displayed str))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; numeric formatting
|
|
|
|
(define (char-mirror c)
|
|
(case c ((#\() #\)) ((#\[) #\]) ((#\{) #\}) ((#\<) #\>) (else c)))
|
|
|
|
(define (integer-log a base)
|
|
(if (zero? a)
|
|
0
|
|
;; (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
|
|
;; (FP-Printing-PLDI96.pdf). It had grown unwieldy with formatting
|
|
;; special cases, so the below is a simplification which tries to rely
|
|
;; on number->string for common cases.
|
|
|
|
(define unspec (list 'unspecified))
|
|
|
|
(define-syntax default
|
|
(syntax-rules ()
|
|
((default var dflt) (if (eq? var unspec) dflt var))))
|
|
|
|
(define (numeric n . o)
|
|
(let-optionals* o ((rad unspec) (prec unspec) (sgn unspec)
|
|
(comma unspec) (commasep unspec) (decsep unspec))
|
|
(fn (radix precision sign-rule
|
|
comma-rule comma-sep decimal-sep decimal-align)
|
|
(let* ((radix (default rad radix))
|
|
(precision (default prec precision))
|
|
(sign-rule (default sgn sign-rule))
|
|
(comma-rule (default comma comma-rule))
|
|
(comma-sep (default commasep comma-sep))
|
|
(dec-sep (default decsep
|
|
(or decimal-sep (if (eqv? comma-sep #\.) #\, #\.))))
|
|
(dec-ls (if (char? dec-sep)
|
|
(list dec-sep)
|
|
(reverse (string->list dec-sep)))))
|
|
;; General formatting utilities.
|
|
(define (get-scale q)
|
|
(expt radix (- (integer-log q radix) 1)))
|
|
(define (char-digit d)
|
|
(cond ((char? d) d)
|
|
((< d 10) (integer->char (+ d (char->integer #\0))))
|
|
(else (integer->char (+ (- d 10) (char->integer #\a))))))
|
|
(define (digit-value ch)
|
|
(let ((res (- (char->integer ch) (char->integer #\0))))
|
|
(if (<= 0 res 9)
|
|
res
|
|
ch)))
|
|
(define (round-up ls)
|
|
(let lp ((ls ls) (res '()))
|
|
(cond
|
|
((null? ls)
|
|
(cons 1 res))
|
|
((not (number? (car ls)))
|
|
(lp (cdr ls) (cons (car ls) res)))
|
|
((= (car ls) (- radix 1))
|
|
(lp (cdr ls) (cons 0 res)))
|
|
(else
|
|
(append (reverse res) (cons (+ 1 (car ls)) (cdr ls)))))))
|
|
(define (maybe-round n d ls)
|
|
(let* ((q (quotient n d))
|
|
(digit (* 2 (if (>= q radix) (quotient q (get-scale q)) q))))
|
|
(if (or (> digit radix)
|
|
(and (= digit radix)
|
|
(let ((prev (find integer? ls)))
|
|
(and prev (odd? prev)))))
|
|
(round-up ls)
|
|
ls)))
|
|
(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? (car dec-ls) (car res))
|
|
(null? (cdr dec-ls)))
|
|
(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-orig)
|
|
(let* ((p (exact n-orig))
|
|
(n (numerator p))
|
|
(d (denominator p)))
|
|
(let lp ((n n)
|
|
(i (if (zero? p) -1 (- (integer-log p radix))))
|
|
(res '()))
|
|
(cond
|
|
;; Use a fixed precision if specified, otherwise generate
|
|
;; 15 decimals.
|
|
((if precision (< i precision) (< i 16))
|
|
(let ((res (if (zero? i)
|
|
(append dec-ls (if (null? res) (cons 0 res) res))
|
|
res))
|
|
(q (quotient n d)))
|
|
(cond
|
|
((< i -1)
|
|
(let* ((scale (expt radix (- -1 i)))
|
|
(digit (quotient q scale))
|
|
(n2 (- n (* d digit scale))))
|
|
(lp n2 (+ i 1) (cons digit res))))
|
|
(else
|
|
(lp (* (remainder n d) radix)
|
|
(+ i 1)
|
|
(cons q res))))))
|
|
(else
|
|
(list->string
|
|
(map char-digit
|
|
(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)
|
|
(cond
|
|
((and (eqv? radix 10) (zero? precision) (inexact? n))
|
|
(number->string (exact (round n))))
|
|
((and (eqv? radix 10) (or (integer? n) (inexact? n)))
|
|
(let* ((s (number->string n))
|
|
(end (string-cursor-end s))
|
|
(dec (string-index s #\.))
|
|
(digits (- (string-cursor->index s end)
|
|
(string-cursor->index s dec))))
|
|
(cond
|
|
((string-cursor<? (string-index s #\e) end)
|
|
(gen-general n))
|
|
((string-cursor=? dec end)
|
|
(string-append s (if (char? dec-sep) (string dec-sep) dec-sep)
|
|
(make-string precision #\0)))
|
|
((<= digits precision)
|
|
(string-append s (make-string (- precision digits -1) #\0)))
|
|
(else
|
|
(let* ((last
|
|
(string-cursor-back s end (- digits precision 1)))
|
|
(res (substring/cursors s (string-cursor-start s) last)))
|
|
(if (and
|
|
(string-cursor<? last end)
|
|
(let ((next (digit-value (string-ref/cursor s last))))
|
|
(or (> next 5)
|
|
(and (= next 5)
|
|
(string-cursor>? last (string-cursor-start s))
|
|
(memv (digit-value
|
|
(string-ref/cursor
|
|
s (string-cursor-prev s last)))
|
|
'(1 3 5 7 9))))))
|
|
(list->string
|
|
(reverse
|
|
(map char-digit
|
|
(round-up
|
|
(reverse (map digit-value (string->list res)))))))
|
|
res))))))
|
|
(else
|
|
(gen-general n))))
|
|
;; Generate any unsigned real number.
|
|
(define (gen-positive-real n)
|
|
(cond
|
|
(precision
|
|
(gen-fixed n))
|
|
((memv radix (if (exact? n) '(2 8 10 16) '(10)))
|
|
(number->string n radix))
|
|
(else
|
|
(gen-general n))))
|
|
;; Insert commas according to the current comma-rule.
|
|
(define (insert-commas str)
|
|
(let* ((dec-pos (if (string? dec-sep)
|
|
(or (string-contains str dec-sep)
|
|
(string-cursor-end str))
|
|
(string-index str dec-sep)))
|
|
(left (substring/cursors str (string-cursor-start str) dec-pos))
|
|
(right (string-copy/cursors str dec-pos))
|
|
(sep (cond ((char? comma-sep) (string comma-sep))
|
|
((string? comma-sep) comma-sep)
|
|
((eqv? #\, dec-sep) ".")
|
|
(else ","))))
|
|
(string-append
|
|
(string-intersperse-right left sep comma-rule)
|
|
right)))
|
|
;; Post-process a positive real number with decimal char fixup
|
|
;; and commas as needed.
|
|
(define (wrap-comma n)
|
|
(if (and (not precision) (exact? n) (not (integer? n)))
|
|
(string-append (wrap-comma (numerator n))
|
|
"/"
|
|
(wrap-comma (denominator n)))
|
|
(let* ((s0 (gen-positive-real n))
|
|
(s1 (if (or (eqv? #\. dec-sep)
|
|
(equal? "." dec-sep))
|
|
s0
|
|
(string-replace-all s0 #\. dec-sep))))
|
|
(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)
|
|
(cond
|
|
((char? sign-rule)
|
|
(string-append (string sign-rule)
|
|
(wrap-comma (- n))
|
|
(string (char-mirror sign-rule))))
|
|
((pair? sign-rule)
|
|
(string-append (car sign-rule)
|
|
(wrap-comma (- n))
|
|
(cdr sign-rule)))
|
|
(else
|
|
(string-append "-" (wrap-comma (- n))))))
|
|
((eq? #t sign-rule)
|
|
(string-append "+" (wrap-comma n)))
|
|
(else
|
|
(wrap-comma n))))
|
|
;; Format a single real number with padding as necessary.
|
|
(define (format n sign-rule)
|
|
(cond
|
|
((finite? n)
|
|
(let* ((s (wrap-sign n sign-rule))
|
|
(dec-pos (if decimal-align
|
|
(string-cursor->index
|
|
s
|
|
(if (char? dec-sep)
|
|
(string-index s dec-sep)
|
|
(or (string-contains s dec-sep)
|
|
(string-cursor-end s))))
|
|
0))
|
|
(diff (- (or decimal-align 0) dec-pos 1)))
|
|
(if (positive? diff)
|
|
(string-append (make-string diff #\space) s)
|
|
s)))
|
|
(else
|
|
(number->string n))))
|
|
;; Write any number.
|
|
(define (write-complex n)
|
|
(cond
|
|
((and radix (not (and (integer? radix) (<= 2 radix 36))))
|
|
(error "invalid radix for numeric formatting" radix))
|
|
((zero? (imag-part n))
|
|
(displayed (format (real-part n) sign-rule)))
|
|
(else
|
|
(each (format (real-part n) sign-rule)
|
|
(format (imag-part n) #t)
|
|
"i"))))
|
|
(write-complex n)))))
|
|
|
|
(define numeric/si
|
|
(let* ((names10 '#("" "k" "M" "G" "T" "E" "P" "Z" "Y"))
|
|
(names-10 '#("" "m" "µ" "n" "p" "f" "a" "z" "y"))
|
|
(names2 (list->vector
|
|
(cons ""
|
|
(cons "Ki" (map (lambda (s) (string-append s "i"))
|
|
(cddr (vector->list names10)))))))
|
|
(names-2 (list->vector
|
|
(cons ""
|
|
(map (lambda (s) (string-append s "i"))
|
|
(cdr (vector->list names-10)))))))
|
|
(define (round-to n k)
|
|
(/ (round (* n k)) k))
|
|
(lambda (n . o)
|
|
(let-optionals* o ((base 1000)
|
|
(separator ""))
|
|
(if (zero? n)
|
|
"0"
|
|
(let* ((log-n (log (abs n)))
|
|
(names (if (negative? log-n)
|
|
(if (= base 1024) names-2 names-10)
|
|
(if (= base 1024) names2 names10)))
|
|
(k (min (exact ((if (negative? log-n) ceiling floor)
|
|
(/ (abs log-n) (log base))))
|
|
(- (vector-length names) 1)))
|
|
(n2 (round-to (/ (abs n)
|
|
(expt base (if (negative? log-n) (- k) k)))
|
|
10)))
|
|
(each (if (negative? n) "-" "")
|
|
(if (integer? n2)
|
|
(number->string (exact n2))
|
|
(inexact n2))
|
|
;; (if (zero? k) "" separator)
|
|
separator
|
|
(vector-ref names k))))))))
|
|
|
|
;; Force a number into a fixed width, print as #'s if doesn't fit.
|
|
;; Needs to be wrapped in PADDED if you want to expand to the width.
|
|
|
|
(define (numeric/fitted width n . args)
|
|
(call-with-output
|
|
(apply numeric n args)
|
|
(lambda (str)
|
|
(if (> (string-length str) width)
|
|
(fn (precision decimal-sep comma-sep)
|
|
(let ((prec (if (and (pair? args) (pair? (cdr args)))
|
|
(cadr args)
|
|
precision)))
|
|
(if (and prec (not (zero? prec)))
|
|
(let* ((dec-sep
|
|
(or decimal-sep
|
|
(if (eqv? #\. comma-sep) #\, #\.)))
|
|
(diff (- width (+ prec
|
|
(if (char? dec-sep)
|
|
1
|
|
(string-length dec-sep))))))
|
|
(each (if (positive? diff) (make-string diff #\#) "")
|
|
dec-sep (make-string prec #\#)))
|
|
(displayed (make-string width #\#)))))
|
|
(displayed str)))))
|
|
|
|
(define (numeric/comma n . o)
|
|
(fn ((orig-comma-rule comma-rule))
|
|
(with ((comma-rule (if (pair? o) (car o) (or orig-comma-rule 3))))
|
|
(apply numeric n (if (pair? o) (cdr o) '())))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; written
|
|
|
|
(define (write-with-shares obj shares)
|
|
(fn ((orig-radix radix) precision)
|
|
(let ((write-number
|
|
;; Shortcut for numeric values. Try to rely on
|
|
;; number->string for standard radixes and no precision,
|
|
;; otherwise fall back on numeric but resetting to a usable
|
|
;; radix.
|
|
(cond
|
|
((and (not precision)
|
|
(assv orig-radix
|
|
'((16 . "#x") (10 . "") (8 . "#o") (2 . "#b"))))
|
|
=> (lambda (cell)
|
|
(lambda (n)
|
|
(cond
|
|
((eqv? orig-radix 10)
|
|
(displayed (number->string n (car cell))))
|
|
((exact? n)
|
|
(each (cdr cell) (number->string n (car cell))))
|
|
(else
|
|
(with ((radix 10)) (numeric n)))))))
|
|
(else (lambda (n) (with ((radix 10)) (numeric n)))))))
|
|
;; `wr' is the recursive writer closing over the shares.
|
|
(let wr ((obj obj))
|
|
(call-with-shared-ref
|
|
obj shares each
|
|
(fn ()
|
|
(cond
|
|
((pair? obj)
|
|
(each "("
|
|
(fn ()
|
|
(let lp ((ls obj))
|
|
(let ((rest (cdr ls)))
|
|
(each (wr (car ls))
|
|
(cond
|
|
((null? rest)
|
|
nothing)
|
|
((pair? rest)
|
|
(each
|
|
" "
|
|
(call-with-shared-ref/cdr
|
|
rest shares each
|
|
(fn () (lp rest)))))
|
|
(else
|
|
(each " . " (wr rest))))))))
|
|
")"))
|
|
((vector? obj)
|
|
(let ((len (vector-length obj)))
|
|
(if (zero? len)
|
|
(displayed "#()")
|
|
(each "#("
|
|
(wr (vector-ref obj 0))
|
|
(fn ()
|
|
(let lp ((i 1))
|
|
(if (>= i len)
|
|
nothing
|
|
(each " " (wr (vector-ref obj i))
|
|
(fn () (lp (+ i 1)))))))
|
|
")"))))
|
|
((number? obj)
|
|
(write-number obj))
|
|
(else
|
|
(displayed (write-to-string obj))))))))))
|
|
|
|
;; The default formatter for `written', overriden with the `writer'
|
|
;; variable. Intended to be equivalent to `write', using datum labels
|
|
;; for shared notation iff there are cycles in the object.
|
|
|
|
(define (written-default obj)
|
|
(fn ()
|
|
(write-with-shares obj (extract-shared-objects obj #t))))
|
|
|
|
;; Writes the object showing the full shared structure.
|
|
|
|
(define (written-shared obj)
|
|
(fn ()
|
|
(write-with-shares obj (extract-shared-objects obj #f))))
|
|
|
|
;; The only expensive part, in both time and memory, of handling
|
|
;; shared structures when writing is building the initial table, so
|
|
;; for the efficient version we just skip that and re-use the writing
|
|
;; code.
|
|
|
|
(define (written-simply obj)
|
|
(fn ()
|
|
(write-with-shares obj (extract-shared-objects #f #f))))
|
|
|
|
;; Local variables:
|
|
;; eval: (put 'fn 'scheme-indent-function 1)
|
|
;; End:
|