source: project/release/5/format/trunk/format.scm @ 39880

Last change on this file since 39880 was 39880, checked in by Kon Lovett, 2 months ago

add version, build-dep... -> dep...

File size: 61.7 KB
Line 
1;;; "format.scm" Common LISP text output formatter for SLIB
2; Written 1992-1994 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de)
3; 2004 Aubrey Jaffer: made reentrant; call slib:error for errors.
4;
5; This code is in the public domain.
6
7; Authors of the original version (< 1.4) were Ken Dickey and Aubrey Jaffer.
8; Please send error reports to the email address above.
9; For documentation see slib.texi and format.doc.
10; For testing load formatst.scm.
11;
12; Version 3.1
13
14; Modified for CHICKEN Kon Lovett, Sep 25 2005
15;
16; - depends on srfi-13 functionality
17;
18; - no local defines for string & number operations
19;
20; - unprocessed arguments are not an error
21;
22; - fix for E format; wasn't leaving off leading 0 when result-len > len
23; so considered overflow
24;
25; - explicit use of fixnum arithmetic
26;
27; - keeps format:* style naming
28;
29; - exports configuration symbols
30;
31; - does not use intermediate string when output is a port
32;
33; - moved defines to toplevel
34
35
36(declare
37        (no-bound-checks)
38        (no-argc-checks)
39        (no-procedure-checks)
40        (always-bound
41                format:error-save))
42
43(module format
44    (format:symbol-case-conv
45                format:iobj-case-conv
46                format:expch
47                format:iteration-bounded
48                format:max-iterations
49                format:floats
50                format:complex-numbers
51                format:radix-pref
52                #;format:ascii-non-printable-charnames
53                format:fn-max
54                format:en-max
55                format:unprocessed-arguments-error?
56                #;format:version
57                #;format:iobj->str
58                format)
59
60(import scheme)
61(import (chicken base))
62(import (chicken port))
63(import (chicken string))
64(import (chicken pretty-print))
65(import (chicken fixnum))
66(import (srfi 13))
67
68
69;;; Configuration ------------------------------------------------------------
70
71(define format:symbol-case-conv #f)
72;; Symbols are converted by symbol->string so the case of the printed
73;; symbols is implementation dependent. format:symbol-case-conv is a
74;; one arg closure which is either #f (no conversion), string-upcase!,
75;; string-downcase! or string-capitalize!.
76
77(define format:iobj-case-conv #f)
78;; As format:symbol-case-conv but applies for the representation of
79;; implementation internal objects.
80
81(define format:expch #\E)
82;; The character prefixing the exponent value in ~e printing.
83
84(define format:iteration-bounded #t)
85;; If #t, "~{...~}" iterates no more than format:max-iterations times;
86;; if #f, there is no bound.
87
88(define format:max-iterations 100)
89;; Compatible with previous versions.
90
91(define format:floats #t)
92;; Detects if the scheme system implements flonums (see at eof).
93
94(define format:complex-numbers #f)
95;; Detects if the scheme system implements complex numbers.
96;; See use below for invocation-time detection of complex support.
97
98(define format:radix-pref (char=? #\# (string-ref (number->string 8 8) 0)))
99;; Detects if number->string adds a radix prefix.
100
101(define format:ascii-non-printable-charnames
102  '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel"
103     "bs"  "ht"  "nl"  "vt"  "np"  "cr"  "so"  "si"
104     "dle" "dc1" "dc2" "dc3" "dc4" "nak" "syn" "etb"
105     "can" "em"  "sub" "esc" "fs"  "gs"  "rs"  "us" "space"))
106
107(define format:fn-max 200)              ; max. number of number digits
108(define format:en-max 10)               ; max. number of exponent digits
109
110(define format:unprocessed-arguments-error? #f) ; CL says this is not an error
111
112;;; End of configuration ----------------------------------------------------
113
114(define format:version "3.1")
115
116(define format:space-ch (char->integer #\space))
117(define format:zero-ch (char->integer #\0))
118
119(define format:parameter-characters
120  '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\') )
121
122(define format:conditional-directives-characters
123        (append '(#\[ #\] #\; #\: #\@ #\^) format:parameter-characters) )
124
125(define format:iteration-directives-characters
126        (append '(#\{ #\} #\: #\@ #\^) format:parameter-characters) )
127
128;; cardinals & ordinals (from dorai@cs.rice.edu)
129
130(define format:cardinal-thousand-block-list
131  '#("" " thousand" " million" " billion" " trillion" " quadrillion"
132                                " quintillion" " sextillion" " septillion" " octillion" " nonillion"
133                                " decillion" " undecillion" " duodecillion" " tredecillion"
134                                " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
135                                " octodecillion" " novemdecillion" " vigintillion") )
136
137(define format:cardinal-ones-list
138  '#(#f "one" "two" "three" "four" "five"
139                                "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen"
140                                "fourteen" "fifteen" "sixteen" "seventeen" "eighteen"
141                                "nineteen") )
142
143(define format:cardinal-tens-list
144  '#(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty"
145                                         "ninety") )
146
147(define format:ordinal-ones-list
148  '#(#f "first" "second" "third" "fourth" "fifth"
149                                "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth"
150                                "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth"
151                                "eighteenth" "nineteenth") )
152
153(define format:ordinal-tens-list
154  '#(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth"
155                                "seventieth" "eightieth" "ninetieth") )
156
157;; roman numerals (from dorai@cs.rice.edu).
158
159(define format:roman-alist
160  '((1000 #\M) (500 #\D) (100 #\C) (50 #\L) (10 #\X) (5 #\V) (1 #\I)))
161
162(define format:roman-boundary-values
163  '(100 100 10 10 1 1 #f))
164
165;; globals
166
167(define format:port #f)         ; curr. format output port
168(define format:output-col 0)    ; curr. format output tty column
169(define format:flush-output #f) ; flush output at end of formatting
170(define format:case-conversion #f)
171(define format:error-continuation #f)
172(define format:args #f)
173(define format:pos 0)           ; curr. format string parsing position
174(define format:arg-pos 0)       ; curr. format argument position
175                                ; this is global for error presentation
176(define format:read-proof #f)   ; resulting string is additionally set into string quotes
177
178;;
179
180(define (format:list-head l k)
181  (if (fx= k 0)
182                '()
183                (cons (car l) (format:list-head (cdr l) (- k 1)))))
184
185;; Aborts the program when a formatting error occures. This is a null
186;; argument closure to jump to the interpreters toplevel continuation.
187
188(define (format:abort) (##sys#error "error in format"))
189
190;; error handler
191
192(define (format:error . args)           ; never returns!
193  (let ((error-continuation format:error-continuation)
194        (format-args format:args)
195        (port (current-error-port)))
196    (set! format:error format:intern-error)
197    (if (and (>= (length format:args) 2)
198             (string? (cadr format:args)))
199                        (let ((format-string (cadr format-args)))
200                                (unless (zero? format:arg-pos)
201                                        (set! format:arg-pos (- format:arg-pos 1)))
202                                (format port "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~
203                                                                                                                                ~{~a ~}===>~{~a ~})~%        "
204                                        (car format:args)
205                                        (substring format-string 0 format:pos)
206                                        (substring format-string format:pos
207                                                (string-length format-string))
208                                        (format:list-head (cddr format:args) format:arg-pos)
209                                        (list-tail (cddr format:args) format:arg-pos)))
210                        (format port
211                                "~%FORMAT: error with call: (format~{ ~a~})~%        "
212                                format:args))
213    (apply format port args)
214    (newline port)
215    (set! format:error format:error-save)
216    (set! format:error-continuation error-continuation)
217    (format:abort)
218    (format:intern-error "format:abort does not jump to toplevel!")))
219
220(define format:error-save format:error)
221
222(define (format:intern-error . args)   ;if something goes wrong in format:error
223  (display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline)
224  (display "        format args: ") (write format:args) (newline)
225  (display "        error args:  ") (write args) (newline)
226  (set! format:error format:error-save)
227  (format:abort))
228
229;; format string and char output routines on format:port
230
231(define (format:out-str str)
232        (if format:case-conversion
233                (display (format:case-conversion str) format:port)
234                (display str format:port))
235        (set! format:output-col (fx+ format:output-col (string-length str))))
236
237(define (format:out-char ch)
238        (if format:case-conversion
239                (display (format:case-conversion (string ch)) format:port)
240                (write-char ch format:port))
241        (set! format:output-col
242                (if (char=? ch #\newline) 0 (fx+ format:output-col 1))))
243
244(define (format:out-substr str i n)
245        (do ((k i (fx+ k 1)))
246                        ((fx= k n))
247                (write-char (string-ref str k) format:port))
248        (set! format:output-col (fx+ format:output-col n)))
249
250(define (format:out-fill n ch)
251        (do ((i 0 (fx+ i 1)))
252                        ((fx= i n))
253                (write-char ch format:port))
254        (set! format:output-col (fx+ format:output-col n)))
255
256;;
257
258(define (format:par pars length index default name)
259  (if (fx> length index)
260                (let ((par (list-ref pars index)))
261                        (if par
262                                (if name
263                                        (if (fx< par 0)
264                                                (error name "parameter must be a positive integer")
265                                                par)
266                                        par)
267                                default))
268                default))
269
270(define (format:out-obj-padded pad-left obj slashify pars)
271        (if (null? pars)
272                (format:out-str (format:obj->str obj slashify))
273                (let ((l (length pars)))
274                        (let ((mincol (format:par pars l 0 0 "mincol"))
275                                                (colinc (format:par pars l 1 1 "colinc"))
276                                                (minpad (format:par pars l 2 0 "minpad"))
277                                                (padchar (integer->char
278                                                                                        (format:par pars l 3 format:space-ch #f)))
279                                                (objstr (format:obj->str obj slashify)))
280                                (unless pad-left
281                                        (format:out-str objstr))
282                                (do ((objstr-len (string-length objstr))
283                                                 (i minpad (fx+ i colinc)))
284                                                ((fx>= (fx+ objstr-len i) mincol)
285                                                 (format:out-fill i padchar)))
286                                (when pad-left
287                                        (format:out-str objstr))))))
288
289(define (format:out-num-padded modifier number pars radix)
290        (unless (integer? number)
291          (set! number (inexact->exact (truncate number)))
292          #;(format:error "argument not an integer" number))
293        (let ((numstr (number->string number radix)))
294                (when (and format:radix-pref (not (fx= radix 10)))
295                        (set! numstr (substring numstr 2 (string-length numstr))))
296                (if (and (null? pars) (not modifier))
297                        (format:out-str numstr)
298                        (let ((l (length pars))
299                                                (numstr-len (string-length numstr)))
300                                (let ((mincol (format:par pars l 0 #f "mincol"))
301                                                        (padchar (integer->char
302                                                                                                (format:par pars l 1 format:space-ch #f)))
303                                                        (commachar (integer->char
304                                                                                                        (format:par pars l 2 (char->integer #\,) #f)))
305                                                        (commawidth (format:par pars l 3 3 "commawidth")))
306                                        (if mincol
307                                                (let ((numlen numstr-len)) ; calc. the output len of number
308                                                        (when (and (memq modifier '(at colon-at)) (positive? number))
309                                                                (set! numlen (fx+ numlen 1)))
310                                                        (when (memq modifier '(colon colon-at))
311                                                                (set! numlen
312                                                                        (fx+ numlen
313                                                                                (fx/ (fx- numstr-len (if (negative? number) 2 1))
314                                                                                        commawidth))))
315                                                        (when (fx> mincol numlen)
316                                                                (format:out-fill (fx- mincol numlen) padchar))))
317                                        (if (and (memq modifier '(at colon-at))
318                                                                         (positive? number))
319                                                        (format:out-char #\+))
320                                        (if (memq modifier '(colon colon-at)) ; insert comma character
321                                                        (let ((start (fxmod numstr-len commawidth))
322                                                                                (ns (if (negative? number) 1 0)))
323                                                                (format:out-substr numstr 0 start)
324                                                                (do ((i start (fx+ i commawidth)))
325                                                                                ((fx>= i numstr-len))
326                                                                        (if (fx> i ns)
327                                                                                        (format:out-char commachar))
328                                                                        (format:out-substr numstr i (fx+ i commawidth))))
329                                                        (format:out-str numstr)))))))
330
331(define (format:tabulate modifier pars)
332        (let ((l (length pars)))
333                (let ((colnum (format:par pars l 0 1 "colnum"))
334                                        (colinc (format:par pars l 1 1 "colinc"))
335                                        (padch (integer->char (format:par pars l 2 format:space-ch #f))))
336                        (case modifier
337                                ((colon colon-at)
338                                        (format:error "unsupported modifier for ~~t" modifier))
339                                ((at)                         ; relative tabulation
340                                (format:out-fill
341                                        (if (fx= colinc 0)
342                                                colnum                  ; colnum = colrel
343                                                (do ((c 0 (fx+ c colinc))
344                                                                 (col (fx+ format:output-col colnum)))
345                                                                ((fx>= c col)
346                                                                 (fx- c format:output-col))))
347                                        padch))
348                                (else                         ; absolute tabulation
349                                (format:out-fill
350                                        (cond
351                                        ((fx< format:output-col colnum)
352                                                (fx- colnum format:output-col))
353                                        ((fx= colinc 0)
354                                                0)
355                                        (else
356                                                (do ((c colnum (fx+ c colinc)))
357                                                                ((fx>= c format:output-col)
358                                                                 (fx- c format:output-col)))))
359                                        padch))))))
360
361(define (format:num->old-roman n)
362        (if (and (integer? n) (>= n 1))
363                (let loop ((n n)
364                                                         (romans format:roman-alist)
365                                                         (s '()))
366                        (if (null? romans)
367                                (list->string (reverse s))
368                                (let ((roman-val (caar romans))
369                                                        (roman-dgt (cadar romans)))
370                                        (do ((q (quotient n roman-val) (- q 1))
371                                                         (s s (cons roman-dgt s)))
372                                                        ((zero? q)
373                                                         (loop (remainder n roman-val)
374                                                                                 (cdr romans) s))))))
375                (format:error "only positive integers can be romanized")))
376
377(define (format:num->roman n)
378        (if (and (integer? n) (positive? n))
379                (let loop ((n n)
380                                                         (romans format:roman-alist)
381                                                         (boundaries format:roman-boundary-values)
382                                                         (s '()))
383                        (if (null? romans)
384                                (list->string (reverse s))
385                                (let ((roman-val (caar romans))
386                                                        (roman-dgt (cadar romans))
387                                                        (bdry (car boundaries)))
388                                        (let loop2 ((q (quotient n roman-val))
389                                                                                        (r (remainder n roman-val))
390                                                                                        (s s))
391                                                (if (zero? q)
392                                                        (if (and bdry (>= r (- roman-val bdry)))
393                                                                (loop (remainder r bdry) (cdr romans)
394                                                                                        (cdr boundaries)
395                                                                                        (cons roman-dgt (append (cdr (assv bdry romans)) s)))
396                                                                (loop r (cdr romans) (cdr boundaries) s))
397                                                        (loop2 (- q 1) r (cons roman-dgt s)))))))
398                (format:error "only positive integers can be romanized")))
399
400(define (format:num->cardinal999 n)
401                ;;this procedure is inspired by the Bruno Haible's CLisp
402                ;;function format-small-cardinal, which converts numbers
403                ;;in the range 1 to 999, and is used for converting each
404                ;;thousand-block in a larger number
405        (let* ((hundreds (quotient n 100))
406                                 (tens+ones (remainder n 100))
407                                 (tens (quotient tens+ones 10))
408                                 (ones (remainder tens+ones 10)))
409                (append
410                        (if (positive? hundreds)
411                                (append
412                                        (string->list (vector-ref format:cardinal-ones-list hundreds))
413                                        (string->list" hundred")
414                                        (if (> tens+ones 0) '(#\space) '()))
415                                '())
416                        (if (< tens+ones 20)
417                                (if (positive? tens+ones)
418                                        (string->list (vector-ref format:cardinal-ones-list tens+ones))
419                                        '())
420                                (append
421                                        (string->list (vector-ref format:cardinal-tens-list tens))
422                                        (if (positive? ones)
423                                                (cons #\-
424                                                        (string->list (vector-ref format:cardinal-ones-list ones)))
425                                                '()))))))
426
427(define (format:num->cardinal n)
428        (cond
429                ((not (integer? n))
430                        (format:error "only integers can be converted to English cardinals"))
431                ((zero? n) "zero")
432                ((negative? n) (string-append "minus " (format:num->cardinal (- n))))
433                (else
434                        (let ((power3-word-limit (vector-length format:cardinal-thousand-block-list)))
435                                (let loop ((n n)
436                                                                         (power3 0)
437                                                                         (s '()))
438                                        (if (zero? n)
439                                                (list->string s)
440                                                (let ((n-before-block (quotient n 1000))
441                                                                        (n-after-block (remainder n 1000)))
442                                                        (loop n-before-block
443                                                                (fx+ power3 1)
444                                                                (if (positive? n-after-block)
445                                                                        (append
446                                                                                (if (positive? n-before-block)
447                                                                                        (string->list ", ")
448                                                                                        '())
449                                                                                (format:num->cardinal999 n-after-block)
450                                                                                (if (fx< power3 power3-word-limit)
451                                                                                        (string->list
452                                                                                                (vector-ref
453                                                                                                        format:cardinal-thousand-block-list
454                                                                                                        power3))
455                                                                                        (append
456                                                                                                (string->list " times ten to the ")
457                                                                                                (string->list (format:num->ordinal (fx* power3 3)))
458                                                                                                (string->list " power")))
459                                                                                s)
460                                                                        s)))))))))
461
462(define (format:num->ordinal n)
463        (cond
464                ((not (integer? n))
465                        (format:error
466                                "only integers can be converted to English ordinals"))
467                ((zero? n) "zeroth")
468                ((negative? n) (string-append "minus " (format:num->ordinal (- n))))
469                (else
470                        (let ((hundreds (quotient n 100))
471                                                (tens+ones (remainder n 100)))
472                                (string-append
473                                        (if (positive? hundreds)
474                                                (string-append
475                                                        (format:num->cardinal (* hundreds 100))
476                                                        (if (zero? tens+ones) "th" " "))
477                                                "")
478                                        (if (zero? tens+ones)
479                                                ""
480                                                (if (< tens+ones 20)
481                                                        (vector-ref format:ordinal-ones-list tens+ones)
482                                                        (let ((tens (quotient tens+ones 10))
483                                                                                (ones (remainder tens+ones 10)))
484                                                                (if (zero? ones)
485                                                                        (vector-ref format:ordinal-tens-list tens)
486                                                                        (string-append
487                                                                                (vector-ref format:cardinal-tens-list tens)
488                                                                                "-"
489                                                                                (vector-ref format:ordinal-ones-list ones)))))))))))
490
491;; format fixed flonums (~F)
492
493(define (format:out-fixed modifier number pars)
494        (unless (or (number? number) (string? number))
495                (format:error "argument is not a number or a number string" number))
496        (let ((l (length pars)))
497                (let ((width (format:par pars l 0 #f "width"))
498                                        (digits (format:par pars l 1 #f "digits"))
499                                        (scale (format:par pars l 2 0 #f))
500                                        (overch (format:par pars l 3 #f #f))
501                                        (padch (format:par pars l 4 format:space-ch #f)))
502
503                        (if digits
504
505                                (begin                      ; fixed precision
506                                        (format:parse-float
507                                        (if (string? number) number (number->string number)) #t scale)
508                                        (if (fx<= (fx- format:fn-len format:fn-dot) digits)
509                                                (format:fn-zfill #f (fx- digits (fx- format:fn-len format:fn-dot)))
510                                                (format:fn-round digits))
511                                        (if width
512                                                (let ((numlen (fx+ format:fn-len 1)))
513                                                        (when (or (not format:fn-pos?) (eq? modifier 'at))
514                                                                (set! numlen (fx+ numlen 1)))
515                                                        (when (and (fx= format:fn-dot 0) (fx> width (fx+ digits 1)))
516                                                                (set! numlen (fx+ numlen 1)))
517                                                        (when (fx< numlen width)
518                                                                (format:out-fill (fx- width numlen) (integer->char padch)))
519                                                        (if (and overch (fx> numlen width))
520                                                                (format:out-fill width (integer->char overch))
521                                                                (format:fn-out modifier (fx> width (fx+ digits 1)))))
522                                                (format:fn-out modifier #t)))
523
524                                (begin                      ; free precision
525                                        (format:parse-float
526                                        (if (string? number) number (number->string number)) #t scale)
527                                        (format:fn-strip)
528                                        (if width
529                                                (let ((numlen (fx+ format:fn-len 1)))
530                                                        (when (or (not format:fn-pos?) (eq? modifier 'at))
531                                                                (set! numlen (fx+ numlen 1)))
532                                                        (when (fx= format:fn-dot 0)
533                                                                (set! numlen (fx+ numlen 1)))
534                                                        (when (fx< numlen width)
535                                                                (format:out-fill (fx- width numlen) (integer->char padch)))
536                                                        (if (fx> numlen width) ; adjust precision if possible
537                                                                (let ((dot-index (fx- numlen
538                                                                                                                                                (fx- format:fn-len format:fn-dot))))
539                                                                        (if (fx> dot-index width)
540                                                                                (if overch ; numstr too big for required width
541                                                                                        (format:out-fill width (integer->char overch))
542                                                                                        (format:fn-out modifier #t))
543                                                                                (begin
544                                                                                        (format:fn-round (fx- width dot-index))
545                                                                                        (format:fn-out modifier #t))))
546                                                                (format:fn-out modifier #t)))
547                                                (format:fn-out modifier #t)))))))
548
549;; format exponential flonums (~E)
550
551(define (format:out-expon modifier number pars)
552        (unless (or (number? number) (string? number))
553                (format:error "argument is not a number" number))
554        (let ((l (length pars)))
555                (let ((width (format:par pars l 0 #f "width"))
556                                        (digits (format:par pars l 1 #f "digits"))
557                                        (edigits (format:par pars l 2 #f "exponent digits"))
558                                        (scale (format:par pars l 3 1 #f))
559                                        (overch (format:par pars l 4 #f #f))
560                                        (padch (format:par pars l 5 format:space-ch #f))
561                                        (expch (format:par pars l 6 #f #f)))
562
563                        (if digits                      ; fixed precision
564
565                                (let ((digits (if (fx> scale 0)
566                                                                                                (if (fx< scale (fx+ digits 2))
567                                                                                                        (fx+ (fx- digits scale) 1)
568                                                                                                        0)
569                                                                                                digits)))
570                                        (format:parse-float
571                                                (if (string? number) number (number->string number)) #f scale)
572                                        (if (fx<= (fx- format:fn-len format:fn-dot) digits)
573                                                (format:fn-zfill #f (fx- digits (fx- format:fn-len format:fn-dot)))
574                                                (format:fn-round digits))
575                                        (if width
576                                                (if (and edigits overch (fx> format:en-len edigits))
577                                                        (format:out-fill width (integer->char overch))
578                                                        (let ((numlen (fx+ format:fn-len 3)) ; .E+
579                                                                                                (leading-0 #f))
580                                                                (when (or (not format:fn-pos?) (eq? modifier 'at))
581                                                                        (set! numlen (fx+ numlen 1)))
582                                                                (when (and (fx= format:fn-dot 0) (fx> width (fx+ digits 1)))
583                                                                        (begin (set! leading-0 #t) (set! numlen (fx+ numlen 1))))
584                                                                (set! numlen
585                                                                        (fx+ numlen
586                                                                                (if (and edigits (fx>= edigits format:en-len))
587                                                                                        edigits
588                                                                                        format:en-len)))
589                                                                (when (fx< numlen width)
590                                                                        (format:out-fill (fx- width numlen) (integer->char padch)))
591                                                                (if (and overch (fx> numlen width) (not leading-0))
592                                                                        (format:out-fill width (integer->char overch))
593                                                                        (begin
594                                                                                (format:fn-out modifier (fx> width (fx- numlen 1)))
595                                                                                (format:en-out edigits expch)))))
596                                                (begin
597                                                        (format:fn-out modifier #t)
598                                                        (format:en-out edigits expch))))
599
600                                (begin                      ; free precision
601                                        (format:parse-float
602                                        (if (string? number) number (number->string number)) #f scale)
603                                        (format:fn-strip)
604                                        (if width
605                                                (if (and edigits overch (fx> format:en-len edigits))
606                                                        (format:out-fill width (integer->char overch))
607                                                        (let ((numlen (fx+ format:fn-len 3))) ; .E+
608                                                                (when (or (not format:fn-pos?) (eq? modifier 'at))
609                                                                        (set! numlen (fx+ numlen 1)))
610                                                                (when (fx= format:fn-dot 0) ; leading 0
611                                                                        (set! numlen (fx+ numlen 1)))
612                                                                (set! numlen
613                                                                        (fx+ numlen
614                                                                                (if (and edigits (fx>= edigits format:en-len))
615                                                                                        edigits
616                                                                                        format:en-len)))
617                                                                (when (fx< numlen width)
618                                                                        (format:out-fill (fx- width numlen) (integer->char padch)))
619                                                                (if (fx> numlen width) ; adjust precision if possible
620                                                                        (let ((f (fx- format:fn-len format:fn-dot))) ; fract len
621                                                                                (if (fx> (fx- numlen f) width)
622                                                                                        (if overch ; numstr too big for required width
623                                                                                                (format:out-fill width (integer->char overch))
624                                                                                                (begin
625                                                                                                        (format:fn-out modifier #t)
626                                                                                                        (format:en-out edigits expch)))
627                                                                                        (begin
628                                                                                                (format:fn-round (fx+ (fx- f numlen) width))
629                                                                                                (format:fn-out modifier #t)
630                                                                                                (format:en-out edigits expch))))
631                                                                        (begin
632                                                                                (format:fn-out modifier #t)
633                                                                                (format:en-out edigits expch)))))
634                                                (begin
635                                                        (format:fn-out modifier #t)
636                                                        (format:en-out edigits expch))))))))
637
638;; format general flonums (~G)
639
640(define (format:out-general modifier number pars)
641        (unless (or (number? number) (string? number))
642                (format:error "argument is not a number or a number string" number))
643        (let ((l (length pars)))
644                (let ((width (if (fx> l 0) (list-ref pars 0) #f))
645                                        (digits (if (fx> l 1) (list-ref pars 1) #f))
646                                        (edigits (if (fx> l 2) (list-ref pars 2) #f))
647                                        (overch (if (fx> l 4) (list-ref pars 4) #f))
648                                        (padch (if (fx> l 5) (list-ref pars 5) #f)))
649                        (format:parse-float
650                        (if (string? number) number (number->string number)) #t 0)
651                        (format:fn-strip)
652                        (let* ((ee (if edigits (fx+ edigits 2) 4)) ; for the following algorithm
653                                                 (ww (if width (fx- width ee) #f)) ; see Steele's CL book p.395
654                                                 (n (if (fx= format:fn-dot 0) ; number less than (abs 1.0) ?
655                                                                        (fxneg (format:fn-zlead))
656                                                                        format:fn-dot))
657                                                 (d (if digits
658                                                                        digits
659                                                                        (fxmax format:fn-len (fxmin n 7)))) ; q = format:fn-len
660                                                 (dd (fx- d n)))
661                                (if (and (fx<= 0 dd) (fx<= dd d))
662                                        (begin
663                                                (format:out-fixed modifier number (list ww dd #f overch padch))
664                                                (format:out-fill ee #\space)) ;~@T not implemented yet
665                                        (format:out-expon modifier number pars))))))
666
667;; format dollar flonums (~$)
668
669(define (format:out-dollar modifier number pars)
670        (unless (or (number? number) (string? number))
671                (format:error "argument is not a number or a number string" number))
672        (let ((l (length pars)))
673                (let ((digits (format:par pars l 0 2 "digits"))
674                                        (mindig (format:par pars l 1 1 "mindig"))
675                                        (width (format:par pars l 2 0 "width"))
676                                        (padch (format:par pars l 3 format:space-ch #f)))
677
678                        (format:parse-float
679                        (if (string? number) number (number->string number)) #t 0)
680                        (if (fx<= (fx- format:fn-len format:fn-dot) digits)
681                                (format:fn-zfill #f (fx- digits (fx- format:fn-len format:fn-dot)))
682                                (format:fn-round digits))
683                        (let ((numlen (fx+ format:fn-len 1)))
684                                (when (or (not format:fn-pos?) (memq modifier '(at colon-at)))
685                                        (set! numlen (fx+ numlen 1)))
686                                (when (and mindig (fx> mindig format:fn-dot))
687                                        (set! numlen (fx+ numlen (fx- mindig format:fn-dot))))
688                                (when (and (fx= format:fn-dot 0) (not mindig))
689                                        (set! numlen (fx+ numlen 1)))
690                                (if (fx< numlen width)
691                                        (case modifier
692                                                ((colon)
693                                                        (if (not format:fn-pos?)
694                                                                        (format:out-char #\-))
695                                                        (format:out-fill (fx- width numlen) (integer->char padch)))
696                                                ((at)
697                                                        (format:out-fill (fx- width numlen) (integer->char padch))
698                                                        (format:out-char (if format:fn-pos? #\+ #\-)))
699                                                ((colon-at)
700                                                        (format:out-char (if format:fn-pos? #\+ #\-))
701                                                        (format:out-fill (fx- width numlen) (integer->char padch)))
702                                                (else
703                                                        (format:out-fill (fx- width numlen) (integer->char padch))
704                                                        (unless format:fn-pos?
705                                                                (format:out-char #\-))))
706                                        (if format:fn-pos?
707                                                (if (memq modifier '(at colon-at)) (format:out-char #\+))
708                                                (format:out-char #\-))))
709                        (when (and mindig (fx> mindig format:fn-dot))
710                                (format:out-fill (fx- mindig format:fn-dot) #\0))
711                        (when (and (fx= format:fn-dot 0) (not mindig))
712                                (format:out-char #\0))
713                        (format:out-substr format:fn-str 0 format:fn-dot)
714                        (format:out-char #\.)
715                        (format:out-substr format:fn-str format:fn-dot format:fn-len))))
716
717;; the flonum buffers
718
719(define format:fn-str (make-string format:fn-max)) ; number buffer
720(define format:fn-len 0)                ; digit length of number
721(define format:fn-dot #f)               ; dot position of number
722(define format:fn-pos? #t)              ; number positive?
723(define format:en-str (make-string format:en-max)) ; exponent buffer
724(define format:en-len 0)                ; digit length of exponent
725(define format:en-pos? #t)              ; exponent positive?
726
727(define (format:parse-float num-str fixed? scale)
728        (set! format:fn-pos? #t)
729        (set! format:fn-len 0)
730        (set! format:fn-dot #f)
731        (set! format:en-pos? #t)
732        (set! format:en-len 0)
733        (do ((i 0 (fx+ i 1))
734                         (left-zeros 0)
735                         (mantissa? #t)
736                         (all-zeros? #t)
737                         (num-len (string-length num-str))
738                         (c #f))                  ; current exam. character in num-str
739                        ((fx= i num-len)
740                         (unless format:fn-dot
741                                 (set! format:fn-dot format:fn-len))
742
743                         (when all-zeros?
744                                 (set! left-zeros 0)
745                                 (set! format:fn-dot 0)
746                                 (set! format:fn-len 1))
747
748                         ;; now format the parsed values according to format's need
749                         (if fixed?
750
751                                 (begin                     ; fixed format m.nnn or .nnn
752                                         (when (and (fx> left-zeros 0) (fx> format:fn-dot 0))
753                                                 (if (fx> format:fn-dot left-zeros)
754                                                         (begin           ; norm 0{0}nn.mm to nn.mm
755                                                                 (format:fn-shiftleft left-zeros)
756                                                                 (set! left-zeros 0)
757                                                                 (set! format:fn-dot (fx- format:fn-dot left-zeros)))
758                                                         (begin           ; normalize 0{0}.nnn to .nnn
759                                                                 (format:fn-shiftleft format:fn-dot)
760                                                                 (set! left-zeros (fx- left-zeros format:fn-dot))
761                                                                 (set! format:fn-dot 0))))
762                                         (when (or (not (fx= scale 0)) (fx> format:en-len 0))
763                                                 (let ((shift (fx+ scale (format:en-int))))
764                                                         (cond
765                                                                (all-zeros? #t)
766                                                                ((fx> (fx+ format:fn-dot shift) format:fn-len)
767                                                                 (format:fn-zfill
768                                                                        #f (fx- shift (fx- format:fn-len format:fn-dot)))
769                                                                 (set! format:fn-dot format:fn-len))
770                                                                ((fx< (fx+ format:fn-dot shift) 0)
771                                                                 (format:fn-zfill #t (fx- (fxneg shift) format:fn-dot))
772                                                                 (set! format:fn-dot 0))
773                                                                (else
774                                                                 (if (fx> left-zeros 0)
775                                                                         (if (fx<= left-zeros shift) ; shift always > 0 here
776                                                                                 (format:fn-shiftleft shift) ; shift out 0s
777                                                                                 (begin
778                                                                                         (format:fn-shiftleft (fx- left-zeros shift))
779                                                                                         (set! format:fn-dot (fxmax 0 (fx- shift left-zeros)))))
780                                                                         (set! format:fn-dot (fx+ format:fn-dot shift))))))))
781
782                                 (let ((negexp              ; expon format m.nnnEee
783                                                                (if (fx> left-zeros 0)
784                                                                        (fx+ (fx- left-zeros format:fn-dot) 1)
785                                                                        (if (fx= format:fn-dot 0) 1 0))))
786                                         (if (fx> left-zeros 0)
787                                                 (begin               ; normalize 0{0}.nnn to n.nn
788                                                         (format:fn-shiftleft left-zeros)
789                                                         (set! format:fn-dot 1))
790                                                 (when (fx= format:fn-dot 0)
791                                                         (set! format:fn-dot 1)))
792                                         (format:en-set (fx- (fx+ (fx- format:fn-dot scale) (format:en-int)) negexp))
793                                         (cond
794                                                (all-zeros?
795                                                 (format:en-set 0)
796                                                 (set! format:fn-dot 1))
797                                                ((fx< scale 0)          ; leading zero
798                                                 (format:fn-zfill #t (fxneg scale))
799                                                 (set! format:fn-dot 0))
800                                                ((fx> scale format:fn-dot)
801                                                 (format:fn-zfill #f (fx- scale format:fn-dot))
802                                                 (set! format:fn-dot scale))
803                                                (else
804                                                 (set! format:fn-dot scale)))))
805                         #t)
806
807                ;; do body
808                (set! c (string-ref num-str i)) ; parse the output of number->string
809                (cond                            ; which can be any valid number
810                 ((char-numeric? c)              ; representation of R4RS except
811                        (if mantissa?                   ; complex numbers
812                                (begin
813                                        (if (char=? c #\0)
814                                                (when all-zeros?
815                                                        (set! left-zeros (fx+ left-zeros 1)))
816                                                (set! all-zeros? #f))
817                                        (string-set! format:fn-str format:fn-len c)
818                                        (set! format:fn-len (fx+ format:fn-len 1)))
819                                (begin
820                                        (string-set! format:en-str format:en-len c)
821                                        (set! format:en-len (fx+ format:en-len 1)))))
822                 ((or (char=? c #\-) (char=? c #\+))
823                        (if mantissa?
824                                (set! format:fn-pos? (char=? c #\+))
825                                (set! format:en-pos? (char=? c #\+))))
826                 ((char=? c #\.)
827                        (set! format:fn-dot format:fn-len))
828                 ((char=? c #\e)
829                        (set! mantissa? #f))
830                 ((char=? c #\E)
831                        (set! mantissa? #f))
832                 ((char-whitespace? c) #t)
833                 ((char=? c #\d) #t)              ; decimal radix prefix
834                 ((char=? c #\#) #t)
835                 (else
836                        (format:error "illegal character in number->string" c)))))
837
838(define (format:en-int)   ; convert exponent string to integer
839        (if (fx= format:en-len 0)
840                0
841                (do ((i 0 (fx+ i 1))
842                                 (n 0))
843                                ((fx= i format:en-len)
844                                 (if format:en-pos? n (fxneg n)))
845                        (set! n
846                                (fx+ (fx* n 10)
847                                        (fx- (char->integer (string-ref format:en-str i))
848                                                format:zero-ch))))))
849
850(define (format:en-set en)              ; set exponent string number
851        (set! format:en-len 0)
852        (set! format:en-pos? (fx>= en 0))
853        (let ((en-str (number->string en)))
854                (do ((i 0 (fx+ i 1))
855                                 (en-len (string-length en-str))
856                                 (c #f))
857                                ((fx= i en-len))
858                        (set! c (string-ref en-str i))
859                        (when (char-numeric? c)
860                                (string-set! format:en-str format:en-len c)
861                                (set! format:en-len (fx+ format:en-len 1))))))
862
863(define (format:fn-zfill left? n) ; fill current number string with 0s
864        (when (fx> (fx+ n format:fn-len) format:fn-max) ; from the left or right
865                (format:error "number is too long to format (enlarge format:fn-max)"))
866        (set! format:fn-len (fx+ format:fn-len n))
867        (if left?
868                (do ((i format:fn-len (fx- i 1)))       ; fill n 0s to left
869                                ((fx< i 0))
870                        (string-set! format:fn-str i
871                                (if (fx< i n)
872                                        #\0
873                                        (string-ref format:fn-str (fx- i n)))))
874                (do ((i (fx- format:fn-len n) (fx+ i 1))) ; fill n 0s to the right
875                                ((fx= i format:fn-len))
876                        (string-set! format:fn-str i #\0))))
877
878(define (format:fn-shiftleft n) ; shift left current number n positions
879        (when (fx> n format:fn-len)
880                (format:error "internal error in format:fn-shiftleft"
881                        (list n format:fn-len)))
882        (do ((i n (fx+ i 1)))
883                        ((fx= i format:fn-len)
884                         (set! format:fn-len (fx- format:fn-len n)))
885                (string-set! format:fn-str (fx- i n) (string-ref format:fn-str i))))
886
887(define (format:fn-round digits)        ; round format:fn-str
888        (set! digits (fx+ digits format:fn-dot))
889        (do ((i digits (fx- i 1))           ; "099",2 -> "10"
890                         (c 5))                         ; "023",2 -> "02"
891                        ((or (fx= c 0) (fx< i 0))               ; "999",2 -> "100"
892                         (if (fx= c 1)                  ; "005",2 -> "01"
893                                 (begin                                 ; carry overflow
894                                         (set! format:fn-len digits)
895                                         (format:fn-zfill #t 1)   ; add a 1 before fn-str
896                                         (string-set! format:fn-str 0 #\1)
897                                         (set! format:fn-dot (fx+ format:fn-dot 1)))
898                                 (set! format:fn-len digits)))
899                (set! c
900                        (fx+ c
901                                (fx- (char->integer (string-ref format:fn-str i)) format:zero-ch)))
902                (string-set! format:fn-str i
903                        (integer->char
904                                (if (fx< c 10)
905                                        (fx+ c format:zero-ch)
906                                        (fx+ (fx- c 10) format:zero-ch))))
907                (set! c (if (fx< c 10) 0 1))))
908
909(define (format:fn-out modifier add-leading-zero?)
910        (if format:fn-pos?
911                (when (eq? modifier 'at)
912                        (format:out-char #\+))
913                (format:out-char #\-))
914        (if (fx= format:fn-dot 0)
915                (when add-leading-zero?
916                        (format:out-char #\0))
917                (format:out-substr format:fn-str 0 format:fn-dot))
918        (format:out-char #\.)
919        (format:out-substr format:fn-str format:fn-dot format:fn-len))
920
921(define (format:en-out edigits expch)
922        (format:out-char (if expch (integer->char expch) format:expch))
923        (format:out-char (if format:en-pos? #\+ #\-))
924        (when (and edigits (fx< format:en-len edigits))
925                (format:out-fill (fx- edigits format:en-len) #\0))
926        (format:out-substr format:en-str 0 format:en-len))
927
928(define (format:fn-strip)               ; strip trailing zeros but one
929        (string-set! format:fn-str format:fn-len #\0)
930        (do ((i format:fn-len (fx- i 1)))
931                        ((or (not (char=? (string-ref format:fn-str i) #\0))
932                                         (fx<= i format:fn-dot))
933                         (set! format:fn-len (fx+ i 1)))))
934
935(define (format:fn-zlead)               ; count leading zeros
936        (do ((i 0 (fx+ i 1)))
937                        ((or (fx= i format:fn-len)
938                                         (not (char=? (string-ref format:fn-str i) #\0)))
939                         (if (fx= i format:fn-len)      ; found a real zero
940                                 0
941                                 i))))
942
943;; format:char->str converts a character into a slashified string as
944;; done by `write'. The procedure is dependent on the integer
945;; representation of characters and assumes a character number
946;; according to the ASCII character set.
947
948(define (format:char->str ch)
949  (let ((int-rep (char->integer ch)))
950    (if (fx< int-rep 0)                 ; if chars are [-128...+127]
951        (set! int-rep (fx+ int-rep 256)))
952    (string-append
953     "#\\"
954     (cond
955      ((char=? ch #\newline) "newline")
956      ((and (fx>= int-rep 0) (fx<= int-rep 32))
957       (vector-ref format:ascii-non-printable-charnames int-rep))
958      ((fx= int-rep 127) "del")
959      ((fx>= int-rep 128)                       ; octal representation
960       (if format:radix-pref
961           (let ((s (number->string int-rep 8)))
962             (substring s 2 (string-length s)))
963           (number->string int-rep 8)))
964      (else (string ch))))))
965
966;; format:iobj->str reveals the implementation dependent
967;; representation of #<...> objects with the use of display and
968;; call-with-output-string.
969
970(define (format:iobj->str iobj format:read-proof)
971  (if (or format:read-proof
972          format:iobj-case-conv)
973                (string-append
974                        (if format:read-proof "\"" "")
975                        (if format:iobj-case-conv
976                                (format:iobj-case-conv
977                                        (call-with-output-string (lambda (p) (display iobj p))))
978                                (call-with-output-string (lambda (p) (display iobj p))))
979                        (if format:read-proof "\"" ""))
980                (call-with-output-string (lambda (p) (display iobj p)))))
981
982;; format:obj->str returns a R4RS representation as a string of an
983;; arbitrary scheme object.
984;;
985;; First parameter is the object, second parameter is a boolean if
986;; the representation should be slashified as `write' does.
987;;
988;; It uses format:char->str which converts a character into a
989;; slashified string as `write' does and which is implementation
990;; dependent.
991;;
992;; It uses format:iobj->str to print out internal objects as quoted
993;; strings so that the output can always be processed by (read)
994
995(define (format:obj->str obj slashify)
996  (cond
997   ((string? obj)
998                (if slashify
999                        (let ((obj-len (string-length obj)))
1000                                (string-append
1001                                "\""
1002                                (let loop ((i 0) (j 0))   ; taken from Marc Feeley's pp.scm
1003                                        (if (fx= j obj-len)
1004                                                (string-append (substring obj i j) "\"")
1005                                                (let ((c (string-ref obj j)))
1006                                                        (if (or (char=? c #\\)
1007                                                                                        (char=? c #\"))
1008                                                                (string-append (substring obj i j) "\\"
1009                                                                                                                                (loop j (fx+ j 1)))
1010                                                                (loop i (fx+ j 1))))))))
1011                        obj))
1012
1013   ((boolean? obj) (if obj "#t" "#f"))
1014
1015   ((number? obj) (number->string obj))
1016
1017   ((symbol? obj)
1018                (if format:symbol-case-conv
1019                        (format:symbol-case-conv (symbol->string obj))
1020                        (symbol->string obj)))
1021
1022   ((char? obj)
1023                (if slashify
1024                        (format:char->str obj)
1025                        (string obj)))
1026
1027   ((null? obj) "()")
1028
1029   ((input-port? obj)
1030    (format:iobj->str obj format:read-proof))
1031
1032   ((output-port? obj)
1033    (format:iobj->str obj format:read-proof))
1034
1035   ((list? obj)
1036                (string-append
1037                        "("
1038                        (let loop ((obj-list obj))
1039                                (if (null? (cdr obj-list))
1040                                        (format:obj->str (car obj-list) #t)
1041                                        (string-append
1042                                                (format:obj->str (car obj-list) #t)
1043                                                " "
1044                                                (loop (cdr obj-list)))))
1045                        ")"))
1046
1047                ((pair? obj)
1048                        (string-append
1049                                "("
1050                                (format:obj->str (car obj) #t)
1051                                " . "
1052                                (format:obj->str (cdr obj) #t)
1053                                ")"))
1054
1055   ((vector? obj)
1056                (string-append "#" (format:obj->str (vector->list obj) #t)))
1057
1058   (else                                ; only objects with an #<...>
1059    (format:iobj->str obj format:read-proof))))
1060                                        ; representation should fall in here
1061
1062;;
1063
1064(define (format:string-capitalize-first str) ; "hello" -> "Hello"
1065  (let ((cap-str (string-copy str))     ; "hELLO" -> "Hello"
1066        (non-first-alpha #f)            ; "*hello" -> "*Hello"
1067        (str-len (string-length str)))  ; "hello you" -> "Hello you"
1068    (do ((i 0 (fx+ i 1)))
1069        ((fx= i str-len) cap-str)
1070      (let ((c (string-ref str i)))
1071        (if (char-alphabetic? c)
1072                                        (if non-first-alpha
1073                                                (string-set! cap-str i (char-downcase c))
1074                                                (begin
1075                                                        (set! non-first-alpha #t)
1076                                                        (string-set! cap-str i (char-upcase c)))))))))
1077;;
1078
1079(define (format:format-work format-string arglist) ; does the formatting work
1080        (letrec (
1081                        (format-string-len (string-length format-string))
1082                        (arg-pos 0)                    ; argument position in arglist
1083                        (arg-len (length arglist))     ; number of arguments
1084                        (modifier #f)                                                                   ; 'colon | 'at | 'colon-at | #f
1085                        (params '())                   ; directive parameter list
1086                        (param-value-found #f)                                  ; a directive parameter value found
1087                        (conditional-nest 0)           ; conditional nesting level
1088                        (clause-pos 0)                                                                  ; last cond. clause beginning char pos
1089                        (clause-default #f)                                             ; conditional default clause string
1090                        (clauses '())                                                                   ; conditional clause string list
1091                        (conditional-type #f)                                   ; reflects the contional modifiers
1092                        (conditional-arg #f)                                            ; argument to apply the conditional
1093                        (iteration-nest 0)             ; iteration nesting level
1094                        (iteration-pos 0)                                                       ; iteration string beginning char pos
1095                        (iteration-type #f)                                             ; reflects the iteration modifiers
1096                        (max-iterations #f)            ; maximum number of iterations
1097                        (recursive-pos-save format:pos)
1098
1099                        (next-char                                                                                      ; gets the next char from format-string
1100                                (lambda ()
1101                                        (let ((ch (peek-next-char)))
1102                                                (set! format:pos (fx+ 1 format:pos))
1103                                                ch)))
1104
1105                        (peek-next-char
1106                                (lambda ()
1107                                        (if (fx>= format:pos format-string-len)
1108                                                        (format:error "illegal format string")
1109                                                        (string-ref format-string format:pos))))
1110
1111                        (one-positive-integer?
1112                                (lambda (params)
1113                                        (cond
1114                                        ((null? params) #f)
1115                                        ((and (fixnum? (car params))
1116                                                                (fx>= (car params) 0)
1117                                                                (fx= (length params) 1)) #t)
1118                                        (else (format:error "one positive integer parameter expected")))))
1119
1120                        (next-arg
1121                                (lambda ()
1122                                        (if (fx>= arg-pos arg-len)
1123                                                        (begin
1124                                                                (set! format:arg-pos (+ arg-len 1))
1125                                                                (format:error "missing argument(s)")))
1126                                        (add-arg-pos 1)
1127                                        (list-ref arglist (fx- arg-pos 1))))
1128
1129                        (prev-arg
1130                                (lambda ()
1131                                        (add-arg-pos -1)
1132                                        (if (fx< arg-pos 0)
1133                                                        (format:error "missing backward argument(s)"))
1134                                        (list-ref arglist arg-pos)))
1135
1136                        (rest-args
1137                                (lambda ()
1138                                        (let loop ((l arglist) (k arg-pos)) ; list-tail definition
1139                                                (if (fx= k 0) l (loop (cdr l) (fx- k 1))))))
1140
1141                        (add-arg-pos
1142                                (lambda (n)
1143                                        (set! arg-pos (fx+ n arg-pos))
1144                                        (set! format:arg-pos arg-pos)))
1145
1146                        (anychar-dispatch              ; dispatches the format-string
1147                                (lambda ()
1148                                        (if (fx>= format:pos format-string-len)
1149                                                arg-pos                 ; used for ~? continuance
1150                                                (let ((char (next-char)))
1151                                                        (cond
1152                                                        ((char=? char #\~)
1153                                                                (set! modifier #f)
1154                                                                (set! params '())
1155                                                                (set! param-value-found #f)
1156                                                                (tilde-dispatch))
1157                                                        (else
1158                                                                (when (and (fx= 0 conditional-nest) (fx= 0 iteration-nest))
1159                                                                        (format:out-char char))
1160                                                                (anychar-dispatch)))))))
1161
1162                        (tilde-dispatch
1163                                (lambda ()
1164                                        (cond
1165                                        ((fx>= format:pos format-string-len)
1166                                                (format:out-str "~")                            ; tilde at end of string is just output
1167                                                arg-pos)                        ; used for ~? continuance
1168                                        ((and (or (fx= 0 conditional-nest)
1169                                                                                (memv (peek-next-char)
1170                                                                                                        format:conditional-directives-characters))
1171                                                                (or (fx= 0 iteration-nest)
1172                                                                                (memv (peek-next-char)
1173                                                                                                        format:iteration-directives-characters)))
1174                                                (case (char-upcase (next-char))
1175
1176                                                        ;; format directives
1177
1178                                                        ((#\A)                  ; Any -- for humans
1179                                                        (set! format:read-proof (memq modifier '(colon colon-at)))
1180                                                        (format:out-obj-padded (memq modifier '(at colon-at))
1181                                                                                                                                                        (next-arg) #f params)
1182                                                        (anychar-dispatch))
1183                                                        ((#\S)                  ; Slashified -- for parsers
1184                                                        (set! format:read-proof (memq modifier '(colon colon-at)))
1185                                                        (format:out-obj-padded (memq modifier '(at colon-at))
1186                                                                                                                                                        (next-arg) #t params)
1187                                                        (anychar-dispatch))
1188                                                        ((#\D)                  ; Decimal
1189                                                        (format:out-num-padded modifier (next-arg) params 10)
1190                                                        (anychar-dispatch))
1191                                                        ((#\X)                  ; Hexadecimal
1192                                                        (format:out-num-padded modifier (next-arg) params 16)
1193                                                        (anychar-dispatch))
1194                                                        ((#\O)                  ; Octal
1195                                                        (format:out-num-padded modifier (next-arg) params 8)
1196                                                        (anychar-dispatch))
1197                                                        ((#\B)                  ; Binary
1198                                                        (format:out-num-padded modifier (next-arg) params 2)
1199                                                        (anychar-dispatch))
1200                                                        ((#\R)
1201                                                        (if (null? params)
1202                                                                (format:out-obj-padded ; Roman, cardinal, ordinal numerals
1203                                                                        #f
1204                                                                        ((case modifier
1205                                                                                ((at) format:num->roman)
1206                                                                                ((colon-at) format:num->old-roman)
1207                                                                                ((colon) format:num->ordinal)
1208                                                                                (else format:num->cardinal))
1209                                                                        (next-arg))
1210                                                                        #f params)
1211                                                                (format:out-num-padded ; any Radix
1212                                                                        modifier (next-arg) (cdr params) (car params)))
1213                                                        (anychar-dispatch))
1214                                                        ((#\F)                  ; Fixed-format floating-point
1215                                                        (if format:floats
1216                                                                (format:out-fixed modifier (next-arg) params)
1217                                                                (format:out-str (number->string (next-arg))))
1218                                                        (anychar-dispatch))
1219                                                        ((#\E)                  ; Exponential floating-point
1220                                                        (if format:floats
1221                                                                (format:out-expon modifier (next-arg) params)
1222                                                                (format:out-str (number->string (next-arg))))
1223                                                        (anychar-dispatch))
1224                                                        ((#\G)                  ; General floating-point
1225                                                        (if format:floats
1226                                                                (format:out-general modifier (next-arg) params)
1227                                                                (format:out-str (number->string (next-arg))))
1228                                                        (anychar-dispatch))
1229                                                        ((#\$)                  ; Dollars floating-point
1230                                                        (if format:floats
1231                                                                (format:out-dollar modifier (next-arg) params)
1232                                                                (format:out-str (number->string (next-arg))))
1233                                                        (anychar-dispatch))
1234                                                        ((#\I)                  ; Complex numbers
1235                                                        (unless format:complex-numbers
1236                                                                (format:error
1237                                                                        "complex numbers not supported by this scheme system"))
1238                                                        (let ((z (next-arg)))
1239                                                                (unless (complex? z)
1240                                                                        (format:error "argument not a complex number"))
1241                                                                (format:out-fixed modifier (real-part z) params)
1242                                                                (format:out-fixed 'at (imag-part z) params)
1243                                                                (format:out-char #\i))
1244                                                        (anychar-dispatch))
1245                                                        ((#\C)                  ; Character
1246                                                        (let ((ch (if (one-positive-integer? params)
1247                                                                                                        (integer->char (car params))
1248                                                                                                        (next-arg))))
1249                                                                (unless (char? ch)
1250                                                                        (format:error "~~c expects a character" ch))
1251                                                                (case modifier
1252                                                                        ((at)
1253                                                                                (format:out-str (format:char->str ch)))
1254                                                                        ((colon)
1255                                                                                (let ((c (char->integer ch)))
1256                                                                                        (when (fx< c 0)
1257                                                                                                (set! c (fx+ c 256)))           ; compensate complement impl.
1258                                                                                        (cond
1259                                                                                        ((fx< c #x20) ; assumes that control chars are < #x20
1260                                                                                                (format:out-char #\^)
1261                                                                                                (format:out-char (integer->char (fx+ c #x40))))
1262                                                                                        ((fx>= c #x7f)
1263                                                                                                (format:out-str "#\\")
1264                                                                                                (format:out-str
1265                                                                                                (if format:radix-pref
1266                                                                                                        (let ((s (number->string c 8)))
1267                                                                                                                (substring s 2 (string-length s)))
1268                                                                                                        (number->string c 8))))
1269                                                                                        (else
1270                                                                                                (format:out-char ch)))))
1271                                                                        (else (format:out-char ch))))
1272                                                        (anychar-dispatch))
1273                                                        ((#\P)                  ; Plural
1274                                                        (when (memq modifier '(colon colon-at))
1275                                                                (prev-arg))
1276                                                        (let ((arg (next-arg)))
1277                                                                (unless (number? arg)
1278                                                                        (format:error "~~p expects a number argument" arg))
1279                                                                (if (fx= arg 1)
1280                                                                        (when (memq modifier '(at colon-at))
1281                                                                                (format:out-char #\y))
1282                                                                        (if (memq modifier '(at colon-at))
1283                                                                                (format:out-str "ies")
1284                                                                                (format:out-char #\s))))
1285                                                        (anychar-dispatch))
1286                                                        ((#\~)                  ; Tilde
1287                                                        (if (one-positive-integer? params)
1288                                                                (format:out-fill (car params) #\~)
1289                                                                (format:out-char #\~))
1290                                                        (anychar-dispatch))
1291                                                        ((#\%)                  ; Newline
1292                                                        (if (one-positive-integer? params)
1293                                                                (format:out-fill (car params) #\newline)
1294                                                                (format:out-char #\newline))
1295                                                        (set! format:output-col 0)
1296                                                        (anychar-dispatch))
1297                                                        ((#\&)                  ; Fresh line
1298                                                        (if (one-positive-integer? params)
1299                                                                (begin
1300                                                                        (when (fx> (car params) 0)
1301                                                                                (format:out-fill
1302                                                                                        (fx- (car params) (if (fx> format:output-col 0) 0 1))
1303                                                                                        #\newline))
1304                                                                        (set! format:output-col 0))
1305                                                                (when (fx> format:output-col 0)
1306                                                                        (format:out-char #\newline)))
1307                                                        (anychar-dispatch))
1308                                                        ((#\_)                  ; Space character
1309                                                        (if (one-positive-integer? params)
1310                                                                (format:out-fill (car params) #\space)
1311                                                                (format:out-char #\space))
1312                                                        (anychar-dispatch))
1313                                                        ((#\/)                  ; Tabulator character
1314                                                        (if (one-positive-integer? params)
1315                                                                (format:out-fill (car params) #\tab)
1316                                                                (format:out-char #\tab))
1317                                                        (anychar-dispatch))
1318                                                        ((#\|)                  ; Page seperator
1319                                                        (if (one-positive-integer? params)
1320                                                                (format:out-fill (car params) #\page)
1321                                                                (format:out-char #\page))
1322                                                        (set! format:output-col 0)
1323                                                        (anychar-dispatch))
1324                                                        ((#\T)                  ; Tabulate
1325                                                        (format:tabulate modifier params)
1326                                                        (anychar-dispatch))
1327                                                        ((#\Y)                  ; Pretty-print
1328                                                        (pretty-print (next-arg) format:port)
1329                                                        (set! format:output-col 0)
1330                                                        (anychar-dispatch))
1331                                                        ((#\? #\K)         ; Indirection (is "~K" in T-Scheme)
1332                                                        (cond
1333                                                                ((memq modifier '(colon colon-at))
1334                                                                (format:error "illegal modifier in ~~?" modifier))
1335                                                                ((eq? modifier 'at)
1336                                                                (let* ((frmt (next-arg))
1337                                                                                                (args (rest-args)))
1338                                                                        (add-arg-pos (format:format-work frmt args))))
1339                                                                (else
1340                                                                (let* ((frmt (next-arg))
1341                                                                                                (args (next-arg)))
1342                                                                        (format:format-work frmt args))))
1343                                                        (anychar-dispatch))
1344                                                        ((#\!)                  ; Flush output
1345                                                        (set! format:flush-output #t)
1346                                                        (anychar-dispatch))
1347                                                        ((#\newline)            ; Continuation lines
1348                                                        (when (eq? modifier 'at)
1349                                                                (format:out-char #\newline))
1350                                                        (when (fx< format:pos format-string-len)
1351                                                                (do ((ch (peek-next-char) (peek-next-char)))
1352                                                                                ((or (not (char-whitespace? ch))
1353                                                                                                        (fx= format:pos (fx- format-string-len 1))))
1354                                                                        (if (eq? modifier 'colon)
1355                                                                                (format:out-char (next-char))
1356                                                                                (next-char))))
1357                                                        (anychar-dispatch))
1358                                                        ((#\*)                  ; Argument jumping
1359                                                        (case modifier
1360                                                                ((colon)             ; jump backwards
1361                                                                        (if (one-positive-integer? params)
1362                                                                                (do ((i 0 (fx+ i 1)))
1363                                                                                                ((fx= i (car params)))
1364                                                                                        (prev-arg))
1365                                                                                (prev-arg)))
1366                                                                ((at)                ; jump absolute
1367                                                                        (set! arg-pos
1368                                                                                (if (one-positive-integer? params) (car params) 0)))
1369                                                                ((colon-at)
1370                                                                        (format:error "illegal modifier `:@' in ~~* directive"))
1371                                                                (else                ; jump forward
1372                                                                        (if (one-positive-integer? params)
1373                                                                                (do ((i 0 (fx+ i 1)))
1374                                                                                                ((fx= i (car params)))
1375                                                                                        (next-arg))
1376                                                                                (next-arg))))
1377                                                        (anychar-dispatch))
1378                                                        ((#\()                  ; Case conversion begin
1379                                                        (set! format:case-conversion
1380                                                                (case modifier
1381                                                                        ((at) format:string-capitalize-first)
1382                                                                        ((colon) string-titlecase)
1383                                                                        ((colon-at) string-upcase)
1384                                                                        (else string-downcase)))
1385                                                        (anychar-dispatch))
1386                                                        ((#\))                  ; Case conversion end
1387                                                        (unless format:case-conversion
1388                                                                (format:error "missing ~~)"))
1389                                                        (set! format:case-conversion #f)
1390                                                        (anychar-dispatch))
1391                                                        ((#\[)                  ; Conditional begin
1392                                                        (set! conditional-nest (fx+ conditional-nest 1))
1393                                                        (cond
1394                                                                ((fx= conditional-nest 1)
1395                                                                (set! clause-pos format:pos)
1396                                                                (set! clause-default #f)
1397                                                                (set! clauses '())
1398                                                                (set! conditional-type
1399                                                                        (case modifier
1400                                                                                ((at) 'if-then)
1401                                                                                ((colon) 'if-else-then)
1402                                                                                ((colon-at) (format:error "illegal modifier in ~~]"))
1403                                                                                (else 'num-case)))
1404                                                                (set! conditional-arg
1405                                                                        (if (one-positive-integer? params)
1406                                                                                (car params)
1407                                                                                (next-arg)))))
1408                                                        (anychar-dispatch))
1409                                                        ((#\;)                  ; Conditional separator
1410                                                        (when (fx= 0 conditional-nest)
1411                                                                (format:error "~~; not in ~~]~~[ conditional"))
1412                                                        (unless (null? params)
1413                                                                (format:error "no parameter allowed in ~~;"))
1414                                                        (when (fx= conditional-nest 1)
1415                                                                (let ((clause-str
1416                                                                                                (cond
1417                                                                                                        ((eq? modifier 'colon)
1418                                                                                                                (set! clause-default #t)
1419                                                                                                                (substring format-string clause-pos
1420                                                                                                                        (fx- format:pos 3)))
1421                                                                                                        ((memq modifier '(at colon-at))
1422                                                                                                                (format:error "illegal modifier in ~~;"))
1423                                                                                                        (else
1424                                                                                                                (substring format-string clause-pos
1425                                                                                                                        (fx- format:pos 2))))))
1426                                                                        (set! clauses (append clauses (list clause-str)))
1427                                                                        (set! clause-pos format:pos)))
1428                                                        (anychar-dispatch))
1429                                                        ((#\])                  ; Conditional end
1430                                                        (when (fx= 0 conditional-nest)
1431                                                                (format:error "missing ~~]"))
1432                                                        (set! conditional-nest (fx- conditional-nest 1))
1433                                                        (when modifier
1434                                                                (format:error "no modifier allowed in ~~["))
1435                                                        (unless (null? params)
1436                                                                (format:error "no parameter allowed in ~~["))
1437                                                        (cond
1438                                                                ((fx= 0 conditional-nest)
1439                                                                (let ((clause-str (substring format-string clause-pos
1440                                                                                                                                                                                        (fx- format:pos 2))))
1441                                                                        (if clause-default
1442                                                                                (set! clause-default clause-str)
1443                                                                                (set! clauses (append clauses (list clause-str)))))
1444                                                                (case conditional-type
1445                                                                        ((if-then)
1446                                                                                (when conditional-arg
1447                                                                                        (format:format-work (car clauses)
1448                                                                                                (list conditional-arg))))
1449                                                                        ((if-else-then)
1450                                                                                (add-arg-pos
1451                                                                                (format:format-work
1452                                                                                        (if conditional-arg (cadr clauses) (car clauses))
1453                                                                                        (rest-args))))
1454                                                                        ((num-case)
1455                                                                                (when (or (not (integer? conditional-arg))
1456                                                                                                                        (fx< conditional-arg 0))
1457                                                                                        (format:error "argument not a positive integer"))
1458                                                                                (when (not (and (fx>= conditional-arg (length clauses))
1459                                                                                                                                                (not clause-default)))
1460                                                                                        (add-arg-pos
1461                                                                                        (format:format-work
1462                                                                                                (if (fx>= conditional-arg (length clauses))
1463                                                                                                        clause-default
1464                                                                                                        (list-ref clauses conditional-arg))
1465                                                                                                (rest-args))))))))
1466                                                        (anychar-dispatch))
1467                                                        ((#\{)                  ; Iteration begin
1468                                                        (set! iteration-nest (fx+ iteration-nest 1))
1469                                                        (cond
1470                                                                ((fx= iteration-nest 1)
1471                                                                (set! iteration-pos format:pos)
1472                                                                (set! iteration-type
1473                                                                        (case modifier
1474                                                                                ((at) 'rest-args)
1475                                                                                ((colon) 'sublists)
1476                                                                                ((colon-at) 'rest-sublists)
1477                                                                                (else 'list)))
1478                                                                (set! max-iterations
1479                                                                        (if (one-positive-integer? params) (car params) #f))))
1480                                                        (anychar-dispatch))
1481                                                        ((#\})                  ; Iteration end
1482                                                        (when (fx= 0 iteration-nest)
1483                                                                (format:error "missing ~~{"))
1484                                                        (set! iteration-nest (fx- iteration-nest 1))
1485                                                        (case modifier
1486                                                                ((colon)
1487                                                                        (unless max-iterations (set! max-iterations 1)))
1488                                                                ((colon-at at) (format:error "illegal modifier" modifier))
1489                                                                (else (unless max-iterations
1490                                                                                                (set! max-iterations format:max-iterations))))
1491                                                        (unless (null? params)
1492                                                                (format:error "no parameters allowed in ~~}" params))
1493                                                        (when (fx= 0 iteration-nest)
1494                                                                (let ((iteration-str
1495                                                                                                (substring format-string iteration-pos
1496                                                                                                                                        (fx- format:pos (if modifier 3 2)))))
1497                                                                        (when (string=? iteration-str "")
1498                                                                                (set! iteration-str (next-arg)))
1499                                                                        (case iteration-type
1500                                                                                ((list)
1501                                                                                        (let ((args (next-arg))
1502                                                                                                                (args-len 0))
1503                                                                                                (unless (list? args)
1504                                                                                                        (format:error "expected a list argument" args))
1505                                                                                                (set! args-len (length args))
1506                                                                                                (do ((arg-pos 0 (fx+ arg-pos
1507                                                                                                                                                                        (format:format-work
1508                                                                                                                                                                                iteration-str
1509                                                                                                                                                                                (list-tail args arg-pos))))
1510                                                                                                                (i 0 (fx+ i 1)))
1511                                                                                                                ((or (fx>= arg-pos args-len)
1512                                                                                                                                (and format:iteration-bounded
1513                                                                                                                                                        (fx>= i max-iterations)))))))
1514                                                                                ((sublists)
1515                                                                                        (let ((args (next-arg))
1516                                                                                                                (args-len 0))
1517                                                                                                (unless (list? args)
1518                                                                                                        (format:error "expected a list argument" args))
1519                                                                                                (set! args-len (length args))
1520                                                                                                (do ((arg-pos 0 (fx+ arg-pos 1)))
1521                                                                                                                ((or (fx>= arg-pos args-len)
1522                                                                                                                                (and format:iteration-bounded
1523                                                                                                                                                        (fx>= arg-pos max-iterations))))
1524                                                                                                        (let ((sublist (list-ref args arg-pos)))
1525                                                                                                                (unless (list? sublist)
1526                                                                                                                        (format:error
1527                                                                                                                                "expected a list of lists argument" args))
1528                                                                                                                (format:format-work iteration-str sublist)))))
1529                                                                                ((rest-args)
1530                                                                                        (let* ((args (rest-args))
1531                                                                                                                (args-len (length args))
1532                                                                                                                (usedup-args
1533                                                                                                                        (do ((arg-pos 0 (fx+ arg-pos
1534                                                                                                                                                                                                (format:format-work
1535                                                                                                                                                                                                        iteration-str
1536                                                                                                                                                                                                        (list-tail
1537                                                                                                                                                                                                        args arg-pos))))
1538                                                                                                                                        (i 0 (fx+ i 1)))
1539                                                                                                                                        ((or (fx>= arg-pos args-len)
1540                                                                                                                                                        (and format:iteration-bounded
1541                                                                                                                                                                                (fx>= i max-iterations)))
1542                                                                                                                                        arg-pos))))
1543                                                                                                (add-arg-pos usedup-args)))
1544                                                                                ((rest-sublists)
1545                                                                                        (let* ((args (rest-args))
1546                                                                                                                (args-len (length args))
1547                                                                                                                (usedup-args
1548                                                                                                                        (do ((arg-pos 0 (fx+ arg-pos 1)))
1549                                                                                                                                        ((or (fx>= arg-pos args-len)
1550                                                                                                                                                        (and format:iteration-bounded
1551                                                                                                                                                                                (fx>= arg-pos max-iterations)))
1552                                                                                                                                        arg-pos)
1553                                                                                                                                (let ((sublist (list-ref args arg-pos)))
1554                                                                                                                                        (if (not (list? sublist))
1555                                                                                                                                                        (format:error "expected list arguments" args))
1556                                                                                                                                        (format:format-work iteration-str sublist)))))
1557                                                                                                (add-arg-pos usedup-args)))
1558                                                                                (else (format:error "internal error in ~~}")))))
1559                                                        (anychar-dispatch))
1560                                                        ((#\^)                  ; Up and out
1561                                                        (let* ((continue
1562                                                                                        (cond
1563                                                                                                ((not (null? params))
1564                                                                                                (not
1565                                                                                                        (case (length params)
1566                                                                                                                ((1) (fx= 0 (car params)))
1567                                                                                                                ((2) (fx= (list-ref params 0) (list-ref params 1)))
1568                                                                                                                ((3) (and (fx<= (list-ref params 0) (list-ref params 1))
1569                                                                                                                                                        (fx<= (list-ref params 0) (list-ref params 2))))
1570                                                                                                                (else (format:error "too many parameters")))))
1571                                                                                                (format:case-conversion ; if conversion stop conversion
1572                                                                                                (set! format:case-conversion string-copy) #t)
1573                                                                                                ((fx= iteration-nest 1) #t)
1574                                                                                                ((fx= conditional-nest 1) #t)
1575                                                                                                ((fx>= arg-pos arg-len)
1576                                                                                                (set! format:pos format-string-len) #f)
1577                                                                                                (else #t))))
1578                                                                (when continue
1579                                                                        (anychar-dispatch))))
1580
1581                                                        ;; format directive modifiers and parameters
1582
1583                                                        ((#\@)                  ; `@' modifier
1584                                                        (when (memq modifier '(at colon-at))
1585                                                                (format:error "double `@' modifier"))
1586                                                        (set! modifier (if (eq? modifier 'colon) 'colon-at 'at))
1587                                                        (tilde-dispatch))
1588                                                        ((#\:)                  ; `:' modifier
1589                                                        (when (memq modifier '(colon colon-at))
1590                                                                (format:error "double `:' modifier"))
1591                                                        (set! modifier (if (eq? modifier 'at) 'colon-at 'colon))
1592                                                        (tilde-dispatch))
1593                                                        ((#\')                  ; Character parameter
1594                                                        (when modifier
1595                                                                (format:error "misplaced modifier" modifier))
1596                                                        (set! params (append params (list (char->integer (next-char)))))
1597                                                        (set! param-value-found #t)
1598                                                        (tilde-dispatch))
1599                                                        ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr
1600                                                        (when modifier
1601                                                                (format:error "misplaced modifier" modifier))
1602                                                        (let ((num-str-beg (fx- format:pos 1))
1603                                                                                (num-str-end format:pos))
1604                                                                (do ((ch (peek-next-char) (peek-next-char)))
1605                                                                                ((not (char-numeric? ch)))
1606                                                                        (next-char)
1607                                                                        (set! num-str-end (fx+ 1 num-str-end)))
1608                                                                (set! params
1609                                                                        (append params
1610                                                                                (list
1611                                                                                        (string->number
1612                                                                                                (substring format-string num-str-beg num-str-end))))))
1613                                                        (set! param-value-found #t)
1614                                                        (tilde-dispatch))
1615                                                        ((#\V)           ; Variable parameter from next argum.
1616                                                        (when modifier
1617                                                                (format:error "misplaced modifier" modifier))
1618                                                        (set! params (append params (list (next-arg))))
1619                                                        (set! param-value-found #t)
1620                                                        (tilde-dispatch))
1621                                                        ((#\#)         ; Parameter is number of remaining args
1622                                                        (when modifier
1623                                                                (format:error "misplaced modifier" modifier))
1624                                                        (set! params (append params (list (length (rest-args)))))
1625                                                        (set! param-value-found #t)
1626                                                        (tilde-dispatch))
1627                                                        ((#\,)                  ; Parameter separators
1628                                                        (when modifier
1629                                                                (format:error "misplaced modifier" modifier))
1630                                                        (unless param-value-found
1631                                                                (set! params (append params '(#f)))) ; append empty paramtr
1632                                                        (set! param-value-found #f)
1633                                                        (tilde-dispatch))
1634                                                        ((#\Q)                  ; Inquiry messages
1635                                                        (if (eq? modifier 'colon)
1636                                                                (format:out-str format:version)
1637                                                                (let ((nl (string #\newline)))
1638                                                                        (format:out-str
1639                                                                                (string-append
1640                                                                                "SLIB Common LISP format version " format:version nl
1641                                                                                "  This code is in the public domain." nl
1642                                                                                "  Please send bug reports to `lutzeb@cs.tu-berlin.de'"
1643                                                                                nl))))
1644                                                        (anychar-dispatch))
1645                                                        (else                   ; Unknown tilde directive
1646                                                        (format:error "unknown control character"
1647                                                                (string-ref format-string (fx- format:pos 1))))))
1648                                        (else (anychar-dispatch)))))) ; in case of conditional
1649
1650                (set! format:pos 0)
1651                (set! format:arg-pos 0)
1652                (anychar-dispatch)                ; start the formatting
1653                (set! format:pos recursive-pos-save)
1654                arg-pos))
1655
1656;; the output handler for a port
1657
1658(define (format:out fmt args)
1659    (set! format:case-conversion #f)    ; modifier case conversion procedure
1660    (set! format:flush-output #f)       ; ~! reset
1661    (let ((arg-pos (format:format-work fmt args))
1662          (arg-len (length args)))
1663      (cond
1664        ((fx< arg-pos arg-len)
1665          (set! format:arg-pos (+ arg-pos 1))
1666          (set! format:pos (string-length fmt))
1667          (if format:unprocessed-arguments-error?
1668            (format:error "superfluous arguments" (fx- arg-len arg-pos))))
1669        ((fx> arg-pos arg-len)
1670          (set! format:arg-pos (+ arg-len 1))
1671          (format:error "missing arguments" (fx- arg-pos arg-len))))))
1672
1673;; We should keep separate track of columns for each port, but
1674;; keeping pointers to ports will foil GC.  Instead, keep
1675;; associations indexed by the string representation of the ports.
1676
1677(define *port-columns* '())
1678
1679(define-inline (format:port-name port)
1680        (->string port) )
1681
1682(define (format:get-port-column port)
1683  (let ([pair (assoc (format:port-name port) *port-columns*)])
1684    (if pair (cdr pair) 0)))
1685
1686(define (format:set-port-column! port col)
1687  (let* ([pname (format:port-name port)]
1688         [pair (assoc pname *port-columns*)])
1689    (if pair
1690                        (set-cdr! pair col)
1691                        (set! *port-columns* (cons (cons pname col) *port-columns*)))))
1692
1693;;; Format entry-point
1694
1695;@
1696(define (format . args)
1697  (set! format:args args)
1698  (set! format:arg-pos 0)
1699  (set! format:pos 0)
1700  (set! format:read-proof #f)
1701  (if (fx< (length args) 1)
1702    (format:error "not enough arguments"))
1703
1704  ;; If the first argument is a string, then that's the format string.
1705  ;; (Scheme->C)
1706  ;; In this case, put the argument list in canonical form.
1707  (let ((args (if (string? (car args)) (cons #f args) args)))
1708    ;; Use this canonicalized version when reporting errors.
1709    (set! format:args args)
1710    (let ((destination (car args))
1711          (arglist (cdr args)))
1712      (cond
1713       ((or (and (boolean? destination) ; port output
1714                 destination)
1715            (output-port? destination)
1716            (number? destination))
1717        (let ((port (cond ((boolean? destination) (current-output-port))
1718                          ((output-port? destination) destination)
1719                          ((number? destination) (current-error-port)))))
1720          (set! format:port port)    ; global port for output routines
1721          (set! format:output-col (format:get-port-column port))
1722          (format:out (car arglist) (cdr arglist))
1723          (format:set-port-column! port format:output-col)
1724          (if format:flush-output (flush-output port))
1725          #t))
1726       ((and (boolean? destination)     ; string output
1727             (not destination))
1728        (call-with-output-string
1729            (lambda (port)
1730              (set! format:port port)
1731              (set! format:output-col 0)
1732              (format:out (car arglist) (cdr arglist)))))
1733       (else
1734        (format:error "illegal destination" destination))))))
1735
1736)
Note: See TracBrowser for help on using the repository browser.