source: project/format-modular/tags/1.7/format-modular.scm @ 8363

Last change on this file since 8363 was 4476, checked in by Kon Lovett, 13 years ago

Rmvd print. Chgd verno.

File size: 63.5 KB
Line 
1; $Id: format.scm 4851 2006-02-08 13:57:26Z azul $
2
3; An implementation of a generic formatter supporting
4; inheritance.  It is followed by an implementation of Common
5; Lisp's FORMAT function.
6;
7; This code is in the public domain.
8
9; Authors:
10;
11;   Alejandro Forero Cuervo <azul@freaks-unidos.net>
12;   Alex Shinn <foof@synthcode.com>
13;   Kon Lovett <klovett@pacbell.net>
14
15; Bugs
16;
17; - Since a new state is created upon each invocation the colpos has no "memory",
18; thus ~& is accurate only within a single invocation.
19
20; ToDo
21;
22; - Use actual port position; needs library support for '(port-position <output-port>)'.
23; Or could fake it a'la SLIB format.
24;
25; - A and S controls provide read-proof. (See testbase egg for similar.)
26;
27; - W control support. Will subsume Y control. (See SRFI-38.)
28
29(require-extension (srfi 1) (srfi 9))
30
31(cond-expand
32  (chicken
33    (use srfi-13 srfi-14 lolevel)
34    (use srfi-29)
35  ) (else
36  ) )
37
38#+chicken
39(eval-when (compile)
40  (declare
41    (generic)
42    (inline)
43    (not usual-integrations
44      ; So utf8 & full-numeric-tower extensions can override.
45      ; Many of these are not 'integrated', but are for exposition.
46      ;
47      ; Numbers
48      number->string string->number
49      inexact->exact exact->inexact
50      quotient remainder
51      log
52      abs floor ceiling
53      negative? zero? positive?
54      number?
55      complex? real? integer?
56      rational?
57      + - * /
58      = < <= > >=
59      make-rectangular real-part imag-part
60      ; Characters
61      char-numeric? char-whitespace? char-alphabetic?
62      char-upcase char-downcase
63      ; Character-Sets
64      char-set-contains? char-set:graphic
65      ;; I/O
66      write-char
67      write-string
68      ; Strings
69      substring substring-index
70      string->list
71      string-ref string-length
72      string-map! string-copy string-index)
73    (no-procedure-checks-for-usual-bindings)
74    (import
75      make-rectangular)
76    (bound-to-procedure
77      make-rectangular
78      ; Forward declaration
79      formatter-error start-iteration)
80    (unused
81      fm$state?
82      fm$iterator?)
83    (export
84      ; Configuration Variables
85      ; SLIB compatibility
86      format:floats
87      format:complex
88      format:expch
89      format:iteration-bounded
90      format:max-iterations
91      ; Pre-defined formatters
92      ;   By category
93      *formatter-params*
94      *formatter-iteration*
95      *formatter-caseconv*
96      *formatter-chars*
97      *formatter-numbers*
98      *formatter-cond*
99      *formatter-indirection*
100      *formatter-jump*
101      *formatter-objs*
102      *formatter-flush*
103      *formatter-plural*
104      *formatter-tabulate*
105      ;   All
106      *formatter-cl*
107      ; Procedures
108      *formatter-out-char
109      *formatter-out-char-times
110      *formatter-out-char-list
111      *formatter-out-string
112      make-format-function
113      format
114      ; Convenience functions to simplify the creation of new
115      ; format-functions.
116      formatter-padded
117      formatter-function) ) )
118
119#+chicken
120#; ; already registered by extras unit
121(register-feature! 'srfi-28)
122
123;;;
124
125;; Generics
126
127(define (complex-strict? num)
128  (and (complex? num)
129       (not (or (real? num) (rational? num) (integer? num)))) )
130
131;;; Configuration
132
133;; Configuration Variables
134
135;FIXME these should be copied into the state record on construction
136(define format:floats #t)
137(define format:complex #f)
138;(define format:fn-max 200)
139;(define format:en-max 10)
140(define format:expch #\E)
141;(define format:radix-pref )
142;(define format:symbol-case-conv #f)
143;(define format:iobj-case-conv #f)
144(define format:iteration-bounded #t)
145(define format:max-iterations 100)
146;(define format:unprocessed-arguments-error? #f)
147
148(cond-expand
149  (chicken
150
151    (define (global-exists? sym #!optional (test (constantly #t)))
152      (and (global-bound? sym)
153           (test (global-ref sym)) ) )
154
155    (set! format:complex (global-exists? 'make-rectangular procedure?))
156
157    (reset-locale-parameters)
158    (load-best-available-bundle! (most-specific-bundle-specifier 'format-modular))
159
160    (define (item@ key)
161      (localized-template 'format-modular key) )
162
163    (define (localized-vector vec)
164      (list->vector (map item@ vec)) )
165
166    ;; Number Names
167
168    (define *cardinal-ones*
169      '(nul one two three four five
170            six seven eight nine ten eleven twelve thirteen
171            fourteen fifteen sixteen seventeen eighteen
172            nineteen))
173
174    (define *thousand-factor-names*
175      '(nul thousand million billion trillion quadrillion
176            quintillion sextillion septillion octillion nonillion
177            decillion undecillion duodecillion tredecillion
178            quattuordecillion quindecillion sexdecillion septendecillion
179            octodecillion novemdecillion vigintillion))
180
181    (define *cardinal-tens*
182      '(nul tens-ten twenty thirty forty fifty sixty seventy eighty
183            ninety))
184
185    (define *cardinal-hundred* 'hundred)
186
187    (define *ordinal-ones*
188      '(nul first second third fourth fifth sixth seventh
189            eighth ninth tenth eleventh twelveth thirteenth fourteenth
190            fifteenth sixteenth seventeenth eighteenth nineteenth))
191
192    (define *ordinal-tens*
193      '(nul tens-tenth twentieth thirtieth fortieth fiftieth sixtieth
194            seventieth eightieth ninetieth))
195
196    ;FIXME these should be copied into the state record on construction
197    (set! *cardinal-ones* (localized-vector *cardinal-ones*))
198    (set! *thousand-factor-names* (localized-vector *thousand-factor-names*))
199    (set! *cardinal-tens* (localized-vector *cardinal-tens*))
200    (set! *cardinal-hundred* (item@ *cardinal-hundred*))
201    (set! *ordinal-ones* (localized-vector *ordinal-ones*))
202    (set! *ordinal-tens* (localized-vector *ordinal-tens*))
203
204  ) (else
205
206    (define *cardinal-ones*
207      '#("" "one" "two" "three" "four" "five"
208            "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen"
209            "fourteen" "fifteen" "sixteen" "seventeen" "eighteen"
210            "nineteen"))
211
212    (define *thousand-factor-names* ;; US-style, consistent w/ CL
213      '#("" " thousand" " million" " billion" " trillion" " quadrillion"
214            " quintillion" " sextillion" " septillion" " octillion" " nonillion"
215            " decillion" " undecillion" " duodecillion" " tredecillion"
216            " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
217            " octodecillion" " novemdecillion" " vigintillion"))
218
219    (define *cardinal-tens*
220      '#(#f "ten" "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty"
221            "ninety"))
222
223    (define *cardinal-hundred* " hundred")
224
225    (define *ordinal-ones*
226      '#("" "first" "second" "third" "fourth" "fifth" "sixth" "seventh"
227            "eighth" "ninth" "tenth" "eleventh" "twelveth" "thirteenth" "fourteenth"
228            "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"))
229
230    (define *ordinal-tens*
231      '#("" "tenth" "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth"
232            "seventieth" "eightieth" "ninetieth"))
233
234  ) )
235
236;;; State record
237
238;
239; The STATE record represents the state in the parsing of the
240; format string.
241;
242; It has one design goal: to be as simple as possible, while
243; still allowing our parser to be smart enough to implement
244; FORMAT.
245;
246; It has the following objects:
247;
248; OUT is the port where output is written.
249;
250; OBJ is the vector with the arguments.
251;
252; OBJPOS is the current position in obj (the read head).
253;
254; CASECONV is the function used to convert case for the
255; characters right before writing them (defaults to identity).
256; It is important to call it for absolutely all the characters
257; written (even if they are not alphabetic) because it might have
258; internal side effects.
259;
260; CASECONV-DEPTH is the depth of nested ~(...~) constructions.
261; It is used to know when a ~) actually ends the top ~(...~)
262; construct (and thus caseconv should be set back to identity).
263; Also used to know whether a ~( is the highest level ~(...~)
264; construct (and thus caseconv should actually be modified).
265;
266; COLPOS is the current position in the output.  It starts in 0.
267; When a character is printed (in *formatter-out-char), this value is
268; increased (or reset if the character was a newline).  This is
269; used for ~T.
270;
271; CONDSKIP is a list such that when non-empty and its car is
272; non-zero, no output should be produced.  It is used to hold the
273; current count for the ~[ ... ~; ...  ~]: if non-zero (both
274; positive or negative), everything will be ignored.  It is also
275; used for iteration: when a ~{ is found, a -1 is added at the
276; beginning of the list to cause everything to skip until the ~}
277; is found.  We use a list because we need to support nested
278; constructs.
279;
280; Note that the basis of our format parser reacts to *all* the
281; format characters and calls their associated function
282; regardless of the occurences of ~[, ~; and ~]; it is the
283; responsability of the associated functions to check the value
284; of condskip to see if the escape character that caused them to
285; be called was found in a position where, --according to ~[, ~;
286; and ~]--, it should be ignored.  A simple way to do this is to
287; use cond-valid: if it returns true, the escape character didn't
288; occur in a position where it should be ignored.  See also the
289; formatter-function function, which was defined for this very
290; purpose.
291;
292; FMT is the format string.
293;
294; FMTPOS is the position in the format string.
295;
296; FMTEND is a list with functions.  When the parsing of the fmt
297; string is done, if the list is not empty, the first function is
298; removed and called, and the parsing continues.  The function
299; should set the state back to some sane valid state (probably
300; changing fmtpos or fmt or both).  If the list is empty, the
301; parser just assumes it is done and returns control to the
302; caller.  This is used to implement indirection.
303;
304; ITERATE is a list with functions used to implement iteration.
305; When a ~{ is found, a new function is added to the list.  That
306; function is called when ~} is found and should either restart
307; the iteration or stop it.  See the Iteration section for more
308; information.
309;
310; NEST is a list with the opening characters for nested
311; constructions such as ~[, ~( and ~{.  It is used to detect
312; nesting errors.
313;
314; TABLE is a vector of 255 positions.  Each position has the
315; function associated to its corresponding escape sequence.  For
316; example, when ~A is found, the function in position
317; (char->integer #\A) is called.  These functions receive the
318; following arguments:
319;
320;   STATE: this very object.
321;
322;   START: the position where we found the tilde (or escape
323;   character) that begins the escape sequence.
324;
325;   PARAMS: the reverted list of parameters in the escape
326;   sequence, ocurring between ESCAPE and the last character in
327;   the escape sequence.  The reason this list is passed reverted
328;   is that in order to generate it we use the regular machinery:
329;   the parser does not distinguish the characters than can occur
330;   in parameters (such as numbers, commas, etc.) from the
331;   regular escape characters (such as #\A, #\{, for ~A, ~{,
332;   etc.), it simply calls their associated functions in TABLE.
333;   If we passed the list in the appropriate order, these
334;   functions would have to constantly append items to its end.
335;   See FORMATTER-FUNCTION if this is an issue for you.
336;
337;   COLON and ATSIGN: booleans indicating whether : and @ occur
338;   in the escape sequence respectively.
339;
340; ESCAPE is the character for the escape sequence (usually #\~,
341; but sometimes, --for emulating the behaviour of the printf
342; function of the C programming language--, #\%).
343
344(define-record-type fm$state
345  (make-state out obj objpos caseconv caseconv-depth colpos condskip fmt fmtpos fmtend iterate nest table escape)
346  fm$state?
347  (out state-out #;state-out-set!)
348  (obj state-obj state-obj-set!)
349  (objpos state-objpos state-objpos-set!)
350  (caseconv state-caseconv state-caseconv-set!)
351  (caseconv-depth state-caseconv-depth state-caseconv-depth-set!)
352  (colpos state-colpos state-colpos-set!)
353  (condskip state-condskip state-condskip-set!)
354  (fmt state-fmt state-fmt-set!)
355  (fmtpos state-fmtpos state-fmtpos-set!)
356  (fmtend state-fmtend state-fmtend-set!)
357  (iterate state-iterate state-iterate-set!)
358  (nest state-nest state-nest-set!)
359  (table state-table #;state-table-set!)
360  (escape state-escape #;state-escape-set!) )
361
362; Create the default state for a format function:
363
364(define (make-default-state table escape out fmt objs)
365  (make-state out (list->vector objs) 0 identity 0 0 '() fmt 0 '() '() '() table escape) )
366
367;;; Miscellaneous convenience functions
368
369; Standard error function to use.
370
371(define (formatter-error . rest)
372  (apply error 'format-modular rest) )
373
374; Standard error function to use when we come across a strange
375; control character in a escape sequence.
376
377(define (formatter-unknown-control-error state . rest)
378  (formatter-error "Unknown control character"
379    (string-ref (state-fmt state) (fx- (state-fmtpos state) 1))) )
380
381; Are we in a valid position in the format string, where we are
382; supposed to produce output, according to CONDSKIP?
383
384(define (cond-valid? s)
385  (or (null? (state-condskip s))
386      (fx= 0 (car (state-condskip s))) ) )
387
388;
389
390(define (state-condskip-push! state obj)
391  (state-condskip-set! state (cons obj (state-condskip state))) )
392
393(define (state-condskip-pop! state)
394  (state-condskip-set! state (cdr (state-condskip state))))
395
396(define (state-objpos-inc! state . rest)
397  (let-optionals rest ((times 1))
398    (state-objpos-set! state (fx+ (state-objpos state) times)) ) )
399
400(define (%state-obj-ref state)
401  (vector-ref (state-obj state) (state-objpos state)) )
402
403(define (state-obj-ref state . rest)
404  (let-optionals rest ((inctimes 0))
405    (let ((obj (%state-obj-ref state)))
406      (state-objpos-inc! state inctimes)
407      obj ) ) )
408
409(define (state-fmtend-push! state func)
410  (state-fmtend-set! state (cons func (state-fmtend state))) )
411
412(define (state-fmtend-pop! state)
413  (state-fmtend-set! state (cdr (state-fmtend state))) )
414
415(define (state-iterate-push! state func)
416  (state-iterate-set! state (cons func (state-iterate state))) )
417
418(define (state-nest-push! state char)
419  (state-nest-set! state (cons char (state-nest state))))
420
421(define (state-nest-pop! state char)
422  (assert (not (null? (state-nest state))))
423  (unless (eqv? (car (state-nest state)) char)
424    (formatter-error "Improper nesting for character" char))
425  (state-nest-set! state (cdr (state-nest state))) )
426
427;;; Generate output
428
429; Output a character, passing it through the caseconv function
430; and updating the COLPOS value of the state.
431
432(define (*formatter-out-char state char)
433  (state-colpos-set! state
434    (if (char=? char #\newline) 0 (fx+ 1 (state-colpos state))))
435  (write-char ((state-caseconv state) char) (state-out state)) )
436
437; Output a list-of char.
438
439(define (*formatter-out-char-list state char-list)
440  (for-each (cut *formatter-out-char state <>) char-list) )
441
442(cond-expand
443  (chicken
444
445    ; Like string-map but guarantees the order of application.
446
447    (define (map-string-in-order p s . args)
448      (let-values (((start end) (string-parse-final-start+end 'map-string-in-order s args)))
449        (let ((ss (make-string (fx- end start)))
450              (i 0))
451          (string-for-each
452            (lambda (c)
453              (string-set! ss i (p c))
454              (set! i (fx+ 1 i)) )
455            s start end)
456          ss ) ) )
457
458    ; Output a string.
459
460    (define (*formatter-out-string state str)
461      (unless (string-null? str)
462        (let ((substr-conv
463                (lambda args
464                  (apply map-string-in-order
465                    (lambda (char)
466                      (state-colpos-set! state (fx+ 1 (state-colpos state)))
467                      ((state-caseconv state) char) )
468                    str args) ) ) )
469          (write-string
470            (let ((nlidx (string-index str #\newline)))
471              (if nlidx
472                (do ((ptr nlidx (string-index str #\newline (fx+ 1 ptr)))
473                     (cur 0 ptr) )
474                    ((not ptr) (substr-conv cur))
475                  (write-string (substr-conv cur ptr) #f (state-out state))
476                  (state-colpos-set! state 0)
477                  ((state-caseconv state) #\newline) )
478                (substr-conv)))
479            #f (state-out state)) ) ) )
480
481    ; Output n repetitions of a char.
482
483    (define *formatter-out-char-times
484      (letrec ((fixnum+char-eq?
485                (lambda (fixnum+char1 fixnum+char2)
486                  (and (fx= (first fixnum+char1) (first fixnum+char2))
487                       (char=? (second fixnum+char1) (second fixnum+char2)) ) ) )
488               (fixnum+char-hash
489                (lambda (fixnum+char #!optional (bound 536870912))
490                  (fxmod (fxior (fxshl (char->integer (second fixnum+char)) 10) (first fixnum+char)) bound) ) )
491               (ht (make-hash-table fixnum+char-eq? fixnum+char-hash))
492               (times+char-memeoize
493                (lambda times+char
494                  (or (hash-table-ref/default ht times+char #f)
495                      (let ((str (make-string (first times+char) (second times+char))))
496                        (hash-table-set! ht times+char str)
497                        str ) ) ) ) )
498        (lambda (state times char)
499          (cond
500            ((not state)
501              (set! ht (make-hash-table fixnum+char-eq? fixnum+char-hash)))
502            ((fx= 1 times)
503              (*formatter-out-char state char))
504            ((fx< 0 times)
505              (*formatter-out-string state (times+char-memeoize times char))) ) ) ) )
506
507  ) (else
508
509    ; Output n repetitions of a char.
510
511    (define (*formatter-out-char-times state times char)
512      (do ((i times (fx- i 1)))
513          ((fx>= 0 i))
514        (*formatter-out-char state char) ) )
515
516    ; Output a string.
517
518    (define (*formatter-out-string state str)
519      (let ((strlen (string-length str)))
520        (do ((i 0 (fx+ i 1)))
521            ((fx= i strlen))
522          (*formatter-out-char state (string-ref str i)) ) ) )
523  ) )
524
525; Tabbing
526
527(define (tabulate state colnum colinc atsign tabchar)
528  (*formatter-out-char-times state
529    (fx+ (if atsign colnum 0)
530       (cond
531         ((and (not atsign) (fx< (state-colpos state) colnum))
532           (fx- colnum (state-colpos state)))
533         ((fx= 0 colinc)
534           0)
535         (else
536           (let ((mod (fxmod (fx+ (if atsign colnum 0) (state-colpos state)) colinc)))
537             (if (fx= 0 mod) 0 (fx- colinc mod))))))
538     tabchar) )
539
540;;; Parsing of format strings
541
542; Called when an escape character is found while processing the
543; format string.  params is the list of params we have received
544; while processing the escape character in reverted order.  start
545; is the position in the format string where the escape character
546; was found.
547
548(define (format-escape state start params colon atsign)
549  (let ((fmt (state-fmt state))
550        (pos (state-fmtpos state)))
551    (cond
552      ((fx< pos (string-length fmt))
553       (state-fmtpos-set! state (fx+ 1 (state-fmtpos state)))
554       ((vector-ref (state-table state) (char->integer (string-ref fmt pos)))
555         state start params colon atsign) )
556      (else
557        (*formatter-out-char state #\~) ) ) ) )
558
559; Process the entire format string; when done, call the first
560; function in STATE-FMTEND or return if empty.
561
562(define (format-parse state)
563  (do ()
564      ((fx= (state-fmtpos state) (string-length (state-fmt state))))
565    (let* ((pos (state-fmtpos state))
566           (c (string-ref (state-fmt state) pos)))
567      (state-fmtpos-set! state (fx+ 1 pos))
568      (if (eq? c (state-escape state))
569        (format-escape state pos '() #f #f)
570        (when (cond-valid? state)
571          (*formatter-out-char state c) ) ) ) )
572  (unless (null? (state-fmtend state))
573    ((car (state-fmtend state)))
574    (format-parse state) ) )
575
576;;; Entry point
577
578; Create the table for a new formatter.  parents is a list of
579; parents to inherit from.
580
581(define (formatter->table case-sensitive formatters)
582  (let ((table (make-vector 256 formatter-unknown-control-error)))
583    (for-each
584      (lambda (definitions)
585        (for-each
586          (if case-sensitive
587            (lambda (binding)
588              (vector-set! table (char->integer (car binding)) (cadr binding)))
589            (lambda (binding)
590              (vector-set! table (char->integer (char-upcase   (car binding))) (cadr binding))
591              (vector-set! table (char->integer (char-downcase (car binding))) (cadr binding))))
592          definitions))
593      (reverse formatters))
594    table ) )
595
596; Create a format function based on a formatter.  Note that we
597; build the table of escape characters as soon as possible but we
598; have to create a state once for each call to the resulting
599; function.
600
601(define (make-format-function case-sensitive escape formatters)
602  (letrec ((table (formatter->table case-sensitive formatters))
603           (formatter
604            (lambda (out . args)
605              (cond
606                ((not out)
607                 (call-with-output-string (lambda (out) (apply formatter out args))) )
608                ((boolean? out)
609                 (apply formatter (current-output-port) args) )
610                ((string? out)
611                 (apply formatter #f out args) )
612                ((output-port? out)
613                  (unless (pair? args)
614                    (formatter-error "bad argument count - received 1 but expected 2" formatter) )
615                  (format-parse
616                    (make-default-state table escape out (car args) (cdr args))) )
617                (else
618                  (formatter-error "invalid destination" out) ) ) ) ) )
619    formatter ) )
620
621; Function to wrap your formatter functions with.  Your formatter
622; function will then receive the params in the appropriate order
623; and won't get called for escape sequences that occur in a
624; location where they should be ignored.
625
626(define (formatter-function func)
627  (lambda (state start params colon atsign)
628    (when (cond-valid? state)
629      (func state start (reverse params) colon atsign))))
630
631;;; Formatter supporting basic arguments
632
633; Add NEW to the list of PARAMS in the state.  FMTPOS is advanced
634; ADVANCE positions and, if we land on a comma (and we actually
635; added something), one more.  Afterwards, parsing of the escape
636; sequence is resumed by a call to FORMAT-ESCAPE.
637;
638; The reason we can't always advance is that if we have
639; consecutive empty parameters we might skip more than we should.
640; For instance, suppose "~,,1D" is our sequence: in the first
641; call to ADD-PARAM (caused by the occurence of the first comma)
642; FMTPOS will be 2, and we really shouldn't advance.  Also note
643; that NEW evaluates to false iff the cause to ADD-PARAM was
644; caused by the occurence of a comma.
645
646(define (add-param state start advance new params colon atsign)
647  (let ((newpos (fx+ advance (state-fmtpos state))))
648    (state-fmtpos-set! state
649      (if (and new (char=? (string-ref (state-fmt state) newpos) #\,))
650        (fx+ newpos 1)
651        newpos)) )
652  (format-escape state start (cons new params) colon atsign))
653
654; Given a string FMT and a position I, return the smallest
655; position in the string greater than I where the digit is not
656; numeric.
657
658(define (skip-number fmt i)
659  (let ((c (string-ref fmt i)))
660    (if (or (char-numeric? c) (char=? c #\+) (char=? c #\-))
661      (skip-number fmt (fx+ i 1))
662      i)))
663
664; Formatter function to call when the escape character is
665; followed by a number (or #\+ or #\-).  It adds the value of the
666; number as a parameter, advances FMTPOS and resumes the parsing.
667
668(define (numeric-arg state start . rest)
669  (let ((newpos (skip-number (state-fmt state) (state-fmtpos state))))
670    (apply add-param state start
671      (fx- newpos (state-fmtpos state))
672      (string->number (substring (state-fmt state) (fx- (state-fmtpos state) 1) newpos))
673      rest)))
674
675; Now define a list that can be used to create format functions
676; that need to support parameters in escape sequences.
677
678(define *formatter-params*
679  `((#\: ,(lambda (state start params colon atsign)
680            (format-escape state start params #t atsign)))
681    (#\@ ,(lambda (state start params colon atsign)
682            (format-escape state start params colon #t)))
683    (#\# ,(lambda (state start . rest)
684            (apply add-param state start 0 (fx- (vector-length (state-obj state)) (state-objpos state)) rest)))
685    (#\' ,(lambda (state start . rest)
686            (apply add-param state start 1 (string-ref (state-fmt state) (state-fmtpos state)) rest)))
687    (#\, ,(lambda (state start . rest)
688            (apply add-param state start 0 #f rest)))
689    (#\V ,(lambda (state start . rest)
690            (apply add-param state start 0 (state-obj-ref state 1) rest)))
691    (#\+ ,numeric-arg)
692    (#\- ,numeric-arg)
693    (#\0 ,numeric-arg)
694    (#\1 ,numeric-arg)
695    (#\2 ,numeric-arg)
696    (#\3 ,numeric-arg)
697    (#\4 ,numeric-arg)
698    (#\5 ,numeric-arg)
699    (#\6 ,numeric-arg)
700    (#\7 ,numeric-arg)
701    (#\8 ,numeric-arg)
702    (#\9 ,numeric-arg)))
703
704;;; Iteration
705
706; We use record ITERATOR to hold all the information about the
707; current iteration.
708;
709; FMT is the format string to which we should return once the
710; iteration is finished.
711;
712; ITOBJ is the list (vector) from where objects for the iteration
713; should be taken.  itobjpos the position in the vector.  This is
714; only used when colon is specified, otherwise STATE-OBJ and
715; STATE-OBJPOS are used and these are set to #f.
716;
717; FMTPOS-START is the position in the format string where
718; iteration starts.  FMTPOS-END is the position when the
719; iteration ends.
720;
721; RUNS is the number of times we have iterated.
722;
723; MAXRUMS is the maximum number of runs or #f for unlimited.
724;
725; OBJ is the list (vector) with the arguments, as it was when the
726; iteration started.
727;
728; OBJPOS is the position in obj when the iteration started.
729;
730; ATSIGN and COLON are booleans indicating those parameters were
731; present in the escape sequence that started the iteration.
732
733(define-record-type fm$iterator
734  (make-iterator fmt fmtpos-start fmtpos-end fmtend itobj itobjpos runs maxruns obj objpos atsign colon)
735  fm$iterator?
736  (fmt iterator-fmt #;iterator-fmt-set!)
737  (fmtpos-start iterator-fmtpos-start iterator-fmtpos-start-set!)
738  (fmtpos-end iterator-fmtpos-end iterator-fmtpos-end-set!)
739  (fmtend iterator-fmtend #;iterator-fmtend-set!)
740  (itobj iterator-itobj iterator-itobj-set!)
741  (itobjpos iterator-itobjpos iterator-itobjpos-set!)
742  (runs iterator-runs iterator-runs-set!)
743  (maxruns iterator-maxruns iterator-maxruns-set!)
744  (obj iterator-obj #;iterator-obj-set!)
745  (objpos iterator-objpos #;iterator-objpos-set!)
746  (atsign iterator-atsign #;iterator-atsign-set!)
747  (colon iterator-colon #;iterator-colon-set!))
748
749;;; Iteration
750
751; Stop an iteration: set obj and obj post back to a sane value and remove the
752; iterate entry from the list.
753
754(define (stop-iteration state it start-end)
755  (state-fmtend-set! state (iterator-fmtend it))
756  (state-fmt-set! state (iterator-fmt it))
757  (state-fmtpos-set! state (iterator-fmtpos-end it))
758  (state-obj-set! state (iterator-obj it))
759  ; Using current state objpos when @ since all argument may not have been used
760  ; during iteration
761  #;(state-objpos-set! state (fx+ (iterator-objpos it) (if (iterator-atsign it) 1 0)))
762  (unless (iterator-atsign it)
763    (state-objpos-set! state (iterator-objpos it)))
764  (state-iterate-set! state (cdr (state-iterate state))) )
765
766; Resume iterating: set obj and objpos to valid values (if needed), push #\{ to
767; nest, set things to a valid state and set the appropriate fmtpos.
768
769(define (resume-iteration state it start params colon atsign)
770  (when (iterator-colon it)
771    (state-obj-set! state (list->vector (vector-ref (iterator-itobj it) (iterator-itobjpos it))))
772    (state-objpos-set! state 0)
773    (iterator-itobjpos-set! it (fx+ 1 (iterator-itobjpos it))))
774  (iterator-runs-set! it (fx+ 1 (iterator-runs it)))
775  (state-nest-push! state #\{)
776  (state-condskip-push! state 0)
777  (state-fmtpos-set! state (iterator-fmtpos-start it)) )
778
779; Should the iteration end?
780
781(define (iterator-stop? state it at-least-once)
782  (or (and (iterator-maxruns it) (fx= (iterator-runs it) (iterator-maxruns it)))
783      (and (not (and at-least-once (fx= 0 (iterator-runs it))))
784           (if (iterator-colon it)
785             (fx<= (vector-length (iterator-itobj it)) (iterator-itobjpos it))
786             (fx<= (vector-length (state-obj state)) (state-objpos state))))))
787
788; Formatter function called to begin the iteration (when ~{ is
789; found):
790
791; Add a function to ITERATE list and use CONDSKIP to cause the
792; parser to skip until the end (~}) for the iteration to begin.
793
794(define (formatter-iteration-start state start params colon atsign)
795  (when (cond-valid? state)
796    (state-iterate-push! state
797      (make-iterator (state-fmt state) (state-fmtpos state) #f (state-fmtend state)
798                     #f #f
799                     0
800                     (if (null? params)
801                       (and format:iteration-bounded format:max-iterations)
802                       (car params))
803                     (state-obj state)
804                     ; When @ then termination objpos is state-objpos since
805                     ; not all arguments may be used during interation
806                     #;(if atsign (vector-length (state-obj state)) (fx+ 1 (state-objpos state)))
807                     (if atsign #f (fx+ 1 (state-objpos state)))
808                     atsign colon)))
809  (state-nest-push! state #\{)
810  (state-condskip-push! state -1) )
811
812; Formatter function called to end one iteration, either
813; continuing to iterate from the beginning or stopping.
814; To be called when ~} is found.
815
816; If we're in a valid state, call the iterator, which resets the
817; state to a valid state.
818
819(define (formatter-iteration-end state start params colon atsign)
820  (state-nest-pop! state #\{)
821  (state-condskip-pop! state)
822  (when (cond-valid? state)
823    (assert (not (null? (state-iterate state))))
824    (let ((it (car (state-iterate state))))
825      (when (fx= 0 (iterator-runs it))
826        (start-iteration state it start params colon atsign))
827      (if (iterator-stop? state it colon)
828        (stop-iteration state it start)
829        (resume-iteration state it start params colon atsign) ) ) ) )
830
831; Start iterating: set itobj and itobjpos to valid values (if needed) and set
832; obj and objpos to valid values (again, if needed).
833
834(define (start-iteration state it start-end params colon atsign)
835  (iterator-fmtpos-end-set! it (state-fmtpos state))
836  (when (fx= (iterator-fmtpos-start it) start-end)
837    (state-fmtend-push! state
838      (lambda () (formatter-iteration-end state start-end params colon atsign)))
839    (state-fmt-set! state (state-obj-ref state 1))
840    (state-fmtpos-set! state 0)
841    (iterator-fmtpos-start-set! it 0))
842  (when (iterator-colon it)
843    (iterator-itobj-set! it
844      (if (iterator-atsign it) (state-obj state) (list->vector (state-obj-ref state))))
845    (iterator-itobjpos-set! it
846      (if (iterator-atsign it) (state-objpos state) 0)))
847  (unless (iterator-atsign it)
848    (state-obj-set! state (list->vector (state-obj-ref state)))
849    (state-objpos-set! state 0) ) )
850
851; Check if an up-and-out character should actually stop an iteration.
852
853(define (up-and-out-check? state params)
854  (cond
855    ((null? params)
856     (fx= (state-objpos state) (vector-length (state-obj state))))
857    ((null? (cdr params))
858     (fx= 0 (first params)))
859    ((null? (cddr params))
860     (fx= (first params) (second params)))
861    (else
862      (let ((m (second params)))
863        (and (fx<= (first params) m) (fx<= m (third params))) ) ) ) )
864
865(define (formatter-iteration-up-and-out)
866  (formatter-function
867    (lambda (state start params colon atsign)
868      (when (up-and-out-check? state params)
869        (cond
870          ((null? (state-nest state))
871           (state-fmtpos-set! state (string-length (state-fmt state))))
872          ((char=? #\{ (car (state-nest state)))
873           (iterator-maxruns-set! (car (state-iterate state)) 0)
874           (state-condskip-pop! state)
875           (state-condskip-push! state -1)))))))
876
877;`~{STR~}'
878;     Iteration (args come from the next argument (a list)).
879;    `~n{'
880;          at most N iterations.
881;
882;    `~:{'
883;          args from next arg (a list of lists).
884;
885;    `~@{'
886;          args from the rest of arguments.
887;
888;    `~:@{'
889;          args from the rest args (lists).
890;
891;`~^'
892;     Up and out.
893;    `~n^'
894;          aborts if N = 0
895;
896;    `~n,m^'
897;          aborts if N = M
898;
899;    `~n,m,k^'
900;          aborts if N <= M <= K
901
902(define *formatter-iteration*
903  `((#\{ ,formatter-iteration-start)
904    (#\} ,formatter-iteration-end)
905    (#\^ ,(formatter-iteration-up-and-out))))
906
907;;; Case conversion
908
909; Generic case-conversion function.  Returns a procedure that given a
910; character, performs case convertion and returns it.
911;
912; start-first specifies what transformation to apply to the first character of
913; the first word, start-rest to the first character of subsequent words.
914; inner-first and inner-rest to characters after the first character in a word
915; to the first word and to all subsequent words respectively.
916;
917; transformation is downcase for #f & upcase otherwise.
918
919(define (tocase start-first start-rest inner-first inner-rest)
920  (let ((current start-first) (inner inner-first))
921    (lambda (c)
922      (let ((func (if current char-upcase char-downcase)))
923        (cond
924          ((or (char-numeric? c) (char-alphabetic? c))
925           (set! current inner))
926          (else
927            (set! current start-rest)
928            (set! inner inner-rest)))
929        (func c)))))
930
931(define (formatter-caseconv-start state start params colon atsign)
932  (state-nest-push! state #\()
933  (when (cond-valid? state)
934    (when (fx= 0 (state-caseconv-depth state))
935      (state-caseconv-set! state
936        (tocase
937          (or atsign colon)       ; Uppercase 1st letter of 1st word?
938          colon                   ; Uppercase 1st letter of subsequent words?
939          (and atsign colon)      ; Uppercase subsequent letters of 1st word?
940          (and atsign colon))))   ; Uppercase subsequent letters of subsequent words?
941    (state-caseconv-depth-set! state (fx+ 1 (state-caseconv-depth state)))))
942
943(define (formatter-caseconv-end state start params colon atsign)
944  (state-nest-pop! state #\()
945  (when (cond-valid? state)
946    (state-caseconv-depth-set! state (fx- 1 (state-caseconv-depth state)))
947    (when (fx= 0 (state-caseconv-depth state))
948      (state-caseconv-set! state identity))))
949
950; `~(str~)'
951;      Case conversion (converts by `string-downcase').
952;     `~:(str~)'
953;           converts by `string-capitalize'.
954;
955;     `~@(str~)'
956;           converts by `string-capitalize-first'.
957;
958;     `~:@(str~)'
959;           converts by `string-upcase'.
960
961(define *formatter-caseconv*
962  `((#\( ,formatter-caseconv-start)
963    (#\) ,formatter-caseconv-end)))
964
965;;; Printing control characters
966
967(define (formatter-chars output)
968  (formatter-function
969    (lambda (state start params colon atsign)
970      (let-optionals params ((times 1))
971        (*formatter-out-char-times state times output)))))
972
973(define (formatter-chars-newline-if)
974  (formatter-function
975    (lambda (state start params colon atsign)
976      (let-optionals params ((times 1))
977        (when (and (fx< 0 times)
978                   (fx< 0 (state-colpos state)))
979          (*formatter-out-char state #\newline))
980        (*formatter-out-char-times state (fx- times 1) #\newline)))))
981
982(define (formatter-chars-skip-whitespace)
983  (formatter-function
984    (lambda (state start params colon atsign)
985      ; Ignore or print leading newline?
986      (when atsign
987        (*formatter-out-char state #\newline))
988      (state-fmtpos-set! state (fx+ (state-fmtpos state) 1))
989      ; Ignore or print subsequent whitespace?
990      (state-fmtpos-set! state
991        (let* ((fmt (state-fmt state))
992               (fmtlen (string-length fmt)))
993          (let loop ((fmtpos (state-fmtpos state)))
994            (if (fx>= fmtpos fmtlen)
995              fmtlen
996              (let ((char (string-ref fmt fmtpos)))
997                (if (char-whitespace? char)
998                  (begin
999                    (when colon
1000                      (*formatter-out-char state char))
1001                    (loop (fx+ fmtpos 1)))
1002                  fmtpos)))))))))
1003
1004; `~%'
1005;      Newline.
1006;     `~n%'
1007;           print N newlines.
1008;
1009; `~&'
1010;      print newline if not at the beginning of the output line.
1011;     `~n&'
1012;           prints `~&' and then N-1 newlines.
1013;
1014; `~|'
1015;      Page Separator.
1016;     `~n|'
1017;           print N page separators (#\page).
1018;
1019; `~~'
1020;      Tilde.
1021;     `~n~'
1022;           print N tildes.
1023;
1024; `~/'
1025;      Print a `#\tab' character
1026;     `~n/'
1027;           print N `#\tab' characters.
1028;
1029; `~_'
1030;      Print a `#\space' character
1031;     `~n_'
1032;           print N `#\space' characters.
1033;
1034; `~'<newline>
1035;      Continuation Line. Skip all whitespace until the next non-whitespace.
1036;     `~:'<newline>
1037;           newline is ignored, whitespace left.
1038;
1039;     `~@'<newline>
1040;           newline is left, whitespace ignored.
1041;
1042;     `~:@'<newline>
1043;           newline and whitespace are left.
1044
1045
1046(define *formatter-chars*
1047  `((#\% ,(formatter-chars #\newline))
1048    (#\& ,(formatter-chars-newline-if))
1049    (#\| ,(formatter-chars #\page))
1050    (#\/ ,(formatter-chars #\tab))
1051    (#\~ ,(formatter-chars #\~))
1052    (#\_ ,(formatter-chars #\space))
1053    (#\newline ,(formatter-chars-skip-whitespace))))
1054
1055;;; Printing numbers
1056
1057;; Number Names
1058
1059(define *roman-numerals*
1060  '((1000 #\M) (500 #\D) (100 #\C) (50 #\L) (10 #\X) (5 #\V) (1 #\I)))
1061
1062;;
1063
1064(define (add-comma char width result)
1065  (if char
1066    (let ((width-remaining (fx- width 1)))
1067      (let ((result
1068            (cdr
1069              (fold-right
1070                (lambda (c rest)
1071                  (let ((remwid (car rest)))
1072                    (if (fx= 0 remwid)
1073                      (cons width-remaining (cons* c char (cdr rest)))
1074                      (cons (fx- remwid 1) (cons c (cdr rest))) ) ) )
1075                `(,width . ())
1076                result))))
1077        ; Strip any leading comma char
1078        (let ((1st-char (first result)))
1079          (cond
1080            ((char=? char 1st-char)
1081              (cdr result))
1082            ((or (char=? #\+ 1st-char) (char=? #\- 1st-char))
1083              (if (and (not (null? (cdr result)))
1084                       (char=? char (second result)))
1085                (cons 1st-char (cddr result))
1086                result))
1087            (else
1088              result) ) ) ) )
1089    result) )
1090
1091;; Pull numbers from the argument list
1092
1093(define (get-number state inc)
1094  (let ((num (state-obj-ref state inc)))
1095    (unless (number? num)
1096      (formatter-error "invalid number" num) )
1097    num ) )
1098
1099(define (get-float state inc)
1100  (let ((num (get-number state inc)))
1101    (if format:floats
1102      (begin
1103        (when (complex-strict? num)
1104          (formatter-error "invalid one dimensional number" num) )
1105        (exact->inexact num) )
1106      (formatter-error "floating-point numbers unsupported" num) ) ) )
1107
1108(define (get-complex state inc)
1109  (let ((num (get-number state inc)))
1110    (if format:complex
1111      (if (complex-strict? num)
1112        num
1113        (make-rectangular (exact->inexact num) 0.0) )
1114      (formatter-error "complex numbers unsupported" num) ) ) )
1115
1116; Given a number, return a list with the digits of its representation in the
1117; specified base.  If always-sign, the sign of the number is always included in
1118; the beginning.
1119
1120(define (number-list number always-sign base)
1121  (let ((tail (string->list (number->string number base))))
1122    (if (and always-sign (not (negative? number)))
1123      (cons #\+ tail)
1124      tail)))
1125
1126(define (format-roman-old state num)
1127  (when (positive? num)
1128    (let ((sub (find (lambda (x) (>= num (car x))) *roman-numerals*)))
1129      (*formatter-out-char state (cadr sub))
1130      (format-roman-old state (- num (car sub))))))
1131
1132(define (format-roman state num)
1133  (when (positive? num)
1134    (let loop ((ls *roman-numerals*))
1135      (let* ((big (car ls)) (big-n (car big)))
1136        (cond
1137          ((>= num big-n)
1138           (*formatter-out-char state (cadr big))
1139           (format-roman state (- num big-n)))
1140          ((and (> (* 2 num) big-n)
1141                (find (compose (lambda (x) (<= (+ x 1) (- big-n x) num)) car) ls))
1142           => (lambda (c)
1143                (*formatter-out-char state (cadr c))
1144                (*formatter-out-char state (cadr big))
1145                (format-roman state (- num (- big-n (car c))))))
1146          (else (loop (cdr ls))))))))
1147
1148(define (format-number-english func zero)
1149  (lambda (state num)
1150    (cond
1151      ((not (integer? num)) (formatter-error "invalid integer" num))
1152      ((zero? num) (*formatter-out-string state zero))
1153      ((negative? num)
1154       (*formatter-out-string state "minus ")
1155       (func state (- num)))
1156      (else (func state num)))))
1157
1158;; Cardinal formatting
1159
1160(define (initial-pows num pow)
1161  (if (zero? num)
1162    '()
1163    (cons (cons (remainder num 1000) pow)
1164          (initial-pows (quotient num 1000) (+ pow 1)))))
1165
1166; Show a number between 0 and 20
1167
1168(define (format-cardinal-20 state num)
1169  (*formatter-out-string state (vector-ref *cardinal-ones* num)))
1170
1171; Show a number between 0 and 100
1172
1173(define (format-cardinal-100 state num)
1174  (cond
1175    ((< num 20) (format-cardinal-20 state num))
1176    (else
1177      (*formatter-out-string state (vector-ref *cardinal-tens* (quotient num 10)))
1178      (let ((ones (remainder num 10)))
1179        (unless (zero? ones)
1180          (unless (zero? (quotient num 10))
1181            (*formatter-out-char state #\-))
1182          (format-cardinal-20 state ones))))))
1183
1184; Show a number between 0 and 1000
1185
1186(define (format-cardinal-1000 state num)
1187  (let ((hundreds (quotient num 100)) (rest (remainder num 100)))
1188    (unless (zero? hundreds)
1189      (format-cardinal-20 state hundreds)
1190      (*formatter-out-string state *cardinal-hundred*))
1191    (unless (zero? rest)
1192      (unless (zero? hundreds)
1193        (*formatter-out-char state #\space))
1194      (format-cardinal-100 state rest))))
1195
1196(define (format-cardinal-positive state num)
1197  (let loop ((pows (reverse (initial-pows num 0))) (start #t))
1198    (unless (null? pows)
1199      (unless (zero? (caar pows))
1200        (unless start
1201          (*formatter-out-string state ", "))
1202        (format-cardinal-1000 state (caar pows))
1203        (*formatter-out-string state (vector-ref *thousand-factor-names* (cdar pows))))
1204      (loop (cdr pows) #f))))
1205
1206(define format-cardinal
1207  (format-number-english format-cardinal-positive "zero"))
1208
1209;; Ordinal formatting
1210
1211; Show a number between 0 and 20
1212
1213(define (format-ordinal-20 state num)
1214  (*formatter-out-string state (vector-ref *ordinal-ones* num)))
1215
1216(define (format-ordinal-positive state num)
1217  (cond
1218    ((>= num 100)
1219     (format-cardinal-positive state (* (quotient num 100) 100))
1220     (let ((rest (remainder num 100)))
1221       (unless (zero? rest)
1222         (*formatter-out-char state #\space)
1223         (format-ordinal-positive state rest))))
1224    ((< num 20)
1225      (format-ordinal-20 state num))
1226    (else
1227      (let ((tens (quotient num 10)) (ones (remainder num 10)))
1228        (cond
1229         ((zero? ones)
1230          (*formatter-out-string state (vector-ref *ordinal-tens* tens)))
1231         (else
1232           (*formatter-out-string state (vector-ref *cardinal-tens* tens))
1233           (*formatter-out-char state #\-)
1234           (*formatter-out-string state (vector-ref *ordinal-ones* ones))))))))
1235
1236(define format-ordinal
1237  (format-number-english format-ordinal-positive "zeroth"))
1238
1239;; Integer formatting
1240
1241(define (formatter-integer/radix base)
1242  (formatter-function
1243    (lambda (state start params colon atsign)
1244      (let-optionals params ((mincol 0) (pad-char #\space) (commachar #\,) (commawidth 3))
1245        (let ((result (add-comma (and colon (or commachar #\,)) (or commawidth 3)
1246                                 (number-list (get-number state 1) atsign base))))
1247          (*formatter-out-char-times state (fxmax 0 (fx- (or mincol 0) (length result))) (or pad-char #\space))
1248          (*formatter-out-char-list state result))))))
1249
1250(define (formatter-radix state start params colon atsign)
1251  (cond
1252    ((not (null? params))
1253     ((formatter-integer/radix (car params)) state start
1254        (reverse (cdr params)) ; formatter-function reverses params so we must do it 1st
1255        colon atsign))
1256    (atsign
1257     ((if colon format-roman-old format-roman) state (state-obj-ref state 1)))
1258    (else
1259     ((if colon format-ordinal format-cardinal) state (state-obj-ref state 1)))))
1260
1261;; Float formatting
1262
1263; Float Helpers
1264
1265(define-constant LN10   2.3025850929940456840179914546843642076011) ; (log 10)
1266
1267(define (log10 num)
1268  (/ (log (abs num)) LN10) )
1269
1270; Round number.  digits specifies the number of digits in the decimal expansion
1271; allowed.
1272
1273(define (round-to-digits number width digits)
1274  (if (or width digits)
1275    (let ((mult (expt 10 (or digits
1276                             (- width
1277                                (if (zero? number) number (ceiling (log10 number)))
1278                                1)))))
1279      (/ (round (* number mult)) mult))
1280    number))
1281
1282; Given a positive fixed float number, return a list with the digits of its
1283; representation.  digits is the number of digits in the decimal expansion.
1284; No padding is performed.
1285
1286(define (unsigned-fixed-float-list number width digits)
1287  (let* ((number (round-to-digits number width digits))
1288         (str (number->string number))
1289         (dot (substring-index "." str))
1290         (middle
1291           (if dot
1292             (string->list (substring str dot ((if digits (cute fxmin (fx+ dot (fx+ digits 1)) <>) identity) (string-length str))))
1293             '(#\.)))
1294         (tail
1295           (cond
1296             (digits (make-list (fxmax 0 (fx- (fx- digits (length middle)) -1)) #\0))
1297             (dot '())
1298             (else '(#\0)))))
1299    (append
1300      (let ((result (string->list (if dot (substring str 0 dot) str))))
1301        (if (and width
1302                 (fx= width (fx+ (fx+ (fx+ (length result) (if dot (- (string-length str) dot) 1)) (length tail)) -1))
1303                 (zero? (truncate number)))
1304          (cdr result)
1305          result))
1306      middle
1307      tail)))
1308
1309; Given a fixed float number, return a list with the digits of its
1310; representation.  If always-sign, the sign of the number is always included in
1311; the beginning.  digits is the number of digits in the decimal expansion.
1312; No padding is performed.
1313
1314(define (fixed-float-list number always-sign width digits)
1315  (if (or always-sign (negative? number))
1316    (cons (if (negative? number) #\- #\+)
1317          (fixed-float-list (abs number) #f (and width (fx- width 1)) digits))
1318    (unsigned-fixed-float-list number width digits)) )
1319
1320(define (exponential-float-list num always-sign width digits exp-digits scale overflow-ch exp-char)
1321  (let* ((expo (if (zero? num) 0 (- (inexact->exact (floor (log10 num))) (- (or scale 1) 1))))
1322         (expo-list (string->list (number->string (abs expo))))
1323         (fixed
1324           (fixed-float-list
1325             (/ num (expt 10 expo))
1326             always-sign
1327             (and width (fx- (fx- width 2) (or exp-digits (length expo-list))))
1328             (and digits
1329                  (if (and scale (fx< 0 scale))
1330                    (fx- (fx- digits scale) -1)
1331                    digits)))))
1332    (if (and exp-digits overflow-ch (< exp-digits (length expo-list)))
1333      #f
1334      (append
1335        fixed
1336        `(,exp-char)
1337        (if (negative? expo) '(#\-) '(#\+))
1338        (if (and exp-digits
1339                 (or (not width)
1340                     (fx<= (fx+ (fx+ (length fixed) 2) exp-digits) width)))
1341          (make-list (fxmax 0 (fx- exp-digits (length expo-list))) #\0)
1342          '())
1343        expo-list))))
1344
1345; Given a positive fixed float number, return a list with the digits of its
1346; representation. digits-before is the number of digits before the
1347; decimal.  digits-after is the number of digits after the decimal.
1348; No  padding is performed.
1349
1350(define (fixed-dollar-list amount digits-before digits-after)
1351  (unsigned-fixed-float-list (abs amount) #f digits-after) )
1352
1353(define (out-fixed-float-list state width overflow-ch pad-char flt-res)
1354  (let ((len (length flt-res)))
1355    (when width
1356      (*formatter-out-char-times state (fxmax 0 (fx- width len)) (or pad-char #\space)))
1357    (if (and width overflow-ch (fx> len width))
1358      (*formatter-out-char-times state width overflow-ch)
1359      (*formatter-out-char-list state flt-res)) ) )
1360
1361; Float formatters
1362
1363(define (formatter-exponential state start params colon atsign)
1364  (let-optionals params ((width #f) (digits #f) (exp-digits #f) (scale #f) (overflow-ch #f) (pad-char #f) (exp-char format:expch))
1365    (let* ((result (exponential-float-list (get-float state 1) atsign width digits exp-digits scale overflow-ch exp-char))
1366           (len (and result (length result))))
1367      (cond
1368        ((or (not result) (and width overflow-ch (fx> len width)))
1369         (*formatter-out-char-times state width overflow-ch))
1370        (else
1371          (when width
1372            (*formatter-out-char-times state (fxmax 0 (fx- width len)) (or pad-char #\space)))
1373          (*formatter-out-char-list state result))))))
1374
1375(define (formatter-fixed-float state start params colon atsign)
1376  (let-optionals params ((width #f) (digits #f) (scale #f) (overflow-ch #f) (pad-char #f))
1377    (out-fixed-float-list state width overflow-ch pad-char
1378      (fixed-float-list (* (get-float state 1) (expt 10 (or scale 0))) atsign width digits)) ) )
1379
1380(define (formatter-general-float state start params colon atsign)
1381  (let-optionals params ((width #f) (digits #f) (exp-digits #f) (scale 1) (overflow-ch #f) (pad-char #f) (exp-ch format:expch))
1382    (let* ((num (get-float state 0))
1383           (n (if (zero? num) 0 (inexact->exact (ceiling (log10 num)))))
1384           (ee (if exp-digits (fx+ 2 exp-digits) 4))
1385           (ww (and width (fx- width ee)))
1386           (d (or digits (max (string-length (number->string num)) (min n 7))))
1387           (dd (- d n)))
1388      (cond
1389        ((<= 0 dd d)
1390         (formatter-fixed-float state start (list ww dd #f overflow-ch (or pad-char #\space)) colon atsign)
1391         (tabulate state ee 1 #t (or pad-char #\space)))
1392        (else
1393          (formatter-exponential state start params colon atsign))))))
1394
1395(define (formatter-dollar state start params colon atsign)
1396  (let-optionals params ((digits-after #f) (min-digits-before #f) (min-width #f) (pad-char #f))
1397    (let* ((digits-after (or digits-after 2))
1398           (min-digits-before (or min-digits-before 1))
1399           (min-width (or min-width 0))
1400           (pad-char (or pad-char #\space))
1401           (num (get-float state 1))
1402           (sign (if (negative? num) #\- (and atsign #\+)))
1403           (sign-len (if sign 1 0))
1404           (result (fixed-dollar-list num min-digits-before digits-after))
1405           (len (fx+ (length result) sign-len))
1406           (leading-digits (list-index (cut char=? #\. <>) result))
1407           (pad-zeros (fxmax 0 (fx- min-digits-before (or leading-digits 0)))) )
1408      ; Per CL spec, but probably never happen.
1409      (if (< (fxmax min-width 100) (fx- len (fx+ 1 sign-len)))
1410        (formatter-exponential state start
1411          (list min-width (fx+ digits-after (fx- min-digits-before 1)) #f #f #f pad-char)
1412          colon atsign)
1413        (begin
1414          ; Sign before padding?
1415          (when colon
1416            (*formatter-out-char state sign))
1417          ; Padding
1418          (*formatter-out-char-times state
1419            (fxmax 0 (fx- min-width (fx+ pad-zeros len))) (or pad-char #\space))
1420          ; Sign after padding?
1421          (when (and (not colon) sign)
1422            (*formatter-out-char state sign))
1423          ; Zero padding
1424          (when (fx< 0 pad-zeros)
1425            (*formatter-out-char-times state pad-zeros #\0))
1426          (*formatter-out-char-list state result))) ) ) )
1427
1428(define (formatter-complex state start params colon atsign)
1429  (let-optionals params ((width #f) (digits #f) (scale #f) (overflow-ch #f) (pad-char #f))
1430    (let ((z (get-complex state 1)))
1431      (out-fixed-float-list state width overflow-ch pad-char
1432        (fixed-float-list (* (real-part z) (expt 10 (or scale 0))) atsign width digits))
1433      (out-fixed-float-list state width overflow-ch pad-char
1434        (fixed-float-list (* (imag-part z) (expt 10 (or scale 0))) #t width digits))
1435      (*formatter-out-char state #\i) ) ) )
1436
1437; `~D'
1438;      Decimal.
1439;     `~@D'
1440;           print number sign always.
1441;
1442;     `~:D'
1443;           print comma separated.
1444;
1445;     `~mincol,padchar,commachar,commawidthD'
1446;           padding.
1447;
1448; `~X'
1449;      Hexadecimal.
1450;     `~@X'
1451;           print number sign always.
1452;
1453;     `~:X'
1454;           print comma separated.
1455;
1456;     `~mincol,padchar,commachar,commawidthX'
1457;           padding.
1458;
1459; `~O'
1460;      Octal.
1461;     `~@O'
1462;           print number sign always.
1463;
1464;     `~:O'
1465;           print comma separated.
1466;
1467;     `~mincol,padchar,commachar,commawidthO'
1468;           padding.
1469;
1470; `~B'
1471;      Binary.
1472;     `~@B'
1473;           print number sign always.
1474;
1475;     `~:B'
1476;           print comma separated.
1477;
1478;     `~mincol,padchar,commachar,commawidthB'
1479;           padding.
1480;
1481; `~nR'
1482;      Radix N.
1483;     `~n,mincol,padchar,commachar,commawidthR'
1484;           padding.
1485;
1486;      `~@R'
1487;      print a number as a Roman numeral.
1488;
1489;      `~:@R'
1490;      print a number as an "old fashioned" Roman numeral.
1491;
1492;      `~:R'
1493;      print a number as an ordinal English number.
1494;
1495;      `~R'
1496;      print a number as a cardinal English number.
1497;
1498; `~F'
1499;      Fixed-format floating-point (prints a flonum like MMM.NNN).
1500;     `~width,digits,scale,overflowchar,padcharF'
1501;
1502;     `~@F'
1503;           If the number is positive a plus sign is printed.
1504;
1505;
1506; `~E'
1507;      Exponential floating-point (prints a flonum like MMM.NNN`E'EE).
1508;     `~width,digits,exponentdigits,scale,overflowchar,padchar,exponentcharE'
1509;
1510;     `~@E'
1511;           If the number is positive a plus sign is printed.
1512;
1513; `~G'
1514;      General floating-point (prints a flonum either fixed or
1515;      exponential).
1516;     `~width,digits,exponentdigits,scale,overflowchar,padchar,exponentcharG'
1517;
1518;     `~@G'
1519;           If the number is positive a plus sign is printed.
1520;
1521; `~$'
1522;      Dollars floating-point (prints a flonum in fixed with signs
1523;      separated).
1524;     `~digits,scale,width,padchar$'
1525;
1526;     `~@$'
1527;           If the number is positive a plus sign is printed.
1528;
1529;     `~:@$'
1530;           A sign is always printed and appears before the padding.
1531;
1532;     `~:$'
1533;           The sign appears before the padding.
1534;
1535; `~I'
1536;      print a R4RS complex number as `~F~@Fi' with passed parameters for
1537;      `~F'.
1538
1539(define *formatter-numbers*
1540  `((#\R ,(formatter-function formatter-radix))
1541    (#\X ,(formatter-integer/radix 16))
1542    (#\D ,(formatter-integer/radix 10))
1543    (#\O ,(formatter-integer/radix 8))
1544    (#\B ,(formatter-integer/radix 2))
1545    (#\G ,(formatter-function formatter-general-float))
1546    (#\F ,(formatter-function formatter-fixed-float))
1547    (#\E ,(formatter-function formatter-exponential))
1548    (#\$ ,(formatter-function formatter-dollar))
1549    (#\I ,(formatter-function formatter-complex))))
1550
1551;;; Conditional Expressions
1552
1553(define (formatter-cond-start state start params colon atsign)
1554  (state-nest-push! state #\[)
1555  (state-condskip-push! state
1556    (cond
1557      ; If not on a valid state, use -1 so it will never become valid.
1558      ((not (cond-valid? state)) -1)
1559      (colon  (if (state-obj-ref state 1) 1 0))
1560      (atsign (if (%state-obj-ref state) 0 (begin (state-objpos-inc! state 1) -1)))
1561      ((null? params) (state-obj-ref state 1))
1562      (else (car params)))))
1563
1564(define (formatter-cond-next state start params colon atsign)
1565  (set-car! (state-condskip state)
1566    (let ((newval (fx- (car (state-condskip state)) 1)))
1567      (if colon (fxmin 0 newval) newval))))
1568
1569(define (formatter-cond-end state start params colon atsign)
1570  (state-nest-pop! state #\[)
1571  (state-condskip-pop! state))
1572
1573;`~[str0~;str1~;...~;strn~]'
1574;     Conditional Expression (numerical clause conditional).
1575;    `~n['
1576;          take argument from N.
1577;
1578;    `~@['
1579;          true test conditional.
1580;
1581;    `~:['
1582;          if-else-then conditional.
1583;
1584;    `~;'
1585;          clause separator.
1586;
1587;    `~:;'
1588;          default clause follows.
1589
1590(define *formatter-cond*
1591  `((#\[ ,formatter-cond-start)
1592    (#\; ,formatter-cond-next)
1593    (#\] ,formatter-cond-end)))
1594
1595;;; Indirection
1596
1597; Function called when the end of the string parsed as the result of an
1598; indirection is reached.  It resets the state to the original string, right
1599; after the character that caused the indirection.
1600
1601(define (indirection-end state fmt fmtpos obj objpos atsign)
1602  (lambda ()
1603    (state-fmtend-pop! state)
1604    (state-fmt-set! state fmt)
1605    (state-fmtpos-set! state fmtpos)
1606    (unless atsign
1607      (state-obj-set! state obj)
1608      (state-objpos-set! state (fx+ objpos 2)))))
1609
1610(define (formatter-indirection state start params colon atsign)
1611  (when (cond-valid? state)
1612    (state-fmtend-push! state
1613      (indirection-end state (state-fmt state) (state-fmtpos state) (state-obj state) (state-objpos state) atsign))
1614    (state-fmt-set! state (state-obj-ref state 1))
1615    (state-fmtpos-set! state 0)
1616    (unless atsign
1617      (state-obj-set! state (list->vector (state-obj-ref state 1)))
1618      (state-objpos-set! state 0))))
1619
1620;`~?'
1621;     Indirection (expects indirect arguments as a list).
1622;    `~@?'
1623;          extracts indirect arguments from format arguments.
1624; `~K'
1625;      Same as `~?.'
1626
1627(define *formatter-indirection*
1628  `((#\? ,formatter-indirection)
1629    (#\K ,formatter-indirection)))
1630
1631;;; Argument jumping
1632
1633(define (formatter-jump state start params colon atsign)
1634  (when (cond-valid? state)
1635    (let-optionals params ((n (if atsign 0 1)))
1636      (if (and colon atsign)
1637        (formatter-error "cannot specify both : and @ for ~*")
1638        ((if atsign state-objpos-set! state-objpos-inc!)
1639         state ((if colon - +) n))))))
1640
1641;`~*'
1642;     Argument Jumping (jumps 1 argument forward).
1643;    `~n*'
1644;          jumps N arguments forward.
1645;
1646;    `~:*'
1647;          jumps 1 argument backward.
1648;
1649;    `~n:*'
1650;          jumps N arguments backward.
1651;
1652;    `~@*'
1653;          jumps to the 0th argument.
1654;
1655;    `~n@*'
1656;          jumps to the Nth argument (beginning from 0)
1657
1658(define *formatter-jump*
1659  `((#\* ,formatter-jump)))
1660
1661;;; Object output
1662
1663(cond-expand
1664  (chicken
1665
1666    (define (out-char-lisp state char)
1667      (*formatter-out-string state "#\\")
1668      (let ((sym (char-name char)))
1669        (cond
1670          (sym
1671            (*formatter-out-string state (symbol->string sym)))
1672          ((char-set-contains? char-set:graphic char)
1673            (*formatter-out-char state char))
1674          (else
1675            (let* ((str (number->string (char->integer char) 16))
1676                   (strlen (string-length str)))
1677              (let ((out-hex-char
1678                    (lambda (prf wid)
1679                      (*formatter-out-char state prf)
1680                      (*formatter-out-char-times state (fx- wid strlen) #\0)
1681                      (*formatter-out-string state str))))
1682                (cond
1683                  ((fx<= strlen 2)  (out-hex-char #\x 2))
1684                  ((fx<= strlen 4)  (out-hex-char #\u 4))
1685                  (else             (out-hex-char #\U 8))) ) ) ) ) ) )
1686
1687  ) (else
1688
1689    (define (out-char-lisp state char)
1690      (*formatter-out-string state "#\\")
1691      (case char
1692        ((#\newline) (*formatter-out-string state "newline"))
1693        ((#\space) (*formatter-out-string state "space"))
1694        ((#\tab) (*formatter-out-string state "tab"))
1695        (else (*formatter-out-char state char))))
1696
1697  ) )
1698
1699(define (out-char-emacs state char)
1700  (let ((c (char->integer char)))
1701    (cond
1702      ((fx< c #x20) ; assumes that control chars are < #x20
1703       (*formatter-out-char state #\^)
1704       (*formatter-out-char state (integer->char (fx+ c #x40))))
1705      ((fx>= c #x7f)
1706       (*formatter-out-string state "#\\")
1707       (*formatter-out-string state (number->string c 8)))
1708      (else (*formatter-out-char state char)))))
1709
1710(define (formatter-char state start params colon atsign)
1711  (when (cond-valid? state)
1712    (let ((char (state-obj-ref state 1)))
1713      (assert (char? char))
1714      ((cond
1715         (colon out-char-emacs)
1716         (atsign out-char-lisp)
1717         (else *formatter-out-char))
1718       state
1719       char))))
1720
1721; Calculate how many instances of pad-char should be produced.
1722
1723(define (calc-padding n mincol colinc len)
1724  (if (fx< (fx+ len n) mincol)
1725    (calc-padding (fx+ n colinc) mincol colinc len)
1726    n))
1727
1728; Bind control character char to function show-func, used for displaying
1729; objects.  show-func is a one-argument function which should write (to the
1730; current-output-port) a representation of the object.  The code in
1731; formatter-padded will take care of padding and other details.
1732;
1733; atsign causes padding to be done at the left
1734; colon causes stringification
1735
1736(define (formatter-padded show-func)
1737  (formatter-function
1738    (lambda (state start params colon atsign)
1739      (let-optionals params ((mincol 0) (colinc 1) (minpad 0) (pad-char #\space))
1740        (let ((objstr (with-output-to-string (lambda () (show-func (state-obj-ref state 1))))))
1741          (unless atsign (*formatter-out-string state objstr))
1742          (*formatter-out-char-times state (calc-padding (or minpad 0) (or mincol 0) (or colinc 1) (string-length objstr)) (or pad-char #\space))
1743          (when atsign (*formatter-out-string state objstr)))))))
1744
1745(define (formatter-pretty-print)
1746  (formatter-function
1747    (lambda (state start params colon atsign)
1748      (let ((objstr (with-output-to-string (lambda () (pretty-print (state-obj-ref state 1))))))
1749        (*formatter-out-string state objstr)))))
1750
1751; `~C'
1752;      Character.
1753;     `~@C'
1754;           prints a character as the reader can understand it (i.e. `#\'
1755;           prefixing).
1756;
1757;     `~:C'
1758;           prints a character as emacs does (eg. `^C' for ASCII 03).
1759;
1760; `~A'
1761;      Aesthetic (print as `display' does).
1762;     `~@A'
1763;           left pad.
1764;
1765;     `~mincol,colinc,minpad,padcharA'
1766;           full padding.
1767;
1768; `~S'
1769;      S-expression (print as `write' does).
1770;     `~@S'
1771;           left pad.
1772;
1773;     `~mincol,colinc,minpad,padcharS'
1774;           full padding.
1775;
1776; `~Y'
1777;      Pretty print formatting of an argument for scheme code lists.
1778
1779(define *formatter-objs*
1780  `((#\A ,(formatter-padded display))
1781    (#\S ,(formatter-padded write))
1782    (#\Y ,(formatter-pretty-print))
1783    (#\C ,formatter-char)))
1784
1785;;; Version info
1786
1787(define (formatter-version state start params colon atsign)
1788  (*formatter-out-string state
1789    (if colon
1790      "$Version: 1.7 $"
1791      "Flexible Format Framework\n$Id: format-modular.scm 1.7 2007-06-08 12:00:00Z klovett $\n  Alejandro Forero Cuervo <azul@freaks-unidos.net>\n  Alex Shinn <foof@synthcode.com>\n  Kon Lovett <klovett@pacbell.net>\n")))
1792
1793; `~Q'
1794;      Prints information and a copyright notice on the format
1795;      implementation.
1796;     `~:Q'
1797;           prints format version.
1798
1799(define *formatter-version*
1800  `((#\Q ,formatter-version)))
1801
1802;;; Flushing output
1803
1804(define (formatter-flush state . rest)
1805  (when (cond-valid? state)
1806    (flush-output (state-out state))))
1807
1808; `~!'
1809;      Flushes the output if format DESTINATION is a port.
1810
1811(define *formatter-flush*
1812  `((#\! ,formatter-flush)))
1813
1814;;; Plural print
1815
1816(define (formatter-plural state start params colon atsign)
1817  (when (cond-valid? state)
1818    (when colon
1819      (state-objpos-inc! state -1))
1820    (*formatter-out-string state
1821      ((if (eqv? 1 (state-obj-ref state)) car cadr)
1822       (if atsign '("y" "ies") '("" "s"))))
1823    (state-objpos-inc! state)))
1824
1825;`~P'
1826;     Plural.
1827;    `~@P'
1828;          prints `y' and `ies'.
1829;
1830;    `~:P'
1831;          as `~P but jumps 1 argument backward.'
1832;
1833;    `~:@P'
1834;          as `~@P but jumps 1 argument backward.'
1835
1836(define *formatter-plural*
1837  `((#\P ,formatter-plural)))
1838
1839;;; Tabulation
1840
1841(define formatter-tabulate
1842  (formatter-function
1843    (lambda (state start params colon atsign)
1844      (let-optionals params ((colnum #f) (colinc #f) (tabchar #\space))
1845        (tabulate state (or colnum 1) (or colinc 1) atsign (or tabchar #\space))))))
1846
1847; `~T'
1848;      Tabulation.
1849;     `~@T'
1850;           relative tabulation.
1851;
1852;     `~colnum,colincT'
1853;           full tabulation.
1854
1855(define *formatter-tabulate*
1856  `((#\T ,formatter-tabulate)))
1857
1858;;; Formatter implementing Common Lisp's format function
1859;;; (With restrictions & extensions)
1860
1861; Supports the following escape sequences:
1862;
1863; ?!P{}^()%/~|_XDOB[;]?*ASCRFEQGTY$I&
1864;
1865; And supports the following parameter sequences:
1866;
1867; V
1868;
1869; The following are known to be missing:
1870; <>
1871;
1872; If you know of another unsupported standard escape sequence, please contact
1873; the authors.
1874
1875(define *formatter-cl*
1876  `(,*formatter-flush*
1877    ,*formatter-plural*
1878    ,*formatter-tabulate*
1879    ,*formatter-params*
1880    ,*formatter-iteration*
1881    ,*formatter-caseconv*
1882    ,*formatter-chars*
1883    ,*formatter-numbers*
1884    ,*formatter-cond*
1885    ,*formatter-indirection*
1886    ,*formatter-jump*
1887    ,*formatter-objs*
1888    ,*formatter-version*))
1889
1890(define format (make-format-function #f #\~ *formatter-cl*))
Note: See TracBrowser for help on using the repository browser.