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
5 ; This code is in the public domain.
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.
14 (define-module (ice-9 format)
15 :use-module (ice-9 and-let-star)
16 :autoload (ice-9 pretty-print) (pretty-print))
19 ;; So that `export' below will not accidentally re-export the
20 ;; `format' of the `(guile)' module.
24 format:symbol-case-conv
28 ;;; Configuration ------------------------------------------------------------
30 (define format:symbol-case-conv #f)
31 ;; Symbols are converted by symbol->string so the case of the printed
32 ;; symbols is implementation dependent. format:symbol-case-conv is a
33 ;; one arg closure which is either #f (no conversion), string-upcase!,
34 ;; string-downcase! or string-capitalize!.
36 (define format:iobj-case-conv #f)
37 ;; As format:symbol-case-conv but applies for the representation of
38 ;; implementation internal objects.
40 (define format:expch #\E)
41 ;; The character prefixing the exponent value in ~e printing.
43 (define format:floats (provided? 'inexact))
44 ;; Detects if the scheme system implements flonums (see at eof).
46 (define format:complex-numbers (provided? 'complex))
47 ;; Detects if the scheme system implements complex numbers.
49 (define format:radix-pref (char=? #\# (string-ref (number->string 8 8) 0)))
50 ;; Detects if number->string adds a radix prefix.
52 (define format:ascii-non-printable-charnames
53 '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel"
54 "bs" "ht" "nl" "vt" "np" "cr" "so" "si"
55 "dle" "dc1" "dc2" "dc3" "dc4" "nak" "syn" "etb"
56 "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space"))
58 ;;; End of configuration ----------------------------------------------------
60 (define format:version "3.0")
61 (define format:port #f) ; curr. format output port
62 (define format:output-col 0) ; curr. format output tty column
63 (define format:flush-output #f) ; flush output at end of formatting
64 (define format:case-conversion #f)
65 (define format:error-continuation #f)
66 (define format:args #f)
67 (define format:pos 0) ; curr. format string parsing position
68 (define format:arg-pos 0) ; curr. format argument position
69 ; this is global for error presentation
71 ; format string and char output routines on format:port
73 (define (format:out-str str)
74 (if format:case-conversion
75 (display (format:case-conversion str) format:port)
76 (display str format:port))
77 (set! format:output-col
78 (+ format:output-col (string-length str))))
80 (define (format:out-char ch)
81 (if format:case-conversion
82 (display (format:case-conversion (string ch)) format:port)
83 (write-char ch format:port))
84 (set! format:output-col
85 (if (char=? ch #\newline)
87 (+ format:output-col 1))))
89 ;(define (format:out-substr str i n) ; this allocates a new string
90 ; (display (substring str i n) format:port)
91 ; (set! format:output-col (+ format:output-col n)))
93 (define (format:out-substr str i n)
96 (write-char (string-ref str k) format:port))
97 (set! format:output-col (+ format:output-col n)))
99 ;(define (format:out-fill n ch) ; this allocates a new string
100 ; (format:out-str (make-string n ch)))
102 (define (format:out-fill n ch)
105 (write-char ch format:port))
106 (set! format:output-col (+ format:output-col n)))
108 ; format's user error handler
110 (define (format:error . args) ; never returns!
111 (let ((error-continuation format:error-continuation)
112 (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 "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~
121 ~{~a ~}===>~{~a ~})~% "
123 (substring format-string 0 format:pos)
124 (substring format-string format:pos
125 (string-length format-string))
126 (list-head (cddr format:args) format:arg-pos)
127 (list-tail (cddr format:args) format:arg-pos)))
129 "~%FORMAT: error with call: (format~{ ~a~})~% "
131 (apply format port args)
133 (set! format:error format:error-save)
134 (set! format:error-continuation error-continuation)
136 (format:intern-error "format:abort does not jump to toplevel!")))
138 (define format:error-save format:error)
140 (define (format:intern-error . args) ;if something goes wrong in format:error
141 (display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline)
142 (display " format args: ") (write format:args) (newline)
143 (display " error args: ") (write args) (newline)
144 (set! format:error format:error-save)
147 (define (format:format . args) ; the formatter entry
148 (set! format:args args)
149 (set! format:arg-pos 0)
151 (if (< (length args) 1)
152 (format:error "not enough arguments"))
154 ;; If the first argument is a string, then that's the format string.
156 ;; In this case, put the argument list in canonical form.
157 (let ((args (if (string? (car args))
160 ;; Use this canonicalized version when reporting errors.
161 (set! format:args args)
163 (let ((destination (car args))
164 (arglist (cdr args)))
166 ((or (and (boolean? destination) ; port output
168 (output-port? destination)
169 (number? destination))
171 ((boolean? destination) (current-output-port))
172 ((output-port? destination) destination)
173 ((number? destination) (current-error-port)))
174 (car arglist) (cdr arglist)))
175 ((and (boolean? destination) ; string output
177 (call-with-output-string
178 (lambda (port) (format:out port (car arglist) (cdr arglist)))))
180 (format:error "illegal destination `~a'" destination))))))
182 (define (format:out port fmt args) ; the output handler for a port
183 (set! format:port port) ; global port for output routines
184 (set! format:case-conversion #f) ; modifier case conversion procedure
185 (set! format:flush-output #f) ; ~! reset
186 (and-let* ((col (port-column port))) ; get current column from port
187 (set! format:output-col col))
188 (let ((arg-pos (format:format-work fmt args))
189 (arg-len (length args)))
192 (set! format:arg-pos (+ arg-pos 1))
193 (set! format:pos (string-length fmt))
194 (format:error "~a superfluous argument~:p" (- arg-len arg-pos)))
196 (set! format:arg-pos (+ arg-len 1))
197 (display format:arg-pos)
198 (format:error "~a missing argument~:p" (- arg-pos arg-len)))
200 (if format:flush-output (force-output port))
203 (define format:parameter-characters
204 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\'))
206 (define (format:format-work format-string arglist) ; does the formatting work
208 ((format-string-len (string-length format-string))
209 (arg-pos 0) ; argument position in arglist
210 (arg-len (length arglist)) ; number of arguments
211 (modifier #f) ; 'colon | 'at | 'colon-at | #f
212 (params '()) ; directive parameter list
213 (param-value-found #f) ; a directive parameter value found
214 (conditional-nest 0) ; conditional nesting level
215 (clause-pos 0) ; last cond. clause beginning char pos
216 (clause-default #f) ; conditional default clause string
217 (clauses '()) ; conditional clause string list
218 (conditional-type #f) ; reflects the contional modifiers
219 (conditional-arg #f) ; argument to apply the conditional
220 (iteration-nest 0) ; iteration nesting level
221 (iteration-pos 0) ; iteration string beginning char pos
222 (iteration-type #f) ; reflects the iteration modifiers
223 (max-iterations #f) ; maximum number of iterations
224 (recursive-pos-save format:pos)
226 (next-char ; gets the next char from format-string
228 (let ((ch (peek-next-char)))
229 (set! format:pos (+ 1 format:pos))
234 (if (>= format:pos format-string-len)
235 (format:error "illegal format string")
236 (string-ref format-string format:pos))))
238 (one-positive-integer?
242 ((and (integer? (car params))
244 (= (length params) 1)) #t)
245 (else (format:error "one positive integer parameter expected")))))
249 (if (>= arg-pos arg-len)
251 (set! format:arg-pos (+ arg-len 1))
252 (format:error "missing argument(s)")))
254 (list-ref arglist (- arg-pos 1))))
259 (if (negative? arg-pos)
260 (format:error "missing backward argument(s)"))
261 (list-ref arglist arg-pos)))
265 (let loop ((l arglist) (k arg-pos)) ; list-tail definition
266 (if (= k 0) l (loop (cdr l) (- k 1))))))
270 (set! arg-pos (+ n arg-pos))
271 (set! format:arg-pos arg-pos)))
273 (anychar-dispatch ; dispatches the format-string
275 (if (>= format:pos format-string-len)
276 arg-pos ; used for ~? continuance
277 (let ((char (next-char)))
282 (set! param-value-found #f)
285 (if (and (zero? conditional-nest)
286 (zero? iteration-nest))
287 (format:out-char char))
288 (anychar-dispatch)))))))
293 ((>= format:pos format-string-len)
294 (format:out-str "~") ; tilde at end of string is just output
295 arg-pos) ; used for ~? continuance
296 ((and (or (zero? conditional-nest)
297 (memv (peek-next-char) ; find conditional directives
298 (append '(#\[ #\] #\; #\: #\@ #\^)
299 format:parameter-characters)))
300 (or (zero? iteration-nest)
301 (memv (peek-next-char) ; find iteration directives
302 (append '(#\{ #\} #\: #\@ #\^)
303 format:parameter-characters))))
304 (case (char-upcase (next-char))
308 ((#\A) ; Any -- for humans
309 (set! format:read-proof (memq modifier '(colon colon-at)))
310 (format:out-obj-padded (memq modifier '(at colon-at))
311 (next-arg) #f params)
313 ((#\S) ; Slashified -- for parsers
314 (set! format:read-proof (memq modifier '(colon colon-at)))
315 (format:out-obj-padded (memq modifier '(at colon-at))
316 (next-arg) #t params)
319 (format:out-num-padded modifier (next-arg) params 10)
322 (format:out-num-padded modifier (next-arg) params 16)
325 (format:out-num-padded modifier (next-arg) params 8)
328 (format:out-num-padded modifier (next-arg) params 2)
332 (format:out-obj-padded ; Roman, cardinal, ordinal numerals
335 ((at) format:num->roman)
336 ((colon-at) format:num->old-roman)
337 ((colon) format:num->ordinal)
338 (else format:num->cardinal))
341 (format:out-num-padded ; any Radix
342 modifier (next-arg) (cdr params) (car params)))
344 ((#\F) ; Fixed-format floating-point
346 (format:out-fixed modifier (next-arg) params)
347 (format:out-str (number->string (next-arg))))
349 ((#\E) ; Exponential floating-point
351 (format:out-expon modifier (next-arg) params)
352 (format:out-str (number->string (next-arg))))
354 ((#\G) ; General floating-point
356 (format:out-general modifier (next-arg) params)
357 (format:out-str (number->string (next-arg))))
359 ((#\$) ; Dollars floating-point
361 (format:out-dollar modifier (next-arg) params)
362 (format:out-str (number->string (next-arg))))
364 ((#\I) ; Complex numbers
365 (if (not format:complex-numbers)
367 "complex numbers not supported by this scheme system"))
368 (let ((z (next-arg)))
369 (if (not (complex? z))
370 (format:error "argument not a complex number"))
371 (format:out-fixed modifier (real-part z) params)
372 (format:out-fixed 'at (imag-part z) params)
373 (format:out-char #\i))
376 (let ((ch (if (one-positive-integer? params)
377 (integer->char (car params))
379 (if (not (char? ch)) (format:error "~~c expects a character"))
382 (format:out-str (format:char->str ch)))
384 (let ((c (char->integer ch)))
386 (set! c (+ c 256))) ; compensate complement impl.
388 ((< c #x20) ; assumes that control chars are < #x20
389 (format:out-char #\^)
391 (integer->char (+ c #x40))))
393 (format:out-str "#\\")
395 (if format:radix-pref
396 (let ((s (number->string c 8)))
397 (substring s 2 (string-length s)))
398 (number->string c 8))))
400 (format:out-char ch)))))
401 (else (format:out-char ch))))
404 (if (memq modifier '(colon colon-at))
406 (let ((arg (next-arg)))
407 (if (not (number? arg))
408 (format:error "~~p expects a number argument"))
410 (if (memq modifier '(at colon-at))
411 (format:out-char #\y))
412 (if (memq modifier '(at colon-at))
413 (format:out-str "ies")
414 (format:out-char #\s))))
417 (if (one-positive-integer? params)
418 (format:out-fill (car params) #\~)
419 (format:out-char #\~))
422 (if (one-positive-integer? params)
423 (format:out-fill (car params) #\newline)
424 (format:out-char #\newline))
425 (set! format:output-col 0)
428 (if (one-positive-integer? params)
430 (if (> (car params) 0)
431 (format:out-fill (- (car params)
432 (if (> format:output-col 0) 0 1))
434 (set! format:output-col 0))
435 (if (> format:output-col 0)
436 (format:out-char #\newline)))
438 ((#\_) ; Space character
439 (if (one-positive-integer? params)
440 (format:out-fill (car params) #\space)
441 (format:out-char #\space))
443 ((#\/) ; Tabulator character
444 (if (one-positive-integer? params)
445 (format:out-fill (car params) #\tab)
446 (format:out-char #\tab))
448 ((#\|) ; Page seperator
449 (if (one-positive-integer? params)
450 (format:out-fill (car params) #\page)
451 (format:out-char #\page))
452 (set! format:output-col 0)
455 (format:tabulate modifier params)
457 ((#\Y) ; Pretty-print
458 (pretty-print (next-arg) format:port)
459 (set! format:output-col 0)
461 ((#\? #\K) ; Indirection (is "~K" in T-Scheme)
463 ((memq modifier '(colon colon-at))
464 (format:error "illegal modifier in ~~?"))
466 (let* ((frmt (next-arg))
468 (add-arg-pos (format:format-work frmt args))))
470 (let* ((frmt (next-arg))
472 (format:format-work frmt args))))
474 ((#\!) ; Flush output
475 (set! format:flush-output #t)
477 ((#\newline) ; Continuation lines
478 (if (eq? modifier 'at)
479 (format:out-char #\newline))
480 (if (< format:pos format-string-len)
481 (do ((ch (peek-next-char) (peek-next-char)))
482 ((or (not (char-whitespace? ch))
483 (= format:pos (- format-string-len 1))))
484 (if (eq? modifier 'colon)
485 (format:out-char (next-char))
488 ((#\*) ; Argument jumping
490 ((colon) ; jump backwards
491 (if (one-positive-integer? params)
496 ((at) ; jump absolute
497 (set! arg-pos (if (one-positive-integer? params)
500 (format:error "illegal modifier `:@' in ~~* directive"))
502 (if (one-positive-integer? params)
508 ((#\() ; Case conversion begin
509 (set! format:case-conversion
511 ((at) string-capitalize-first)
512 ((colon) string-capitalize)
513 ((colon-at) string-upcase)
514 (else string-downcase)))
516 ((#\)) ; Case conversion end
517 (if (not format:case-conversion)
518 (format:error "missing ~~("))
519 (set! format:case-conversion #f)
521 ((#\[) ; Conditional begin
522 (set! conditional-nest (+ conditional-nest 1))
524 ((= conditional-nest 1)
525 (set! clause-pos format:pos)
526 (set! clause-default #f)
528 (set! conditional-type
531 ((colon) 'if-else-then)
532 ((colon-at) (format:error "illegal modifier in ~~["))
534 (set! conditional-arg
535 (if (one-positive-integer? params)
539 ((#\;) ; Conditional separator
540 (if (zero? conditional-nest)
541 (format:error "~~; not in ~~[~~] conditional"))
542 (if (not (null? params))
543 (format:error "no parameter allowed in ~~;"))
544 (if (= conditional-nest 1)
547 ((eq? modifier 'colon)
548 (set! clause-default #t)
549 (substring format-string clause-pos
551 ((memq modifier '(at colon-at))
552 (format:error "illegal modifier in ~~;"))
554 (substring format-string clause-pos
555 (- format:pos 2))))))
556 (set! clauses (append clauses (list clause-str)))
557 (set! clause-pos format:pos)))
559 ((#\]) ; Conditional end
560 (if (zero? conditional-nest) (format:error "missing ~~["))
561 (set! conditional-nest (- conditional-nest 1))
563 (format:error "no modifier allowed in ~~]"))
564 (if (not (null? params))
565 (format:error "no parameter allowed in ~~]"))
567 ((zero? conditional-nest)
568 (let ((clause-str (substring format-string clause-pos
571 (set! clause-default clause-str)
572 (set! clauses (append clauses (list clause-str)))))
573 (case conditional-type
576 (format:format-work (car clauses)
577 (list conditional-arg))))
580 (format:format-work (if conditional-arg
585 (if (or (not (integer? conditional-arg))
586 (< conditional-arg 0))
587 (format:error "argument not a positive integer"))
588 (if (not (and (>= conditional-arg (length clauses))
589 (not clause-default)))
592 (if (>= conditional-arg (length clauses))
594 (list-ref clauses conditional-arg))
597 ((#\{) ; Iteration begin
598 (set! iteration-nest (+ iteration-nest 1))
600 ((= iteration-nest 1)
601 (set! iteration-pos format:pos)
606 ((colon-at) 'rest-sublists)
608 (set! max-iterations (if (one-positive-integer? params)
611 ((#\}) ; Iteration end
612 (if (zero? iteration-nest) (format:error "missing ~~{"))
613 (set! iteration-nest (- iteration-nest 1))
616 (if (not max-iterations) (set! max-iterations 1)))
617 ((colon-at at) (format:error "illegal modifier"))
618 (else (if (not max-iterations) (set! max-iterations 100))))
619 (if (not (null? params))
620 (format:error "no parameters allowed in ~~}"))
621 (if (zero? iteration-nest)
623 (substring format-string iteration-pos
624 (- format:pos (if modifier 3 2)))))
625 (if (string=? iteration-str "")
626 (set! iteration-str (next-arg)))
629 (let ((args (next-arg))
631 (if (not (list? args))
632 (format:error "expected a list argument"))
633 (set! args-len (length args))
634 (do ((arg-pos 0 (+ arg-pos
637 (list-tail args arg-pos))))
639 ((or (>= arg-pos args-len)
640 (>= i max-iterations))))))
642 (let ((args (next-arg))
644 (if (not (list? args))
645 (format:error "expected a list argument"))
646 (set! args-len (length args))
647 (do ((arg-pos 0 (+ arg-pos 1)))
648 ((or (>= arg-pos args-len)
649 (>= arg-pos max-iterations)))
650 (let ((sublist (list-ref args arg-pos)))
651 (if (not (list? sublist))
653 "expected a list of lists argument"))
654 (format:format-work iteration-str sublist)))))
656 (let* ((args (rest-args))
657 (args-len (length args))
659 (do ((arg-pos 0 (+ arg-pos
665 ((or (>= arg-pos args-len)
666 (>= i max-iterations))
668 (add-arg-pos usedup-args)))
670 (let* ((args (rest-args))
671 (args-len (length args))
673 (do ((arg-pos 0 (+ arg-pos 1)))
674 ((or (>= arg-pos args-len)
675 (>= arg-pos max-iterations))
677 (let ((sublist (list-ref args arg-pos)))
678 (if (not (list? sublist))
679 (format:error "expected list arguments"))
680 (format:format-work iteration-str sublist)))))
681 (add-arg-pos usedup-args)))
682 (else (format:error "internal error in ~~}")))))
687 ((not (null? params))
689 (case (length params)
690 ((1) (zero? (car params)))
691 ((2) (= (list-ref params 0) (list-ref params 1)))
692 ((3) (<= (list-ref params 0)
694 (list-ref params 2)))
695 (else (format:error "too much parameters")))))
696 (format:case-conversion ; if conversion stop conversion
697 (set! format:case-conversion string-copy) #t)
698 ((= iteration-nest 1) #t)
699 ((= conditional-nest 1) #t)
700 ((>= arg-pos arg-len)
701 (set! format:pos format-string-len) #f)
704 (anychar-dispatch))))
706 ;; format directive modifiers and parameters
708 ((#\@) ; `@' modifier
709 (if (memq modifier '(at colon-at))
710 (format:error "double `@' modifier"))
711 (set! modifier (if (eq? modifier 'colon) 'colon-at 'at))
713 ((#\:) ; `:' modifier
714 (if (memq modifier '(colon colon-at))
715 (format:error "double `:' modifier"))
716 (set! modifier (if (eq? modifier 'at) 'colon-at 'colon))
718 ((#\') ; Character parameter
719 (if modifier (format:error "misplaced modifier"))
720 (set! params (append params (list (char->integer (next-char)))))
721 (set! param-value-found #t)
723 ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr
724 (if modifier (format:error "misplaced modifier"))
725 (let ((num-str-beg (- format:pos 1))
726 (num-str-end format:pos))
727 (do ((ch (peek-next-char) (peek-next-char)))
728 ((not (char-numeric? ch)))
730 (set! num-str-end (+ 1 num-str-end)))
733 (list (string->number
734 (substring format-string
737 (set! param-value-found #t)
739 ((#\V) ; Variable parameter from next argum.
740 (if modifier (format:error "misplaced modifier"))
741 (set! params (append params (list (next-arg))))
742 (set! param-value-found #t)
744 ((#\#) ; Parameter is number of remaining args
745 (if modifier (format:error "misplaced modifier"))
746 (set! params (append params (list (length (rest-args)))))
747 (set! param-value-found #t)
749 ((#\,) ; Parameter separators
750 (if modifier (format:error "misplaced modifier"))
751 (if (not param-value-found)
752 (set! params (append params '(#f)))) ; append empty paramtr
753 (set! param-value-found #f)
755 ((#\Q) ; Inquiry messages
756 (if (eq? modifier 'colon)
757 (format:out-str format:version)
758 (let ((nl (string #\newline)))
761 "SLIB Common LISP format version " format:version nl
762 " (C) copyright 1992-1994 by Dirk Lutzebaeck" nl
763 " please send bug reports to `lutzeb@cs.tu-berlin.de'"
766 (else ; Unknown tilde directive
767 (format:error "unknown control character `~c'"
768 (string-ref format-string (- format:pos 1))))))
769 (else (anychar-dispatch)))))) ; in case of conditional
772 (set! format:arg-pos 0)
773 (anychar-dispatch) ; start the formatting
774 (set! format:pos recursive-pos-save)
775 arg-pos)) ; return the position in the arg. list
777 ;; format:obj->str returns a R4RS representation as a string of an arbitrary
779 ;; First parameter is the object, second parameter is a boolean if the
780 ;; representation should be slashified as `write' does.
781 ;; It uses format:char->str which converts a character into
782 ;; a slashified string as `write' does and which is implementation dependent.
783 ;; It uses format:iobj->str to print out internal objects as
784 ;; quoted strings so that the output can always be processed by (read)
786 (define (format:obj->str obj slashify)
787 (define (obj->str obj slashify visited)
788 (if (memq obj (cdr visited))
789 (let ((n (- (list-index (cdr visited) (cdr obj)))))
790 (string-append "#" (number->string n) "#"))
794 (let ((obj-len (string-length obj)))
797 (let loop ((i 0) (j 0)) ; taken from Marc Feeley's pp.scm
799 (string-append (substring obj i j) "\"")
800 (let ((c (string-ref obj j)))
801 (if (or (char=? c #\\)
803 (string-append (substring obj i j) "\\"
805 (loop i (+ j 1))))))))
808 ((boolean? obj) (if obj "#t" "#f"))
810 ((number? obj) (number->string obj))
813 (if format:symbol-case-conv
814 (format:symbol-case-conv (symbol->string obj))
815 (symbol->string obj)))
819 (format:char->str obj)
825 (format:iobj->str obj))
828 (format:iobj->str obj))
832 (let loop ((obj-list obj)
836 (cond ((null? (cdr obj-list))
839 (obj->str (car obj-list)
841 (cons (car obj-list) visited))))
842 ((memq (cdr obj-list) visited)
845 (obj->str (car obj-list)
847 (cons (car obj-list) visited))
851 (list-index visited (cdr obj-list))))
853 ((pair? (cdr obj-list))
855 (cons (cdr obj-list) visited)
859 (obj->str (car obj-list)
861 (cons (car obj-list) visited))
866 (obj->str (car obj-list)
868 (cons (car obj-list) visited))
870 (obj->str (cdr obj-list)
872 (cons (cdr obj-list) visited))))))
876 (string-append "#" (obj->str (vector->list obj) #t visited)))
878 (else ; only objects with an #<...>
879 (format:iobj->str obj))))) ; representation should fall in here
880 (obj->str obj slashify (list obj)))
882 ;; format:iobj->str reveals the implementation dependent representation of
883 ;; #<...> objects with the use of display and call-with-output-string.
884 ;; If format:read-proof is set to #t the resulting string is additionally
885 ;; set into string quotes.
887 (define format:read-proof #f)
889 (define (format:iobj->str iobj)
890 (if (or format:read-proof
891 format:iobj-case-conv)
893 (if format:read-proof "\"" "")
894 (if format:iobj-case-conv
895 (format:iobj-case-conv
896 (call-with-output-string (lambda (p) (display iobj p))))
897 (call-with-output-string (lambda (p) (display iobj p))))
898 (if format:read-proof "\"" ""))
899 (call-with-output-string (lambda (p) (display iobj p)))))
902 ;; format:char->str converts a character into a slashified string as
903 ;; done by `write'. The procedure is dependent on the integer
904 ;; representation of characters and assumes a character number according to
905 ;; the ASCII character set.
907 (define (format:char->str ch)
908 (let ((int-rep (char->integer ch)))
909 (if (< int-rep 0) ; if chars are [-128...+127]
910 (set! int-rep (+ int-rep 256)))
914 ((char=? ch #\newline) "newline")
915 ((and (>= int-rep 0) (<= int-rep 32))
916 (vector-ref format:ascii-non-printable-charnames int-rep))
917 ((= int-rep 127) "del")
918 ((>= int-rep 128) ; octal representation
919 (if format:radix-pref
920 (let ((s (number->string int-rep 8)))
921 (substring s 2 (string-length s)))
922 (number->string int-rep 8)))
923 (else (string ch))))))
925 (define format:space-ch (char->integer #\space))
926 (define format:zero-ch (char->integer #\0))
928 (define (format:par pars length index default name)
930 (let ((par (list-ref pars index)))
935 "~s parameter must be a positive integer" name)
941 (define (format:out-obj-padded pad-left obj slashify pars)
943 (format:out-str (format:obj->str obj slashify))
944 (let ((l (length pars)))
945 (let ((mincol (format:par pars l 0 0 "mincol"))
946 (colinc (format:par pars l 1 1 "colinc"))
947 (minpad (format:par pars l 2 0 "minpad"))
948 (padchar (integer->char
949 (format:par pars l 3 format:space-ch #f)))
950 (objstr (format:obj->str obj slashify)))
952 (format:out-str objstr))
953 (do ((objstr-len (string-length objstr))
954 (i minpad (+ i colinc)))
955 ((>= (+ objstr-len i) mincol)
956 (format:out-fill i padchar)))
958 (format:out-str objstr))))))
960 (define (format:out-num-padded modifier number pars radix)
961 (if (not (integer? number)) (format:error "argument not an integer"))
962 (let ((numstr (number->string number radix)))
963 (if (and format:radix-pref (not (= radix 10)))
964 (set! numstr (substring numstr 2 (string-length numstr))))
965 (if (and (null? pars) (not modifier))
966 (format:out-str numstr)
967 (let ((l (length pars))
968 (numstr-len (string-length numstr)))
969 (let ((mincol (format:par pars l 0 #f "mincol"))
970 (padchar (integer->char
971 (format:par pars l 1 format:space-ch #f)))
972 (commachar (integer->char
973 (format:par pars l 2 (char->integer #\,) #f)))
974 (commawidth (format:par pars l 3 3 "commawidth")))
976 (let ((numlen numstr-len)) ; calc. the output len of number
977 (if (and (memq modifier '(at colon-at)) (> number 0))
978 (set! numlen (+ numlen 1)))
979 (if (memq modifier '(colon colon-at))
980 (set! numlen (+ (quotient (- numstr-len
981 (if (< number 0) 2 1))
984 (if (> mincol numlen)
985 (format:out-fill (- mincol numlen) padchar))))
986 (if (and (memq modifier '(at colon-at))
988 (format:out-char #\+))
989 (if (memq modifier '(colon colon-at)) ; insert comma character
990 (let ((start (remainder numstr-len commawidth))
991 (ns (if (< number 0) 1 0)))
992 (format:out-substr numstr 0 start)
993 (do ((i start (+ i commawidth)))
996 (format:out-char commachar))
997 (format:out-substr numstr i (+ i commawidth))))
998 (format:out-str numstr)))))))
1000 (define (format:tabulate modifier pars)
1001 (let ((l (length pars)))
1002 (let ((colnum (format:par pars l 0 1 "colnum"))
1003 (colinc (format:par pars l 1 1 "colinc"))
1004 (padch (integer->char (format:par pars l 2 format:space-ch #f))))
1007 (format:error "unsupported modifier for ~~t"))
1008 ((at) ; relative tabulation
1011 colnum ; colnum = colrel
1012 (do ((c 0 (+ c colinc))
1013 (col (+ format:output-col colnum)))
1015 (- c format:output-col))))
1017 (else ; absolute tabulation
1020 ((< format:output-col colnum)
1021 (- colnum format:output-col))
1025 (do ((c colnum (+ c colinc)))
1026 ((>= c format:output-col)
1027 (- c format:output-col)))))
1031 ;; roman numerals (from dorai@cs.rice.edu).
1033 (define format:roman-alist
1034 '((1000 #\M) (500 #\D) (100 #\C) (50 #\L)
1035 (10 #\X) (5 #\V) (1 #\I)))
1037 (define format:roman-boundary-values
1038 '(100 100 10 10 1 1 #f))
1040 (define format:num->old-roman
1042 (if (and (integer? n) (>= n 1))
1044 (romans format:roman-alist)
1046 (if (null? romans) (list->string (reverse s))
1047 (let ((roman-val (caar romans))
1048 (roman-dgt (cadar romans)))
1049 (do ((q (quotient n roman-val) (- q 1))
1050 (s s (cons roman-dgt s)))
1052 (loop (remainder n roman-val)
1053 (cdr romans) s))))))
1054 (format:error "only positive integers can be romanized"))))
1056 (define format:num->roman
1058 (if (and (integer? n) (> n 0))
1060 (romans format:roman-alist)
1061 (boundaries format:roman-boundary-values)
1064 (list->string (reverse s))
1065 (let ((roman-val (caar romans))
1066 (roman-dgt (cadar romans))
1067 (bdry (car boundaries)))
1068 (let loop2 ((q (quotient n roman-val))
1069 (r (remainder n roman-val))
1072 (if (and bdry (>= r (- roman-val bdry)))
1073 (loop (remainder r bdry) (cdr romans)
1077 (cdr (assv bdry romans))
1079 (loop r (cdr romans) (cdr boundaries) s))
1080 (loop2 (- q 1) r (cons roman-dgt s)))))))
1081 (format:error "only positive integers can be romanized"))))
1083 ;; cardinals & ordinals (from dorai@cs.rice.edu)
1085 (define format:cardinal-ones-list
1086 '(#f "one" "two" "three" "four" "five"
1087 "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen"
1088 "fourteen" "fifteen" "sixteen" "seventeen" "eighteen"
1091 (define format:cardinal-tens-list
1092 '(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty"
1095 (define format:num->cardinal999
1097 ;this procedure is inspired by the Bruno Haible's CLisp
1098 ;function format-small-cardinal, which converts numbers
1099 ;in the range 1 to 999, and is used for converting each
1100 ;thousand-block in a larger number
1101 (let* ((hundreds (quotient n 100))
1102 (tens+ones (remainder n 100))
1103 (tens (quotient tens+ones 10))
1104 (ones (remainder tens+ones 10)))
1109 (list-ref format:cardinal-ones-list hundreds))
1110 (string->list" hundred")
1111 (if (> tens+ones 0) '(#\space) '()))
1113 (if (< tens+ones 20)
1116 (list-ref format:cardinal-ones-list tens+ones))
1120 (list-ref format:cardinal-tens-list tens))
1124 (list-ref format:cardinal-ones-list ones)))
1127 (define format:cardinal-thousand-block-list
1128 '("" " thousand" " million" " billion" " trillion" " quadrillion"
1129 " quintillion" " sextillion" " septillion" " octillion" " nonillion"
1130 " decillion" " undecillion" " duodecillion" " tredecillion"
1131 " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
1132 " octodecillion" " novemdecillion" " vigintillion"))
1134 (define format:num->cardinal
1136 (cond ((not (integer? n))
1138 "only integers can be converted to English cardinals"))
1140 ((< n 0) (string-append "minus " (format:num->cardinal (- n))))
1142 (let ((power3-word-limit
1143 (length format:cardinal-thousand-block-list)))
1149 (let ((n-before-block (quotient n 1000))
1150 (n-after-block (remainder n 1000)))
1151 (loop n-before-block
1153 (if (> n-after-block 0)
1155 (if (> n-before-block 0)
1156 (string->list ", ") '())
1157 (format:num->cardinal999 n-after-block)
1158 (if (< power3 power3-word-limit)
1161 format:cardinal-thousand-block-list
1164 (string->list " times ten to the ")
1166 (format:num->ordinal
1168 (string->list " power")))
1172 (define format:ordinal-ones-list
1173 '(#f "first" "second" "third" "fourth" "fifth"
1174 "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth"
1175 "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth"
1176 "eighteenth" "nineteenth"))
1178 (define format:ordinal-tens-list
1179 '(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth"
1180 "seventieth" "eightieth" "ninetieth"))
1182 (define format:num->ordinal
1184 (cond ((not (integer? n))
1186 "only integers can be converted to English ordinals"))
1188 ((< n 0) (string-append "minus " (format:num->ordinal (- n))))
1190 (let ((hundreds (quotient n 100))
1191 (tens+ones (remainder n 100)))
1195 (format:num->cardinal (* hundreds 100))
1196 (if (= tens+ones 0) "th" " "))
1198 (if (= tens+ones 0) ""
1199 (if (< tens+ones 20)
1200 (list-ref format:ordinal-ones-list tens+ones)
1201 (let ((tens (quotient tens+ones 10))
1202 (ones (remainder tens+ones 10)))
1204 (list-ref format:ordinal-tens-list tens)
1206 (list-ref format:cardinal-tens-list tens)
1208 (list-ref format:ordinal-ones-list ones))))
1211 ;; format fixed flonums (~F)
1213 (define (format:out-fixed modifier number pars)
1214 (if (not (or (number? number) (string? number)))
1215 (format:error "argument is not a number or a number string"))
1217 (let ((l (length pars)))
1218 (let ((width (format:par pars l 0 #f "width"))
1219 (digits (format:par pars l 1 #f "digits"))
1220 (scale (format:par pars l 2 0 #f))
1221 (overch (format:par pars l 3 #f #f))
1222 (padch (format:par pars l 4 format:space-ch #f)))
1226 (begin ; fixed precision
1228 (if (string? number) number (number->string number)) #t scale)
1229 (if (<= (- format:fn-len format:fn-dot) digits)
1230 (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
1231 (format:fn-round digits))
1233 (let ((numlen (+ format:fn-len 1)))
1234 (if (or (not format:fn-pos?) (eq? modifier 'at))
1235 (set! numlen (+ numlen 1)))
1236 (if (and (= format:fn-dot 0) (> width (+ digits 1)))
1237 (set! numlen (+ numlen 1)))
1238 (if (< numlen width)
1239 (format:out-fill (- width numlen) (integer->char padch)))
1240 (if (and overch (> numlen width))
1241 (format:out-fill width (integer->char overch))
1242 (format:fn-out modifier (> width (+ digits 1)))))
1243 (format:fn-out modifier #t)))
1245 (begin ; free precision
1247 (if (string? number) number (number->string number)) #t scale)
1250 (let ((numlen (+ format:fn-len 1)))
1251 (if (or (not format:fn-pos?) (eq? modifier 'at))
1252 (set! numlen (+ numlen 1)))
1253 (if (= format:fn-dot 0)
1254 (set! numlen (+ numlen 1)))
1255 (if (< numlen width)
1256 (format:out-fill (- width numlen) (integer->char padch)))
1257 (if (> numlen width) ; adjust precision if possible
1258 (let ((dot-index (- numlen
1259 (- format:fn-len format:fn-dot))))
1260 (if (> dot-index width)
1261 (if overch ; numstr too big for required width
1262 (format:out-fill width (integer->char overch))
1263 (format:fn-out modifier #t))
1265 (format:fn-round (- width dot-index))
1266 (format:fn-out modifier #t))))
1267 (format:fn-out modifier #t)))
1268 (format:fn-out modifier #t)))))))
1270 ;; format exponential flonums (~E)
1272 (define (format:out-expon modifier number pars)
1273 (if (not (or (number? number) (string? number)))
1274 (format:error "argument is not a number"))
1276 (let ((l (length pars)))
1277 (let ((width (format:par pars l 0 #f "width"))
1278 (digits (format:par pars l 1 #f "digits"))
1279 (edigits (format:par pars l 2 #f "exponent digits"))
1280 (scale (format:par pars l 3 1 #f))
1281 (overch (format:par pars l 4 #f #f))
1282 (padch (format:par pars l 5 format:space-ch #f))
1283 (expch (format:par pars l 6 #f #f)))
1285 (if digits ; fixed precision
1287 (let ((digits (if (> scale 0)
1288 (if (< scale (+ digits 2))
1289 (+ (- digits scale) 1)
1293 (if (string? number) number (number->string number)) #f scale)
1294 (if (<= (- format:fn-len format:fn-dot) digits)
1295 (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
1296 (format:fn-round digits))
1298 (if (and edigits overch (> format:en-len edigits))
1299 (format:out-fill width (integer->char overch))
1300 (let ((numlen (+ format:fn-len 3))) ; .E+
1301 (if (or (not format:fn-pos?) (eq? modifier 'at))
1302 (set! numlen (+ numlen 1)))
1303 (if (and (= format:fn-dot 0) (> width (+ digits 1)))
1304 (set! numlen (+ numlen 1)))
1307 (if (and edigits (>= edigits format:en-len))
1310 (if (< numlen width)
1311 (format:out-fill (- width numlen)
1312 (integer->char padch)))
1313 (if (and overch (> numlen width))
1314 (format:out-fill width (integer->char overch))
1316 (format:fn-out modifier (> width (- numlen 1)))
1317 (format:en-out edigits expch)))))
1319 (format:fn-out modifier #t)
1320 (format:en-out edigits expch))))
1322 (begin ; free precision
1324 (if (string? number) number (number->string number)) #f scale)
1327 (if (and edigits overch (> format:en-len edigits))
1328 (format:out-fill width (integer->char overch))
1329 (let ((numlen (+ format:fn-len 3))) ; .E+
1330 (if (or (not format:fn-pos?) (eq? modifier 'at))
1331 (set! numlen (+ numlen 1)))
1332 (if (= format:fn-dot 0)
1333 (set! numlen (+ numlen 1)))
1336 (if (and edigits (>= edigits format:en-len))
1339 (if (< numlen width)
1340 (format:out-fill (- width numlen)
1341 (integer->char padch)))
1342 (if (> numlen width) ; adjust precision if possible
1343 (let ((f (- format:fn-len format:fn-dot))) ; fract len
1344 (if (> (- numlen f) width)
1345 (if overch ; numstr too big for required width
1346 (format:out-fill width
1347 (integer->char overch))
1349 (format:fn-out modifier #t)
1350 (format:en-out edigits expch)))
1352 (format:fn-round (+ (- f numlen) width))
1353 (format:fn-out modifier #t)
1354 (format:en-out edigits expch))))
1356 (format:fn-out modifier #t)
1357 (format:en-out edigits expch)))))
1359 (format:fn-out modifier #t)
1360 (format:en-out edigits expch))))))))
1362 ;; format general flonums (~G)
1364 (define (format:out-general modifier number pars)
1365 (if (not (or (number? number) (string? number)))
1366 (format:error "argument is not a number or a number string"))
1368 (let ((l (length pars)))
1369 (let ((width (if (> l 0) (list-ref pars 0) #f))
1370 (digits (if (> l 1) (list-ref pars 1) #f))
1371 (edigits (if (> l 2) (list-ref pars 2) #f))
1372 (overch (if (> l 4) (list-ref pars 4) #f))
1373 (padch (if (> l 5) (list-ref pars 5) #f)))
1375 (if (string? number) number (number->string number)) #t 0)
1377 (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm
1378 (ww (if width (- width ee) #f)) ; see Steele's CL book p.395
1379 (n (if (= format:fn-dot 0) ; number less than (abs 1.0) ?
1380 (- (format:fn-zlead))
1384 (max format:fn-len (min n 7)))) ; q = format:fn-len
1388 (format:out-fixed modifier number (list ww dd #f overch padch))
1389 (format:out-fill ee #\space)) ;~@T not implemented yet
1390 (format:out-expon modifier number pars))))))
1392 ;; format dollar flonums (~$)
1394 (define (format:out-dollar modifier number pars)
1395 (if (not (or (number? number) (string? number)))
1396 (format:error "argument is not a number or a number string"))
1398 (let ((l (length pars)))
1399 (let ((digits (format:par pars l 0 2 "digits"))
1400 (mindig (format:par pars l 1 1 "mindig"))
1401 (width (format:par pars l 2 0 "width"))
1402 (padch (format:par pars l 3 format:space-ch #f)))
1405 (if (string? number) number (number->string number)) #t 0)
1406 (if (<= (- format:fn-len format:fn-dot) digits)
1407 (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
1408 (format:fn-round digits))
1409 (let ((numlen (+ format:fn-len 1)))
1410 (if (or (not format:fn-pos?) (memq modifier '(at colon-at)))
1411 (set! numlen (+ numlen 1)))
1412 (if (and mindig (> mindig format:fn-dot))
1413 (set! numlen (+ numlen (- mindig format:fn-dot))))
1414 (if (and (= format:fn-dot 0) (not mindig))
1415 (set! numlen (+ numlen 1)))
1416 (if (< numlen width)
1419 (if (not format:fn-pos?)
1420 (format:out-char #\-))
1421 (format:out-fill (- width numlen) (integer->char padch)))
1423 (format:out-fill (- width numlen) (integer->char padch))
1424 (format:out-char (if format:fn-pos? #\+ #\-)))
1426 (format:out-char (if format:fn-pos? #\+ #\-))
1427 (format:out-fill (- width numlen) (integer->char padch)))
1429 (format:out-fill (- width numlen) (integer->char padch))
1430 (if (not format:fn-pos?)
1431 (format:out-char #\-))))
1433 (if (memq modifier '(at colon-at)) (format:out-char #\+))
1434 (format:out-char #\-))))
1435 (if (and mindig (> mindig format:fn-dot))
1436 (format:out-fill (- mindig format:fn-dot) #\0))
1437 (if (and (= format:fn-dot 0) (not mindig))
1438 (format:out-char #\0))
1439 (format:out-substr format:fn-str 0 format:fn-dot)
1440 (format:out-char #\.)
1441 (format:out-substr format:fn-str format:fn-dot format:fn-len))))
1443 ; the flonum buffers
1445 (define format:fn-max 200) ; max. number of number digits
1446 (define format:fn-str (make-string format:fn-max)) ; number buffer
1447 (define format:fn-len 0) ; digit length of number
1448 (define format:fn-dot #f) ; dot position of number
1449 (define format:fn-pos? #t) ; number positive?
1450 (define format:en-max 10) ; max. number of exponent digits
1451 (define format:en-str (make-string format:en-max)) ; exponent buffer
1452 (define format:en-len 0) ; digit length of exponent
1453 (define format:en-pos? #t) ; exponent positive?
1455 (define (format:parse-float num-str fixed? scale)
1456 (set! format:fn-pos? #t)
1457 (set! format:fn-len 0)
1458 (set! format:fn-dot #f)
1459 (set! format:en-pos? #t)
1460 (set! format:en-len 0)
1465 (num-len (string-length num-str))
1466 (c #f)) ; current exam. character in num-str
1468 (if (not format:fn-dot)
1469 (set! format:fn-dot format:fn-len))
1474 (set! format:fn-dot 0)
1475 (set! format:fn-len 1)))
1477 ;; now format the parsed values according to format's need
1481 (begin ; fixed format m.nnn or .nnn
1482 (if (and (> left-zeros 0) (> format:fn-dot 0))
1483 (if (> format:fn-dot left-zeros)
1484 (begin ; norm 0{0}nn.mm to nn.mm
1485 (format:fn-shiftleft left-zeros)
1487 (set! format:fn-dot (- format:fn-dot left-zeros)))
1488 (begin ; normalize 0{0}.nnn to .nnn
1489 (format:fn-shiftleft format:fn-dot)
1490 (set! left-zeros (- left-zeros format:fn-dot))
1491 (set! format:fn-dot 0))))
1492 (if (or (not (= scale 0)) (> format:en-len 0))
1493 (let ((shift (+ scale (format:en-int))))
1496 ((> (+ format:fn-dot shift) format:fn-len)
1498 #f (- shift (- format:fn-len format:fn-dot)))
1499 (set! format:fn-dot format:fn-len))
1500 ((< (+ format:fn-dot shift) 0)
1501 (format:fn-zfill #t (- (- shift) format:fn-dot))
1502 (set! format:fn-dot 0))
1504 (if (> left-zeros 0)
1505 (if (<= left-zeros shift) ; shift always > 0 here
1506 (format:fn-shiftleft shift) ; shift out 0s
1508 (format:fn-shiftleft left-zeros)
1509 (set! format:fn-dot (- shift left-zeros))))
1510 (set! format:fn-dot (+ format:fn-dot shift))))))))
1512 (let ((negexp ; expon format m.nnnEee
1513 (if (> left-zeros 0)
1514 (- left-zeros format:fn-dot -1)
1515 (if (= format:fn-dot 0) 1 0))))
1516 (if (> left-zeros 0)
1517 (begin ; normalize 0{0}.nnn to n.nn
1518 (format:fn-shiftleft left-zeros)
1519 (set! format:fn-dot 1))
1520 (if (= format:fn-dot 0)
1521 (set! format:fn-dot 1)))
1522 (format:en-set (- (+ (- format:fn-dot scale) (format:en-int))
1527 (set! format:fn-dot 1))
1528 ((< scale 0) ; leading zero
1529 (format:fn-zfill #t (- scale))
1530 (set! format:fn-dot 0))
1531 ((> scale format:fn-dot)
1532 (format:fn-zfill #f (- scale format:fn-dot))
1533 (set! format:fn-dot scale))
1535 (set! format:fn-dot scale)))))
1539 (set! c (string-ref num-str i)) ; parse the output of number->string
1540 (cond ; which can be any valid number
1541 ((char-numeric? c) ; representation of R4RS except
1542 (if mantissa? ; complex numbers
1546 (set! left-zeros (+ left-zeros 1)))
1548 (set! all-zeros? #f)))
1549 (string-set! format:fn-str format:fn-len c)
1550 (set! format:fn-len (+ format:fn-len 1)))
1552 (string-set! format:en-str format:en-len c)
1553 (set! format:en-len (+ format:en-len 1)))))
1554 ((or (char=? c #\-) (char=? c #\+))
1556 (set! format:fn-pos? (char=? c #\+))
1557 (set! format:en-pos? (char=? c #\+))))
1559 (set! format:fn-dot format:fn-len))
1561 (set! mantissa? #f))
1563 (set! mantissa? #f))
1564 ((char-whitespace? c) #t)
1565 ((char=? c #\d) #t) ; decimal radix prefix
1568 (format:error "illegal character `~c' in number->string" c)))))
1570 (define (format:en-int) ; convert exponent string to integer
1571 (if (= format:en-len 0)
1575 ((= i format:en-len)
1579 (set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i))
1580 format:zero-ch))))))
1582 (define (format:en-set en) ; set exponent string number
1583 (set! format:en-len 0)
1584 (set! format:en-pos? (>= en 0))
1585 (let ((en-str (number->string en)))
1587 (en-len (string-length en-str))
1590 (set! c (string-ref en-str i))
1591 (if (char-numeric? c)
1593 (string-set! format:en-str format:en-len c)
1594 (set! format:en-len (+ format:en-len 1)))))))
1596 (define (format:fn-zfill left? n) ; fill current number string with 0s
1597 (if (> (+ n format:fn-len) format:fn-max) ; from the left or right
1598 (format:error "number is too long to format (enlarge format:fn-max)"))
1599 (set! format:fn-len (+ format:fn-len n))
1601 (do ((i format:fn-len (- i 1))) ; fill n 0s to left
1603 (string-set! format:fn-str i
1606 (string-ref format:fn-str (- i n)))))
1607 (do ((i (- format:fn-len n) (+ i 1))) ; fill n 0s to the right
1608 ((= i format:fn-len))
1609 (string-set! format:fn-str i #\0))))
1611 (define (format:fn-shiftleft n) ; shift left current number n positions
1612 (if (> n format:fn-len)
1613 (format:error "internal error in format:fn-shiftleft (~d,~d)"
1616 ((= i format:fn-len)
1617 (set! format:fn-len (- format:fn-len n)))
1618 (string-set! format:fn-str (- i n) (string-ref format:fn-str i))))
1620 (define (format:fn-round digits) ; round format:fn-str
1621 (set! digits (+ digits format:fn-dot))
1622 (do ((i digits (- i 1)) ; "099",2 -> "10"
1623 (c 5)) ; "023",2 -> "02"
1624 ((or (= c 0) (< i 0)) ; "999",2 -> "100"
1625 (if (= c 1) ; "005",2 -> "01"
1626 (begin ; carry overflow
1627 (set! format:fn-len digits)
1628 (format:fn-zfill #t 1) ; add a 1 before fn-str
1629 (string-set! format:fn-str 0 #\1)
1630 (set! format:fn-dot (+ format:fn-dot 1)))
1631 (set! format:fn-len digits)))
1632 (set! c (+ (- (char->integer (string-ref format:fn-str i))
1634 (string-set! format:fn-str i (integer->char
1636 (+ c format:zero-ch)
1637 (+ (- c 10) format:zero-ch))))
1638 (set! c (if (< c 10) 0 1))))
1640 (define (format:fn-out modifier add-leading-zero?)
1642 (if (eq? modifier 'at)
1643 (format:out-char #\+))
1644 (format:out-char #\-))
1645 (if (= format:fn-dot 0)
1646 (if add-leading-zero?
1647 (format:out-char #\0))
1648 (format:out-substr format:fn-str 0 format:fn-dot))
1649 (format:out-char #\.)
1650 (format:out-substr format:fn-str format:fn-dot format:fn-len))
1652 (define (format:en-out edigits expch)
1653 (format:out-char (if expch (integer->char expch) format:expch))
1654 (format:out-char (if format:en-pos? #\+ #\-))
1656 (if (< format:en-len edigits)
1657 (format:out-fill (- edigits format:en-len) #\0)))
1658 (format:out-substr format:en-str 0 format:en-len))
1660 (define (format:fn-strip) ; strip trailing zeros but one
1661 (string-set! format:fn-str format:fn-len #\0)
1662 (do ((i format:fn-len (- i 1)))
1663 ((or (not (char=? (string-ref format:fn-str i) #\0))
1664 (<= i format:fn-dot))
1665 (set! format:fn-len (+ i 1)))))
1667 (define (format:fn-zlead) ; count leading zeros
1669 ((or (= i format:fn-len)
1670 (not (char=? (string-ref format:fn-str i) #\0)))
1671 (if (= i format:fn-len) ; found a real zero
1676 ;;; some global functions not found in SLIB
1678 ;; string-index finds the index of the first occurence of the character `c'
1679 ;; in the string `s'; it returns #f if there is no such character in `s'.
1681 (define (string-index s c)
1682 (let ((slen-1 (- (string-length s) 1)))
1685 ((char=? c (string-ref s i)) i)
1687 (else (loop (+ i 1)))))))
1689 (define (string-capitalize-first str) ; "hello" -> "Hello"
1690 (let ((cap-str (string-copy str)) ; "hELLO" -> "Hello"
1691 (non-first-alpha #f) ; "*hello" -> "*Hello"
1692 (str-len (string-length str))) ; "hello you" -> "Hello you"
1694 ((= i str-len) cap-str)
1695 (let ((c (string-ref str i)))
1696 (if (char-alphabetic? c)
1698 (string-set! cap-str i (char-downcase c))
1700 (set! non-first-alpha #t)
1701 (string-set! cap-str i (char-upcase c)))))))))
1703 (define (list-head l k)
1706 (cons (car l) (list-head (cdr l) (- k 1)))))
1709 ;; Aborts the program when a formatting error occures. This is a null
1710 ;; argument closure to jump to the interpreters toplevel continuation.
1712 (define format:abort (lambda () (error "error in format")))
1714 (define format format:format)
1715 ;; Thanks to Shuji Narazaki
1716 (module-set! the-root-module 'format format)
1718 ;; If this is not possible then a continuation is used to recover
1719 ;; properly from a format error. In this case format returns #f.
1721 ;(define format:abort
1722 ; (lambda () (format:error-continuation #f)))
1725 ; (lambda args ; wraps format:format with an error
1726 ; (call-with-current-continuation ; continuation
1728 ; (set! format:error-continuation cont)
1729 ; (apply format:format args)))))