source: project/release/3/fmt/fmt.scm @ 10190

Last change on this file since 10190 was 10190, checked in by Alex Shinn, 12 years ago

Updating to version 0.513.

File size: 38.5 KB
Line 
1;;;; fmt.scm -- extensible formatting library
2;;
3;; Copyright (c) 2006-2007 Alex Shinn.  All rights reserved.
4;; BSD-style license: http://synthcode.com/license.txt
5
6;; (require-extension (srfi 1 6 13 23 69))
7
8;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
9;;; string utilities
10
11(define (write-to-string x)
12  (call-with-output-string (lambda (p) (write x p))))
13
14(define (display-to-string x)
15  (if (string? x)
16      x
17      (call-with-output-string (lambda (p) (display x p)))))
18
19(define nl-str
20  (call-with-output-string newline))
21
22(define (make-space n) (make-string n #\space))
23(define (make-nl-space n) (string-append nl-str (make-string n #\space)))
24
25;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26;;; list utilities
27
28(define (take* ls n)   ; handles dotted lists and n > length
29  (cond ((zero? n) '())
30        ((pair? ls) (cons (car ls) (take* (cdr ls) (- n 1))))
31        (else '())))
32
33(define (drop* ls n)   ; may return the dot
34  (cond ((zero? n) ls)
35        ((pair? ls) (drop* (cdr ls) (- n 1)))
36        (else ls)))
37
38;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
39;;; format state representation
40
41;; Use a flexible representation optimized for common cases -
42;; frequently accessed values are in fixed vector slots, with a
43;; `properties' slot holding an alist for all other values.
44
45(define *default-fmt-state*
46  (vector 0 0 10 '() #\space #f 78 #f #f #f #f #f))
47
48(define fmt-state? vector?)
49
50(define (new-fmt-state . o)
51  (let ((st (if (pair? o) (car o) (current-output-port))))
52    (if (vector? st)
53        st
54        (fmt-set-writer!
55         (fmt-set-port! (copy-fmt-state *default-fmt-state*) st)
56         fmt-write))))
57
58(define (copy-fmt-state st)
59  (let* ((len (vector-length st))
60         (res (make-vector len)))
61    (do ((i 0 (+ i 1)))
62        ((= i len))
63      (vector-set! res i (vector-ref st i)))
64    (fmt-set-properties! res (map (lambda (x) (cons (car x) (cdr x)))
65                                  (fmt-properties res)))
66    res))
67
68(define (fmt-row st) (vector-ref st 0))
69(define (fmt-col st) (vector-ref st 1))
70(define (fmt-radix st) (vector-ref st 2))
71(define (fmt-properties st) (vector-ref st 3))
72(define (fmt-pad-char st) (vector-ref st 4))
73(define (fmt-precision st) (vector-ref st 5))
74(define (fmt-width st) (vector-ref st 6))
75(define (fmt-writer st) (vector-ref st 7))
76(define (fmt-port st) (vector-ref st 8))
77(define (fmt-decimal-sep st) (vector-ref st 9))
78(define (fmt-string-width st) (vector-ref st 10))
79(define (fmt-ellipses st) (vector-ref st 11))
80
81(define (fmt-set-row! st x) (vector-set! st 0 x) st)
82(define (fmt-set-col! st x) (vector-set! st 1 x) st)
83(define (fmt-set-radix! st x) (vector-set! st 2 x) st)
84(define (fmt-set-properties! st x) (vector-set! st 3 x) st)
85(define (fmt-set-pad-char! st x) (vector-set! st 4 x) st)
86(define (fmt-set-precision! st x) (vector-set! st 5 x) st)
87(define (fmt-set-width! st x) (vector-set! st 6 x) st)
88(define (fmt-set-writer! st x) (vector-set! st 7 x) st)
89(define (fmt-set-port! st x) (vector-set! st 8 x) st)
90(define (fmt-set-decimal-sep! st x) (vector-set! st 9 x) st)
91(define (fmt-set-string-width! st x) (vector-set! st 10 x) st)
92(define (fmt-set-ellipses! st x) (vector-set! st 11 x) st)
93
94(define (fmt-ref st key . o)
95  (case key
96    ((row) (fmt-row st))
97    ((col) (fmt-col st))
98    ((radix) (fmt-radix st))
99    ((properties) (fmt-properties st))
100    ((writer) (fmt-writer st))
101    ((port) (fmt-port st))
102    ((precision) (fmt-precision st))
103    ((pad-char) (fmt-pad-char st))
104    ((width) (fmt-width st))
105    ((decimal-sep) (fmt-decimal-sep st))
106    ((string-width) (fmt-string-width st))
107    ((ellipses) (fmt-ellipses st))
108    (else (cond ((assq key (fmt-properties st)) => cdr)
109                ((pair? o) (car o))
110                (else #f)))))
111
112(define (fmt-set-property! st key val)
113  (cond ((assq key (fmt-properties st))
114         => (lambda (cell) (set-cdr! cell val) st))
115        (else (fmt-set-properties!
116               st
117               (cons (cons key val) (fmt-properties st))))))
118
119(define (fmt-set! st key val)
120  (case key
121    ((row) (fmt-set-row! st val))
122    ((col) (fmt-set-col! st val))
123    ((radix) (fmt-set-radix! st val))
124    ((properties) (fmt-set-properties! st val))
125    ((pad-char) (fmt-set-pad-char! st val))
126    ((precision) (fmt-set-precision! st val))
127    ((writer) (fmt-set-writer! st val))
128    ((port) (fmt-set-port! st val))
129    ((width) (fmt-set-width! st val))
130    ((decimal-sep) (fmt-set-decimal-sep! st val))
131    ((string-width) (fmt-set-string-width! st val))
132    ((ellipses) (fmt-set-ellipses! st val))
133    (else (fmt-set-property! st key val))))
134
135(define (fmt-add-properties! st alist)
136  (for-each (lambda (x) (fmt-set! st (car x) (cdr x))) alist)
137  st)
138
139(define (fmt-let key val . ls)
140  (lambda (st)
141    (let ((orig-val (fmt-ref st key)))
142      (fmt-set! ((apply-cat ls) (fmt-set! st key val)) key orig-val))))
143
144(define (fmt-bind key val . ls)
145  (lambda (st) ((apply-cat ls) (fmt-set! st key val))))
146
147(define (fix prec . ls) (fmt-let 'precision prec (apply-cat ls)))
148(define (radix rad . ls) (fmt-let 'radix rad (apply-cat ls)))
149(define (pad-char ch . ls) (fmt-let 'pad-char ch (apply-cat ls)))
150(define (comma-char ch . ls) (fmt-let 'comma-char ch (apply-cat ls)))
151(define (decimal-char ch . ls) (fmt-let 'decimal-sep ch (apply-cat ls)))
152(define (with-width w . ls) (fmt-let 'width w (apply-cat ls)))
153(define (ellipses ell . ls) (fmt-let 'ellipses ell (apply-cat ls)))
154
155;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
156;;; the basic interface
157
158(define (fmt-start st initializer proc)
159  (cond
160    ((or (output-port? st) (fmt-state? st))
161     (proc (initializer st))
162     (if #f #f))
163    ((eq? #t st)
164     (proc (initializer (current-output-port)))
165     (if #f #f))
166    ((eq? #f st)
167     (get-output-string
168      (fmt-port (proc (initializer (open-output-string))))))
169    (else (error "unknown format output" st))))
170
171(define (fmt st . args)
172  (fmt-start st new-fmt-state (apply-cat args)))
173
174(define (fmt-update str st)
175  (let ((len (string-length str))
176        (nli (string-index-right str #\newline))
177        (str-width (fmt-string-width st)))
178    (if nli
179        (let ((row (+ (fmt-row st) 1 (string-count str #\newline 0 nli))))
180          (fmt-set-row!
181           (fmt-set-col! st (if str-width
182                                (str-width str (+ nli 1) len)
183                                (- len (+ nli 1))))
184           row))
185        (fmt-set-col! st (+ (fmt-col st)
186                            (if str-width
187                                (str-width str 0 len)
188                                len))))))
189
190(define (fmt-write str st)
191  (display str (fmt-port st))
192  (fmt-update str st))
193
194(define (apply-cat procs)
195  (lambda (st)
196    (let loop ((ls procs) (st st))
197      (if (null? ls)
198          st
199          (loop (cdr ls) ((dsp (car ls)) st))))))
200
201(define (cat . ls) (apply-cat ls))
202
203(define (fmt-null st) st)
204
205;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
206;;; control structures
207
208(define (fmt-if check pass . o)
209  (let ((fail (if (pair? o) (car o) (lambda (x) x))))
210    (lambda (st) (if (check st) ((dsp pass) st) ((dsp fail) st)))))
211
212(define (fmt-try-fit proc . fail)
213  (if (null? fail)
214      proc
215      (lambda (orig-st)
216        (let ((width (fmt-width orig-st))
217              (buffer '()))
218          (call-with-current-continuation
219            (lambda (return)
220              (define (output* str st)
221                (let lp ((i 0) (col (fmt-col st)))
222                  (let ((nli (string-index str #\newline i)))
223                    (if nli
224                        (if (> (+ (- nli i) col) width)
225                            (return ((apply fmt-try-fit fail) orig-st))
226                            (lp (+ nli 1) 0))
227                        (let* ((len (string-length str))
228                               (col (+ (- len i) col)))
229                          (if (> col width)
230                              (return ((apply fmt-try-fit fail) orig-st))
231                              (begin
232                                (set! buffer (cons str buffer))
233                                (fmt-update str st))))))))
234              (proc (fmt-set-port! (fmt-set-writer! (copy-fmt-state orig-st)
235                                                    output*)
236                                   (open-output-string)))
237              ((fmt-writer orig-st)
238               (string-concatenate-reverse buffer)
239               orig-st)))))))
240
241(define (fits-in-width gen width)
242  (lambda (st)
243    (let ((output (fmt-writer st))
244          (port (open-output-string)))
245      (call-with-current-continuation
246        (lambda (return)
247          (define (output* str st)
248            (let ((st (fmt-update str st)))
249              (if (> (fmt-col st) width)
250                  (return #f)
251                  (begin
252                    (display str port)
253                    st))))
254          (gen (fmt-set-port! (fmt-set-writer! (copy-fmt-state st) output*)
255                              port))
256          (get-output-string port))))))
257
258(define (fits-in-columns ls write width)
259  (lambda (st)
260    (let ((max-w (quotient width 2)))
261      (let lp ((ls ls) (res '()) (widest 0))
262        (cond
263          ((pair? ls)
264           (let ((str ((fits-in-width (write (car ls)) max-w) st)))
265             (and str
266                  (lp (cdr ls)
267                      (cons str res)
268                      (max (string-length str) widest)))))
269          ((null? ls) (cons widest (reverse res)))
270          (else #f))))))
271
272(define (fmt-capture producer consumer)
273  (lambda (st)
274    (let ((port (open-output-string)))
275      (producer (fmt-set-writer! (fmt-set-port! (copy-fmt-state st) port)
276                                 fmt-write))
277      ((consumer (get-output-string port)) st))))
278
279(define (fmt-to-string producer)
280  (fmt-capture producer (lambda (str) (lambda (st) str))))
281
282;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
283;;; standard formatters
284
285(define (nl st)
286  ((fmt-writer st) nl-str st))
287
288;; output a newline iff we're not at the start of a fresh line
289(define (fl st)
290  (if (zero? (fmt-col st)) st (nl st)))
291
292;; tab to a given tab-stop
293(define (tab-to . o)
294  (lambda (st)
295    (let* ((tab-width (if (pair? o) (car o) 8))
296           (rem (modulo (fmt-col st) tab-width)))
297      (if (positive? rem)
298          ((fmt-writer st)
299           (make-string (- tab-width rem) (fmt-pad-char st))
300           st)
301          st))))
302
303;; move to an explicit column
304(define (space-to col)
305  (lambda (st)
306    (let ((width (- col (fmt-col st))))
307      (if (positive? width)
308          ((fmt-writer st) (make-string width (fmt-pad-char st)) st)
309          st))))
310
311(define (fmt-join fmt ls . o)
312  (let ((sep (dsp (if (pair? o) (car o) ""))))
313    (lambda (st)
314      (if (null? ls)
315          st
316          (let lp ((ls (cdr ls))
317                   (st ((fmt (car ls)) st)))
318            (if (null? ls)
319                st
320                (lp (cdr ls) ((fmt (car ls)) (sep st)))))))))
321
322(define (fmt-join/prefix fmt ls . o)
323  (if (null? ls)
324      fmt-null
325      (let ((sep (dsp (if (pair? o) (car o) ""))))
326        (cat sep (fmt-join fmt ls sep)))))
327(define (fmt-join/suffix fmt ls . o)
328  (if (null? ls)
329      fmt-null
330      (let ((sep (dsp (if (pair? o) (car o) ""))))
331        (cat (fmt-join fmt ls sep) sep))))
332
333(define (fmt-join/last fmt fmt/last ls . o)
334  (let ((sep (dsp (if (pair? o) (car o) ""))))
335    (lambda (st)
336      (cond
337        ((null? ls)
338         st)
339        ((null? (cdr ls))
340         ((fmt/last (car ls)) (sep st)))
341        (else
342         (let lp ((ls (cdr ls))
343                  (st ((fmt (car ls)) st)))
344           (if (null? (cdr ls))
345               ((fmt/last (car ls)) (sep st))
346               (lp (cdr ls) ((fmt (car ls)) (sep st))))))))))
347
348(define (fmt-join/dot fmt fmt/dot ls . o)
349  (let ((sep (dsp (if (pair? o) (car o) ""))))
350    (lambda (st)
351      (cond
352        ((pair? ls)
353         (let lp ((ls (cdr ls))
354                  (st ((fmt (car ls)) st)))
355           (cond
356             ((null? ls) st)
357             ((pair? ls) (lp (cdr ls) ((fmt (car ls)) (sep st))))
358             (else ((fmt/dot ls) (sep st))))))
359        ((null? ls) st)
360        (else ((fmt/dot ls) st))))))
361
362(define (fmt-join/range fmt start . o)
363  (let-optionals* o ((end #f) (sep ""))
364    (lambda (st)
365      (let lp ((i (+ start 1)) (st ((fmt start) st)))
366        (if (and end (>= i end))
367            st
368            (lp (+ i 1) ((fmt i) ((dsp sep) st))))))))
369
370(define (pad/both width . ls)
371  (fmt-capture
372   (apply-cat ls)
373   (lambda (str)
374     (lambda (st)
375       (let ((diff (- width ((or (fmt-string-width st) string-length) str)))
376             (output (fmt-writer st)))
377         (if (positive? diff)
378             (let* ((diff/2 (quotient diff 2))
379                    (left (make-string diff/2 (fmt-pad-char st)))
380                    (right (if (even? diff)
381                               left
382                               (make-string (+ 1 diff/2) (fmt-pad-char st)))))
383               (output right (output str (output left st))))
384             (output str st)))))))
385
386(define (pad width . ls)
387  (lambda (st)
388    (let* ((col (fmt-col st))
389           (padder
390            (lambda (st)
391              (let ((diff (- width (- (fmt-col st) col))))
392                (if (positive? diff)
393                    ((fmt-writer st) (make-string diff (fmt-pad-char st)) st)
394                    st)))))
395      ((cat (apply-cat ls) padder) st))))
396
397(define pad/right pad)
398
399(define (pad/left width . ls)
400  (fmt-capture
401   (apply-cat ls)
402   (lambda (str)
403     (lambda (st)
404       (let* ((str-width ((or (fmt-string-width st) string-length) str))
405              (diff (- width str-width)))
406         ((fmt-writer st)
407          str
408          (if (positive? diff)
409              ((fmt-writer st) (make-string diff (fmt-pad-char st)) st)
410              st)))))))
411
412(define (trim/buffered width fmt proc)
413  (fmt-capture
414   fmt
415   (lambda (str)
416     (lambda (st)
417       (let* ((str-width ((or (fmt-string-width st) string-length) str))
418              (diff (- str-width width)))
419         ((fmt-writer st)
420          (if (positive? diff)
421              (proc str str-width diff st)
422              str)
423          st))))))
424
425(define (trim width . ls)
426  (lambda (st)
427    (let ((ell (fmt-ellipses st)))
428      (if ell
429          ((trim/buffered
430            width
431            (apply-cat ls)
432            (lambda (str str-width diff st)
433              (let* ((ell (if (char? ell) (string ell) ell))
434                     (ell-len (string-length ell))
435                     (diff (- (+ str-width ell-len) width)))
436                (if (negative? diff)
437                    ell
438                    (string-append
439                     (substring/shared str 0 (- (string-length str) diff))
440                     ell)))))
441           st)
442          (let ((output (fmt-writer st))
443                (start-col (fmt-col st)))
444            (call-with-current-continuation
445              (lambda (return)
446                (define (output* str st)
447                  (let* ((len ((or (fmt-string-width st) string-length) str))
448                         (diff (- (+ (- (fmt-col st) start-col) len) width)))
449                    (if (positive? diff)
450                        (return
451                         (fmt-set-writer!
452                          (output (substring/shared str 0 (- len diff)) st)
453                          output))
454                        (output str st))))
455                ((fmt-let 'writer output* (apply-cat ls)) st))))))))
456
457(define (trim/length width . ls)
458  (lambda (st)
459    (call-with-current-continuation
460      (lambda (return)
461        (let ((output (fmt-writer st))
462              (sum 0))
463          (define (output* str st)
464            (let ((len (string-length str)))
465              (set! sum (+ sum len))
466              (if (> sum width)
467                  (return
468                   (fmt-set-writer!
469                    (output (substring/shared str 0 (- len (- sum width))) st)
470                    output))
471                  (output str st))))
472          ((fmt-let 'writer output* (apply-cat ls)) st))))))
473
474(define (trim/left width . ls)
475  (trim/buffered
476   width
477   (apply-cat ls)
478   (lambda (str str-width diff st)
479     (let ((ell (fmt-ellipses st)))
480       (if ell
481           (let* ((ell (if (char? ell) (string ell) ell))
482                  (ell-len (string-length ell))
483                  (diff (- (+ str-width ell-len) width)))
484             (if (negative? diff)
485                 ell
486                 (string-append ell (substring/shared str diff))))
487           (substring/shared str diff))))))
488
489(define (trim/both width . ls)
490  (trim/buffered
491   width
492   (apply-cat ls)
493   (lambda (str str-width diff st)
494     (let ((ell (fmt-ellipses st)))
495       (if ell
496           (let* ((ell (if (char? ell) (string ell) ell))
497                  (ell-len (string-length ell))
498                  (diff (- (+ str-width ell-len ell-len) width))
499                  (left (quotient diff 2))
500                  (right (- (string-length str) (quotient (+ diff 1) 2))))
501             (if (negative? diff)
502                 ell
503                 (string-append ell (substring/shared str left right) ell)))
504           (substring/shared str
505                             (quotient (+ diff 1) 2)
506                             (- (string-length str) (quotient diff 2))))))))
507
508(define (fit width . ls)
509  (pad width (trim width (apply-cat ls))))
510(define (fit/left width . ls)
511  (pad/left width (trim/left width (apply-cat ls))))
512(define (fit/both width . ls)
513  (pad/both width (trim/both width (apply-cat ls))))
514
515;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
516;;; String-map formatters
517
518(define (make-string-fmt-transformer proc)
519  (lambda ls
520    (lambda (st)
521      (let ((base-writer (fmt-writer st)))
522        ((fmt-let
523          'writer (lambda (str st) (base-writer (proc str) st))
524          (apply-cat ls))
525         st)))))
526
527(define upcase (make-string-fmt-transformer string-upcase))
528(define downcase (make-string-fmt-transformer string-downcase))
529(define titlecase (make-string-fmt-transformer string-titlecase))
530
531;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
532;;; Numeric formatting
533
534(define *min-e* -1024)
535(define *bot-f* (expt 2 52))
536;;(define *top-f* (* 2 *bot-f*))
537
538(define (integer-log a base)
539  (if (zero? a)
540      0
541      (inexact->exact (ceiling (/ (log (+ a 1)) (log base))))))
542(define (integer-length* a)
543  (if (negative? a)
544      (integer-log (- 1 a) 2)
545      (integer-log a 2)))
546
547(define invlog2of
548  (let ((table (make-vector 37))
549        (log2 (log 2)))
550    (do ((b 2 (+ b 1)))
551        ((= b 37))
552      (vector-set! table b (/ log2 (log b))))
553    (lambda (b)
554      (if (<= 2 b 36)
555          (vector-ref table b)
556          (/ log2 (log b))))))
557
558(define fast-expt
559  (let ((table (make-vector 326)))
560    (do ((k 0 (+ k 1)) (v 1 (* v 10)))
561        ((= k 326))
562      (vector-set! table k v))
563    (lambda (b k)
564      (if (and (= b 10) (<= 0 k 326))
565          (vector-ref table (inexact->exact (truncate k)))
566          (expt b k)))))
567
568(define (mirror-of c)
569  (case c ((#\() #\)) ((#\[) #\]) ((#\{) #\}) ((#\<) #\>) (else c)))
570
571;; General algorithm based on "Printing Floating-Point Numbers Quickly
572;; and Accurately" by Burger and Dybvig (FP-Printing-PLDI96.pdf).  The
573;; code below will be hard to read out of that context until it's
574;; cleaned up.
575
576(define (num->string n st . opt)
577  (call-with-output-string
578    (lambda (port)
579      (let-optionals* opt
580          ((base (fmt-radix st))
581           (digits (fmt-precision st))
582           (sign? #f)
583           (commify? #f)
584           (comma-sep (and commify? (fmt-ref st 'comma-char #\,)))
585           (decimal-sep (or (fmt-decimal-sep st)
586                            (if (eqv? comma-sep #\.) #\, #\.)))
587           (comma-rule (if (eq? commify? #t) 3 commify?)))
588
589        (define (write-positive n)
590
591          (let* ((m+e (mantissa+exponent (exact->inexact n)))
592                 (f (car m+e))
593                 (e (cadr m+e))
594                 (inv-base (invlog2of base))
595                 (round? (even? f))
596                 (smaller (if round? <= <))
597                 (bigger (if round? >= >)))
598
599            (define (write-digit d)
600              (let ((d (inexact->exact (truncate d))))
601                (write-char
602                 (cond ((< d 10)
603                        (integer->char (+ d (char->integer #\0))))
604                       ((< d 36)
605                        (integer->char (+ (- d 10) (char->integer #\A))))
606                       (else (error "invalid digit: " d)))
607                 port)))
608
609            (define (pad d i) ;; just pad 0's, not #'s
610              (write-digit d)
611              (let lp ((i (- i 1)))
612                (cond
613                 ((>= i 0)
614                  (if (and commify?
615                           (if digits
616                               (and (> i digits)
617                                    (zero? (modulo (- i (- digits 1))
618                                                   comma-rule)))
619                               (and (positive? i)
620                                    (zero? (modulo i comma-rule)))))
621                      (display comma-sep port))
622                  (if (= i (- digits 1))
623                      (display decimal-sep port))
624                  (write-char #\0 port)
625                  (lp (- i 1))))))
626
627            (define (pad-all d i)
628              (write-digit d)
629              (let lp ((i (- i 1)))
630                (cond
631                 ((> i 0)
632                  (if (and commify? (zero? (modulo i comma-rule)))
633                      (display comma-sep port))
634                  (write-char #\0 port)
635                  (lp (- i 1)))
636                 ((and (= i 0) (inexact? n))
637                  (display decimal-sep port)
638                  (write-digit 0)))))
639
640            (define (pad-sci d i k)
641              (write-digit d)
642              (write-char #\e port)
643              (cond
644               ((positive? k)
645                (write-char #\+ port)
646                (write (- k 1) port))
647               (else
648                (write k port))))
649
650            (define (scale r s m+ m- k f e)
651              (let ((est (inexact->exact
652                          (ceiling (- (* (+ e (integer-length* f) -1)
653                                         (invlog2of base))
654                                      1.0e-10)))))
655                (if (not (negative? est))
656                    (fixup r (* s (fast-expt base est)) m+ m- est)
657                    (let ((skale (fast-expt base (- est))))
658                      (fixup (* r skale) s
659                             (* m+ skale) (* m- skale) est)))))
660
661            (define (fixup r s m+ m- k)
662              (if (bigger (+ r m+) s)
663                  (lead r s m+ m- (+ k 1))
664                  (lead (* r base) s (* m+ base) (* m- base) k)))
665
666            (define (lead r s m+ m- k)
667              (cond
668               ;;((and (not digits) (> k 14))
669               ;; (generate-sci r s m+ m- k))
670               ;;((and (not digits) (< k -4))
671               ;; (if (>= (/ r s) base)
672               ;;     (generate-sci (/ r base) s (/ m+ base) (/ m- base) k)
673               ;;     (generate-sci r s m+ m- k)))
674               ((and (not digits) (or (> k 14) (< k -4)))
675                (write n port))     ; XXXX using native write for now
676               (else
677                (cond
678                 ((and (not digits)
679                       (not (positive? k)))
680                  (write-char #\0 port)
681                  (display decimal-sep port)
682                  (let lp ((i 0))
683                    (cond
684                     ((> i k)
685                      (write-char #\0 port)
686                      (lp (- i 1)))))))
687                (if digits
688                    (generate-fixed r s m+ m- k)
689                    (generate-all r s m+ m- k)))))
690
691            (define (generate-all r s m+ m- k)
692              (let gen ((r r) (m+ m+) (m- m-) (i k))
693                (cond ((= i k))
694                      ((zero? i)
695                       (display decimal-sep port))
696                      ((and commify?
697                            (positive? i)
698                            (zero? (modulo i comma-rule)))
699                       (display comma-sep port)))
700                (let ((d (quotient r s))
701                      (r (remainder r s)))
702                  (if (not (smaller r m-))
703                      (cond
704                       ((not (bigger (+ r m+) s))
705                        (write-digit d)
706                        (gen (* r base) (* m+ base) (* m- base) (- i 1)))
707                       (else
708                        (pad-all (+ d 1) i)))
709                      (if (not (bigger (+ r m+) s))
710                          (pad-all d i)
711                          (pad-all (if (< (* r 2) s) d (+ d 1)) i))))))
712
713            ;; This is ugly because we need to keep a list of all
714            ;; output of the form x9999... in case we get to the end
715            ;; of the precision and need to round up.
716            (define (generate-fixed r s m+ m- k)
717              (let ((i0 (- (+ k digits) 1))
718                    (stack (if (<= k 0)
719                               (append (make-list (- k) 0)
720                                       (list decimal-sep 0))
721                               '())))
722                (define (write-digit-list ls)
723                  (for-each
724                   (lambda (x) (if (number? x) (write-digit x) (display x port)))
725                   ls))
726                (define (flush)
727                  (write-digit-list (reverse stack))
728                  (set! stack '()))
729                (define (flush/rounded)
730                  (let lp ((ls stack) (res '()))
731                    (cond
732                     ((null? ls)
733                      (write-digit-list (cons #\1 res)))
734                     ((not (number? (car ls)))
735                      (lp (cdr ls) (cons (car ls) res)))
736                     ((= (car ls) (- base 1))
737                      (lp (cdr ls) (cons #\0 res)))
738                     (else
739                      (write-digit-list
740                       (append (reverse (cdr ls))
741                               (cons (+ 1 (car ls)) res))))))
742                  (set! stack '()))
743                (define (output digit)
744                  (if (and (number? digit) (< digit (- base 1)))
745                      (flush))
746                  (set! stack (cons digit stack)))
747                (let gen ((r r) (m+ m+) (m- m-) (i i0))
748                  (cond ((= i i0))
749                        ((= i (- digits 1))
750                         (output decimal-sep))
751                        ((and commify?
752                              (> i digits)
753                              (zero? (modulo (- i (- digits 1))
754                                             comma-rule)))
755                         (output comma-sep)))
756                  (let ((d (quotient r s))
757                        (r (remainder r s)))
758                    (cond
759                     ((< i 0)
760                      (let ((d2 (* 2 (if (>= (* r 2) s) (+ d 1) d))))
761                        (if (or (> d2 base)
762                                (and (= d2 base)
763                                     (pair? stack)
764                                     (number? (car stack))
765                                     (odd? (car stack))))
766                            (flush/rounded)
767                            (flush))))
768                     ((smaller r m-)
769                      (flush)
770                      (if (bigger (+ r m+) s)
771                          (pad (if (< (* r 2) s) d (+ d 1)) i)
772                          (pad d i)))
773                     ((bigger (+ r m+) s)
774                      (flush)
775                      (pad (+ d 1) i))
776                     (else
777                      (output d)
778                      (gen (* r base) (* m+ base)
779                           (* m- base) (- i 1))))))))
780
781            (define (generate-sci r s m+ m- k)
782              (let gen ((r r) (m+ m+) (m- m-) (i k))
783                (cond ((= i (- k 1)) (display decimal-sep port)))
784                (let ((d (quotient r s))
785                      (r (remainder r s)))
786                  (if (not (smaller r m-))
787                      (cond
788                       ((not (bigger (+ r m+) s))
789                        (write-digit d)
790                        (gen (* r base) (* m+ base) (* m- base) (- i 1)))
791                       (else (pad-sci (+ d 1) i k)))
792                      (if (not (bigger (+ r m+) s))
793                          (pad-sci d i k)
794                          (pad-sci (if (< (* r 2) s) d (+ d 1)) i k))))))
795
796            (cond
797             ((negative? e)
798              (if (or (= e *min-e*) (not (= f *bot-f*)))
799                  (scale (* f 2) (* (expt 2.0 (- e)) 2) 1 1 0 f e)
800                  (scale (* f 2 2) (* (expt 2.0 (- 1 e)) 2) 2 1 0 f e)))
801             (else
802              (if (= f *bot-f*)
803                  (let ((be (expt 2 e)))
804                    (scale (* f be 2) 2.0 be be 0 f e))
805                  (let* ((be (expt 2 e)) (be1 (* be 2)))
806                    (scale (* f be1 2) (* 2.0 2) be1 be 0 f e)))))))
807
808        (define (write-real n sign?)
809          (cond
810           ((negative? n)
811            (if (char? sign?)
812                (begin (display sign? port) (write-positive (abs n))
813                       (display (mirror-of sign?) port))
814                (begin (write-char #\- port) (write-positive (abs n)))))
815           (else
816            (if (and sign? (not (char? sign?)))
817                (write-char #\+ port))
818            (write-positive n))))
819
820        (let ((imag (imag-part n)))
821          (cond
822           ((zero? imag)
823            (cond
824             ((and (not digits) (exact? n) (not (integer? n)))
825              (write-real (numerator n) sign?)
826              (write-char #\/ port)
827              (write-real (denominator n) #f))
828             (else
829              (write-real n sign?))))
830           (else (write-real imag sign?)
831                 (write-real (real-part n) #t)
832                 (write-char #\i port))))))))
833
834(define (num n . opt)
835  (lambda (st) ((fmt-writer st) (apply num->string n st opt) st)))
836
837(define (num/comma n . o)
838  (lambda (st)
839    (let-optionals* o
840        ((base (fmt-radix st))
841         (digits (fmt-precision st))
842         (sign? #f)
843         (comma-rule 3)
844         (comma-sep (fmt-ref st 'comma-char #\,))
845         (decimal-sep (or (fmt-decimal-sep st)
846                          (if (eqv? comma-sep #\.) #\, #\.))))
847      ((num n base digits sign? comma-rule comma-sep decimal-sep) st))))
848
849;; SI suffix formatting, as used in --human-readable options to some
850;; GNU commands (such as ls).  See
851;;
852;;   http://www.bipm.org/en/si/si_brochure/chapter3/prefixes.html
853;;   http://physics.nist.gov/cuu/Units/binary.html
854;;
855;; Note: lowercase "k" for base 10, uppercase "K" for base 2
856
857(define num/si
858  (let* ((names10 '#("" "k" "M" "G" "T" "E" "P" "Z" "Y"))
859         (names2 (list->vector
860                  (cons ""
861                        (cons "Ki" (map (lambda (s) (string-append s "i"))
862                                        (cddr (vector->list names10))))))))
863    (lambda (n . o)
864      (let-optionals* o ((base 1024)
865                         (suffix "")
866                         (names (if (= base 1024) names2 names10)))
867        (let* ((k (min (inexact->exact (floor (/ (log n) (log base))))
868                       (vector-length names)))
869               (n2 (/ (round (* (/ n (expt base k)) 10)) 10)))
870          (cat (if (integer? n2)
871                   (number->string (inexact->exact n2))
872                   (exact->inexact n2))
873               (vector-ref names k)
874               (if (zero? k) "" suffix)))))))
875
876;; Force a number into a fixed width, print as #'s if doesn't fit.
877;; Needs to be wrapped in a PAD if you want to expand to the width.
878
879(define (num/fit width n . args)
880  (fmt-capture
881   (apply num n args)
882   (lambda (str)
883     (lambda (st)
884       (if (> (string-length str) width)
885           (let ((prec (if (and (pair? args) (pair? (cdr args)))
886                           (cadr args)
887                           (fmt-precision st))))
888             (if prec
889                 (let* ((decimal-sep
890                         (or (fmt-ref st 'decimal-sep)
891                             (if (eqv? #\. (fmt-ref st 'comma-sep)) #\, #\.)))
892                        (diff (- width (+ prec
893                                          (if (char? decimal-sep)
894                                              1
895                                              (string-length decimal-sep))))))
896                   ((cat (if (positive? diff) (make-string diff #\#) "")
897                         decimal-sep (make-string prec #\#))
898                    st))
899                 ((fmt-writer st) (make-string width #\#) st)))
900           ((fmt-writer st) str st))))))
901
902;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
903;;; shared structure utilities
904
905(define (eq?-table-ref tab x) (hash-table-ref/default tab x #f))
906(define (eq?-table-set! tab x v) (hash-table-set! tab x v))
907
908;; XXXX extend for records and other container data types
909(define (make-shared-ref-table obj)
910  (let ((tab (make-eq?-table))
911        (res (make-eq?-table))
912        (index 0))
913    (let walk ((obj obj))
914      (cond
915        ((eq?-table-ref tab obj)
916         => (lambda (i) (eq?-table-set! tab obj (+ i 1))))
917        ((not (or (symbol? obj) (number? obj) (char? obj)
918                  (boolean? obj) (null? obj) (eof-object? obj)))
919         (eq?-table-set! tab obj 1)
920         (cond
921           ((pair? obj)
922            (walk (car obj))
923            (walk (cdr obj)))
924           ((vector? obj)
925            (let ((len (vector-length obj)))
926              (do ((i 0 (+ i 1))) ((>= i len))
927                (walk (vector-ref obj i)))))))))
928    (hash-table-walk
929     tab
930     (lambda (obj count)
931       (if (> count 1)
932           (begin
933             (eq?-table-set! res obj (cons index #f))
934             (set! index (+ index 1))))))
935    res))
936
937(define (gen-shared-ref i suffix)
938  (string-append "#" (number->string i) suffix))
939
940(define (maybe-gen-shared-ref st cell shares)
941  (cond
942    ((pair? cell)
943     (set-car! cell (cdr shares))
944     (set-cdr! cell #t)
945     (set-cdr! shares (+ (cdr shares) 1))
946     ((fmt-writer st) (gen-shared-ref (car cell) "=") st))
947    (else st)))
948
949(define (call-with-shared-ref obj st shares proc)
950  (let ((cell (eq?-table-ref (car shares) obj)))
951    (if (and (pair? cell) (cdr cell))
952        ((fmt-writer st) (gen-shared-ref (car cell) "#") st)
953        (proc (maybe-gen-shared-ref st cell shares)))))
954
955(define (call-with-shared-ref/cdr obj st shares proc sep)
956  (let ((cell (eq?-table-ref (car shares) obj))
957        (output (fmt-writer st)))
958    (cond
959      ((and (pair? cell) (cdr cell))
960       (output (gen-shared-ref (car cell) "#") (output ". " (sep st))))
961      ((pair? cell)
962       (let ((st (maybe-gen-shared-ref (output ". " (sep st)) cell shares)))
963         (output ")" (proc (output "(" st)))))
964      (else
965       (proc (sep st))))))
966
967;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
968;;; sexp formatters
969
970(define (slashified str . o)
971  (let-optionals* o ((quot #\") (esc #\\) (rename (lambda (x) #f)))
972    (lambda (st)
973      (let* ((len (string-length str))
974             (output (fmt-writer st))
975             (quot-str (string quot))
976             (esc-str (if (char? esc) (string esc) (or esc quot-str))))
977        (let lp ((i 0) (j 0) (st st))
978          (define (collect)
979            (if (= i j) st (output (substring/shared str i j) st)))
980          (if (>= j len)
981              (collect)
982              (let ((c (string-ref str j)))
983                (cond
984                  ((or (eqv? c quot) (eqv? c esc))
985                   (lp j (+ j 1) (output esc-str (collect))))
986                  ((rename c)
987                   => (lambda (c2)
988                        (lp (+ j 1)
989                            (+ j 1)
990                            (output c2 (output esc-str (collect))))))
991                  (else
992                   (lp i (+ j 1) st))))))))))
993
994;; Only slashify if there are special characters, in which case also
995;; wrap in quotes.  For writing symbols in |...| escapes, or CSV
996;; fields, etc.  The predicate indicates which characters cause
997;; slashification - this is in addition to automatic slashifying when
998;; either the quote or escape char is present.
999
1000(define (maybe-slashified str pred . o)
1001  (let-optionals* o ((quot #\") (esc #\\) (rename (lambda (x) #f)))
1002    (define (esc? c) (or (eqv? c quot) (eqv? c esc) (rename c) (pred c)))
1003    (if (string-index str esc?)
1004        (cat quot (slashified str quot esc rename) quot)
1005        (dsp str))))
1006
1007(define (fmt-write-string str)
1008  (define (rename c)
1009    (case c
1010      ((#\newline) "n")
1011      (else #f)))
1012  (slashified str #\" #\\ rename))
1013
1014(define (dsp obj)
1015  (cond
1016    ((procedure? obj) obj)
1017    ((string? obj) (lambda (st) ((fmt-writer st) obj st)))
1018    ((char? obj) (dsp (string obj)))
1019    (else (wrt obj))))
1020
1021(define (write-with-shares obj shares)
1022  (lambda (st)
1023    (let* ((output (fmt-writer st))
1024           (wr-num
1025            (cond ((and (= 10 (fmt-radix st))
1026                        (not (fmt-precision st)))
1027                   (lambda (n st) (output (number->string n) st)))
1028                  ((assv (fmt-radix st)
1029                         '((16 . "#x") (10 . "") (8 . "#o") (2 . "#b")))
1030                   => (lambda (cell)
1031                        (let ((prefix (cdr cell)))
1032                          (lambda (n st) ((num n) (output prefix st))))))
1033                  (else (lambda (n st) (output (number->string n) st))))))
1034      (let wr ((obj obj) (st st))
1035        (call-with-shared-ref obj st shares
1036          (lambda (st)
1037            (cond
1038              ((pair? obj)
1039               (output
1040                ")"
1041                (let lp ((ls obj)
1042                         (st (output "(" st)))
1043                  (let ((st (wr (car ls) st))
1044                        (rest (cdr ls)))
1045                    (cond
1046                      ((null? rest) st)
1047                      ((pair? rest)
1048                       (call-with-shared-ref/cdr rest st shares
1049                         (lambda (st) (lp rest st))
1050                         (dsp " ")))
1051                      (else (wr rest (output " . " st))))))))
1052              ((vector? obj)
1053               (let ((len (vector-length obj)))
1054                 (if (zero? len)
1055                     (output "#()" st)
1056                     (let lp ((i 1)
1057                              (st
1058                               (wr (vector-ref obj 0)
1059                                   (output "#(" st))))
1060                       (if (>= i len)
1061                           (output ")" st)
1062                           (lp (+ i 1)
1063                               (wr (vector-ref obj i)
1064                                   (output " " st))))))))
1065              ((string? obj)
1066               (output "\"" ((fmt-write-string obj) (output "\"" st))))
1067              ((number? obj)
1068               (wr-num obj st))
1069              ((boolean? obj)
1070               (output (if obj "#t" "#f") st))
1071              (else
1072               (output (write-to-string obj) st)))))))))
1073
1074(define (wrt obj)
1075  (write-with-shares obj (cons (make-shared-ref-table obj) 0)))
1076
1077;; the only expensive part, in both time and memory, of handling
1078;; shared structures when writing is building the initial table, so
1079;; for the efficient version we just skip that
1080
1081(define (wrt/unshared obj)
1082  (write-with-shares obj (cons (make-eq?-table) 0)))
1083
Note: See TracBrowser for help on using the repository browser.