HCoop / bpt / guile.git / blob
? search:


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