source: project/release/3/format-modular/tags/1.8.1/format-modular.scm @ 9926

Last change on this file since 9926 was 9926, checked in by Kon Lovett, 12 years ago

Rel 1.8.1 w/ Explict use of SRFI 69.

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