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

Last change on this file since 36265 was 36265, checked in by felix winkelmann, 20 months ago

format 3.2.0

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