/[guile]/guile/guile-core/ice-9/format.scm
ViewVC logotype

Diff of /guile/guile-core/ice-9/format.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.1.20  
changed lines
  Added in v.1.21

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26