FM / ice-9

/usr/share/guile/2.0/ice-9

Name	Size	Mode	Actions
and-let-star.scm	2593	0644	edit dl rm
binary-ports.scm	1921	0644	edit dl rm
boot-9.scm	154720	0644	edit dl rm
buffered-input.scm	4935	0644	edit dl rm
calling.scm	10790	0644	edit dl rm
channel.scm	5312	0644	edit dl rm
command-line.scm	18655	0644	edit dl rm
common-list.scm	9160	0644	edit dl rm
control.scm	4036	0644	edit dl rm
curried-definitions.scm	1829	0644	edit dl rm
debug.scm	1114	0644	edit dl rm
deprecated.scm	31993	0644	edit dl rm
documentation.scm	7432	0644	edit dl rm
eval-string.scm	2997	0644	edit dl rm
eval.scm	21354	0644	edit dl rm
expect.scm	5628	0644	edit dl rm
format.scm	76284	0644	edit dl rm
ftw.scm	24753	0644	edit dl rm
futures.scm	11186	0644	edit dl rm
gap-buffer.scm	10384	0644	edit dl rm
getopt-long.scm	16888	0644	edit dl rm
hash-table.scm	1813	0644	edit dl rm
hcons.scm	2614	0644	edit dl rm
history.scm	2343	0644	edit dl rm
i18n.scm	17778	0644	edit dl rm
iconv.scm	3735	0644	edit dl rm
lineio.scm	3941	0644	edit dl rm
list.scm	1319	0644	edit dl rm
local-eval.scm	9946	0644	edit dl rm
ls.scm	3275	0644	edit dl rm
mapping.scm	4955	0644	edit dl rm
match.scm	2045	0644	edit dl rm
match.upstream.scm	36459	0644	edit dl rm
networking.scm	3407	0644	edit dl rm
null.scm	1157	0644	edit dl rm
occam-channel.scm	7436	0644	edit dl rm
optargs.scm	16123	0644	edit dl rm
poe.scm	3382	0644	edit dl rm
poll.scm	6166	0644	edit dl rm
popen.scm	5806	0644	edit dl rm
posix.scm	2793	0644	edit dl rm
pretty-print.scm	16211	0644	edit dl rm
psyntax-pp.scm	166774	0644	edit dl rm
psyntax.scm	147118	0644	edit dl rm
q.scm	4297	0644	edit dl rm
quasisyntax.scm	5348	0644	edit dl rm
r4rs.scm	9645	0644	edit dl rm
r5rs.scm	1602	0644	edit dl rm
r6rs-libraries.scm	9164	0644	edit dl rm
rdelim.scm	7648	0644	edit dl rm
readline.scm	9786	0644	edit dl rm
receive.scm	1082	0644	edit dl rm
regex.scm	9084	0644	edit dl rm
runq.scm	8379	0644	edit dl rm
rw.scm	1047	0644	edit dl rm
safe-r5rs.scm	3814	0644	edit dl rm
safe.scm	1275	0644	edit dl rm
save-stack.scm	2197	0644	edit dl rm
scm-style-repl.scm	11986	0644	edit dl rm
serialize.scm	3859	0644	edit dl rm
session.scm	18143	0644	edit dl rm
slib.scm	1583	0644	edit dl rm
stack-catch.scm	1983	0644	edit dl rm
streams.scm	7488	0644	edit dl rm
string-fun.scm	8798	0644	edit dl rm
syncase.scm	1556	0644	edit dl rm
threads.scm	6388	0644	edit dl rm
time.scm	2088	0644	edit dl rm
top-repl.scm	2812	0644	edit dl rm
unicode.scm	1005	0644	edit dl rm
vlist.scm	22081	0644	edit dl rm
weak-vector.scm	1288	0644	edit dl rm

Edit: /usr/share/guile/2.0/ice-9/format.scm (76284B)

;;;; "format.scm" Common LISP text output formatter for SLIB
;;; 	Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;; 
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;; 
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;

;;; This code was orignally in the public domain.
;;;
;;; Written 1992-1994 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de).
;;;
;;; Authors of the version from SLIB (< 1.4) were Ken Dickey and Aubrey
;;; Jaffer.
;;;
;;; Assimilated into Guile May 1999.
;;;
;;; Please don't bother the original authors with bug reports, though;
;;; send them to bug-guile@gnu.org.
;;;

(define-module (ice-9 format)
  #:autoload (ice-9 pretty-print) (pretty-print truncated-print)
  #:autoload (ice-9 i18n)         (%global-locale number->locale-string)
  #:replace (format))

(define format:version "3.0")

(define (format destination format-string . format-args)
  (if (not (string? format-string))
      (error "format: expected a string for format string" format-string))

(let* ((port
          (cond
           ((not destination)
            ;; Use a Unicode-capable output string port.
            (with-fluids ((%default-port-encoding "UTF-8"))
              (open-output-string)))
           ((boolean? destination) (current-output-port)) ; boolean but not false
           ((output-port? destination) destination)
           ((number? destination)
            (issue-deprecation-warning
             "Passing a number to format as the port is deprecated."
             "Pass (current-error-port) instead.")
            (current-error-port))
           (else
            (error "format: bad destination `~a'" destination))))

(output-col (or (port-column port) 0))

(flush-output? #f))

(define format:case-conversion #f)
    (define format:pos 0)        ; curr. format string parsing position
    (define format:arg-pos 0)    ; curr. format argument position
					; this is global for error presentation
       
    ;; format string and char output routines on port

(define (format:out-str str)
      (if format:case-conversion
          (display (format:case-conversion str) port)
          (display str port))
      (set! output-col
            (+ output-col (string-length str))))

(define (format:out-char ch)
      (if format:case-conversion
          (display (format:case-conversion (string ch))
                   port)
          (write-char ch port))
      (set! output-col
            (if (char=? ch #\newline)
                0
                (+ output-col 1))))
       
    ;;(define (format:out-substr str i n)  ; this allocates a new string
    ;;  (display (substring str i n) port)
    ;;  (set! output-col (+ output-col n)))

(define (format:out-substr str i n)
      (do ((k i (+ k 1)))
          ((= k n))
        (write-char (string-ref str k) port))
      (set! output-col (+ output-col (- n i))))

;;(define (format:out-fill n ch)       ; this allocates a new string
    ;;  (format:out-str (make-string n ch)))

(define (format:out-fill n ch)
      (do ((i 0 (+ i 1)))
          ((= i n))
        (write-char ch port))
      (set! output-col (+ output-col n)))

;; format's user error handler

(define (format:error . args)       ; never returns!
      (let ((port (current-error-port)))
        (set! format:error format:intern-error)
        (if (not (zero? format:arg-pos))
            (set! format:arg-pos (- format:arg-pos 1)))
        (format port
                "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~
                                  ~{~a ~}===>~{~a ~})~%        "
                destination
                (substring format-string 0 format:pos)
                (substring format-string format:pos
                           (string-length format-string))
                (list-head format-args format:arg-pos)
                (list-tail format-args format:arg-pos))
        (apply format port args)
        (newline port)
        (set! format:error format:error-save)
        (format:abort)))

(define (format:intern-error . args)
      ;;if something goes wrong in format:error
      (display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline)
      (display "        destination: ") (write destination) (newline)
      (display "        format string: ") (write format-string) (newline)
      (display "        format args: ") (write format-args) (newline)
      (display "        error args:  ") (write args) (newline)
      (set! format:error format:error-save)
      (format:abort))
	      
    (define format:error-save format:error)
  
    (define format:parameter-characters
      '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\'))

(define (format:format-work format-string arglist) ; does the formatting work
      (letrec
          ((format-string-len (string-length format-string))
           (arg-pos 0)               ; argument position in arglist
           (arg-len (length arglist))   ; number of arguments
           (modifier #f)                ; 'colon | 'at | 'colon-at | #f
           (params '())                 ; directive parameter list
           (param-value-found #f)       ; a directive
					; parameter value
					; found
           (conditional-nest 0)         ; conditional nesting level
           (clause-pos 0)               ; last cond. clause
					; beginning char pos
           (clause-default #f)		; conditional default
					; clause string
           (clauses '())                ; conditional clause
					; string list
           (conditional-type #f)        ; reflects the
					; contional modifiers
           (conditional-arg #f)      ; argument to apply the conditional
           (iteration-nest 0)        ; iteration nesting level
           (iteration-pos 0)         ; iteration string
					; beginning char pos
           (iteration-type #f)		; reflects the
					; iteration modifiers
           (max-iterations #f)		; maximum number of
					; iterations
           (recursive-pos-save format:pos)
	       
           (next-char			; gets the next char
					; from format-string
            (lambda ()
              (let ((ch (peek-next-char)))
                (set! format:pos (+ 1 format:pos))
                ch)))
	       
           (peek-next-char
            (lambda ()
              (if (>= format:pos format-string-len)
                  (format:error "illegal format string")
                  (string-ref format-string format:pos))))
	       
           (one-positive-integer?
            (lambda (params)
              (cond
               ((null? params) #f)
               ((and (integer? (car params))
                     (>= (car params) 0)
                     (= (length params) 1)) #t)
               (else
                (format:error
                 "one positive integer parameter expected")))))
	       
           (next-arg
            (lambda ()
              (if (>= arg-pos arg-len)
                  (begin
                    (set! format:arg-pos (+ arg-len 1))
                    (format:error "missing argument(s)")))
              (add-arg-pos 1)
              (list-ref arglist (- arg-pos 1))))
	       
           (prev-arg
            (lambda ()
              (add-arg-pos -1)
              (if (negative? arg-pos)
                  (format:error "missing backward argument(s)"))
              (list-ref arglist arg-pos)))
	       
           (rest-args
            (lambda ()
              (let loop ((l arglist) (k arg-pos)) ; list-tail definition
                (if (= k 0) l (loop (cdr l) (- k 1))))))
	       
           (add-arg-pos
            (lambda (n) 
              (set! arg-pos (+ n arg-pos))
              (set! format:arg-pos arg-pos)))
	       
           (anychar-dispatch		; dispatches the format-string
            (lambda ()
              (if (>= format:pos format-string-len)
                  arg-pos               ; used for ~? continuance
                  (let ((char (next-char)))
                    (cond
                     ((char=? char #\~)
                      (set! modifier #f)
                      (set! params '())
                      (set! param-value-found #f)
                      (tilde-dispatch))
                     (else
                      (if (and (zero? conditional-nest)
                               (zero? iteration-nest))
                          (format:out-char char))
                      (anychar-dispatch)))))))
	       
           (tilde-dispatch
            (lambda ()
              (cond
               ((>= format:pos format-string-len)
                (format:out-str "~")	; tilde at end of
					; string is just
					; output
                arg-pos)                ; used for ~?
					; continuance
               ((and (or (zero? conditional-nest)
                         (memv (peek-next-char) ; find conditional
					; directives
                               (append '(#\[ #\] #\; #\: #\@ #\^)
                                       format:parameter-characters)))
                     (or (zero? iteration-nest)
                         (memv (peek-next-char) ; find iteration
					; directives
                               (append '(#\{ #\} #\: #\@ #\^)
                                       format:parameter-characters))))
                (case (char-upcase (next-char))
		      
                  ;; format directives
		      
                  ((#\A)                ; Any -- for humans
                   (set! format:read-proof
                         (memq modifier '(colon colon-at)))
                   (format:out-obj-padded (memq modifier '(at colon-at))
                                          (next-arg) #f params)
                   (anychar-dispatch))
                  ((#\S)                ; Slashified -- for parsers
                   (set! format:read-proof
                         (memq modifier '(colon colon-at)))
                   (format:out-obj-padded (memq modifier '(at colon-at))
                                          (next-arg) #t params)
                   (anychar-dispatch))
                  ((#\D)                ; Decimal
                   (format:out-num-padded modifier (next-arg) params 10)
                   (anychar-dispatch))
                  ((#\H)                ; Localized number
                   (let* ((num      (next-arg))
                          (locale   (case modifier
                                      ((colon) (next-arg))
                                      (else    %global-locale)))
                          (argc     (length params))
                          (width    (format:par params argc 0 #f "width"))
                          (decimals (format:par params argc 1 #t "decimals"))
                          (padchar  (integer->char
                                     (format:par params argc 2 format:space-ch
                                                 "padchar")))
                          (str      (number->locale-string num decimals
                                                           locale)))
                     (format:out-str (if (and width
                                              (< (string-length str) width))
                                         (string-pad str width padchar)
                                         str)))
                   (anychar-dispatch))
                  ((#\X)                ; Hexadecimal
                   (format:out-num-padded modifier (next-arg) params 16)
                   (anychar-dispatch))
                  ((#\O)                ; Octal
                   (format:out-num-padded modifier (next-arg) params 8)
                   (anychar-dispatch))
                  ((#\B)                ; Binary
                   (format:out-num-padded modifier (next-arg) params 2)
                   (anychar-dispatch))
                  ((#\R)
                   (if (null? params)
                       (format:out-obj-padded ; Roman, cardinal,
					; ordinal numerals
                        #f
                        ((case modifier
                           ((at) format:num->roman)
                           ((colon-at) format:num->old-roman)
                           ((colon) format:num->ordinal)
                           (else format:num->cardinal))
                         (next-arg))
                        #f params)
                       (format:out-num-padded ; any Radix
                        modifier (next-arg) (cdr params) (car params)))
                   (anychar-dispatch))
                  ((#\F)                ; Fixed-format floating-point
                   (format:out-fixed modifier (next-arg) params)
                   (anychar-dispatch))
                  ((#\E)                ; Exponential floating-point
                   (format:out-expon modifier (next-arg) params)
                   (anychar-dispatch))
                  ((#\G)                ; General floating-point
                   (format:out-general modifier (next-arg) params)
                   (anychar-dispatch))
                  ((#\$)                ; Dollars floating-point
                   (format:out-dollar modifier (next-arg) params)
                   (anychar-dispatch))
                  ((#\I)                ; Complex numbers
                   (let ((z (next-arg)))
                     (if (not (complex? z))
                         (format:error "argument not a complex number"))
                     (format:out-fixed modifier (real-part z) params)
                     (format:out-fixed 'at (imag-part z) params)
                     (format:out-char #\i))
                   (anychar-dispatch))
                  ((#\C)                ; Character
                   (let ((ch (if (one-positive-integer? params)
                                 (integer->char (car params))
                                 (next-arg))))
                     (if (not (char? ch))
                         (format:error "~~c expects a character"))
                     (case modifier
                       ((at)
                        (format:out-str (object->string ch)))
                       ((colon)
                        (let ((c (char->integer ch)))
                          (if (< c 0)
                              (set! c (+ c 256))) ; compensate
					; complement
					; impl.
                          (cond
                           ((< c #x20)	; assumes that control
					; chars are < #x20
                            (format:out-char #\^)
                            (format:out-char
                             (integer->char (+ c #x40))))
                           ((>= c #x7f)
                            (format:out-str "#\\")
                            (format:out-str
                             (number->string c 8)))
                           (else
                            (format:out-char ch)))))
                       (else (format:out-char ch))))
                   (anychar-dispatch))
                  ((#\P)                ; Plural
                   (if (memq modifier '(colon colon-at))
                       (prev-arg))
                   (let ((arg (next-arg)))
                     (if (not (number? arg))
                         (format:error "~~p expects a number argument"))
                     (if (= arg 1)
                         (if (memq modifier '(at colon-at))
                             (format:out-char #\y))
                         (if (memq modifier '(at colon-at))
                             (format:out-str "ies")
                             (format:out-char #\s))))
                   (anychar-dispatch))
                  ((#\~)                ; Tilde
                   (if (one-positive-integer? params)
                       (format:out-fill (car params) #\~)
                       (format:out-char #\~))
                   (anychar-dispatch))
                  ((#\%)                ; Newline
                   (if (one-positive-integer? params)
                       (format:out-fill (car params) #\newline)
                       (format:out-char #\newline))
                   (set! output-col 0)
                   (anychar-dispatch))
                  ((#\&)                ; Fresh line
                   (if (one-positive-integer? params)
                       (begin
                         (if (> (car params) 0)
                             (format:out-fill (- (car params)
                                                 (if (>
                                                      output-col
                                                      0) 0 1))
                                              #\newline))
                         (set! output-col 0))
                       (if (> output-col 0)
                           (format:out-char #\newline)))
                   (anychar-dispatch))
                  ((#\_)                ; Space character
                   (if (one-positive-integer? params)
                       (format:out-fill (car params) #\space)
                       (format:out-char #\space))
                   (anychar-dispatch))
                  ((#\/)                ; Tabulator character
                   (if (one-positive-integer? params)
                       (format:out-fill (car params) #\tab)
                       (format:out-char #\tab))
                   (anychar-dispatch))
                  ((#\|)                ; Page seperator
                   (if (one-positive-integer? params)
                       (format:out-fill (car params) #\page)
                       (format:out-char #\page))
                   (set! output-col 0)
                   (anychar-dispatch))
                  ((#\T)                ; Tabulate
                   (format:tabulate modifier params)
                   (anychar-dispatch))
                  ((#\Y)                ; Structured print
                   (let ((width (if (one-positive-integer? params)
                                    (car params)
                                    79)))
                     (case modifier
                       ((at)
                        (format:out-str
                         (call-with-output-string
                           (lambda (p)
                             (truncated-print (next-arg) p
                                              #:width width)))))
                       ((colon-at)
                        (format:out-str
                         (call-with-output-string
                           (lambda (p)
                             (truncated-print (next-arg) p
                                              #:width
                                              (max (- width
                                                      output-col)
                                                   1))))))
                       ((colon)
                        (format:error "illegal modifier in ~~?"))
                       (else
                        (pretty-print (next-arg) port
                                      #:width width)
                        (set! output-col 0))))
                   (anychar-dispatch))
                  ((#\? #\K)         ; Indirection (is "~K" in T-Scheme)
                   (cond
                    ((memq modifier '(colon colon-at))
                     (format:error "illegal modifier in ~~?"))
                    ((eq? modifier 'at)
                     (let* ((frmt (next-arg))
                            (args (rest-args)))
                       (add-arg-pos (format:format-work frmt args))))
                    (else
                     (let* ((frmt (next-arg))
                            (args (next-arg)))
                       (format:format-work frmt args))))
                   (anychar-dispatch))
                  ((#\!)                ; Flush output
                   (set! flush-output? #t)
                   (anychar-dispatch))
                  ((#\newline)		; Continuation lines
                   (if (eq? modifier 'at)
                       (format:out-char #\newline))
                   (if (< format:pos format-string-len)
                       (do ((ch (peek-next-char) (peek-next-char)))
                           ((or (not (char-whitespace? ch))
                                (= format:pos (- format-string-len 1))))
                         (if (eq? modifier 'colon)
                             (format:out-char (next-char))
                             (next-char))))
                   (anychar-dispatch))
                  ((#\*)                ; Argument jumping
                   (case modifier
                     ((colon)		; jump backwards
                      (if (one-positive-integer? params)
                          (do ((i 0 (+ i 1)))
                              ((= i (car params)))
                            (prev-arg))
                          (prev-arg)))
                     ((at)              ; jump absolute
                      (set! arg-pos (if (one-positive-integer? params)
                                        (car params) 0)))
                     ((colon-at)
                      (format:error "illegal modifier `:@' in ~~* directive"))
                     (else              ; jump forward
                      (if (one-positive-integer? params)
                          (do ((i 0 (+ i 1)))
                              ((= i (car params)))
                            (next-arg))
                          (next-arg))))
                   (anychar-dispatch))
                  ((#$)                ; Case conversion begin
                   (set! format:case-conversion
                         (case modifier
                           ((at) string-capitalize-first)
                           ((colon) string-capitalize)
                           ((colon-at) string-upcase)
                           (else string-downcase)))
                   (anychar-dispatch))
                  ((#$)                ; Case conversion end
                   (if (not format:case-conversion)
                       (format:error "missing ~~("))
                   (set! format:case-conversion #f)
                   (anychar-dispatch))
                  ((#\[)                ; Conditional begin
                   (set! conditional-nest (+ conditional-nest 1))
                   (cond
                    ((= conditional-nest 1)
                     (set! clause-pos format:pos)
                     (set! clause-default #f)
                     (set! clauses '())
                     (set! conditional-type
                           (case modifier
                             ((at) 'if-then)
                             ((colon) 'if-else-then)
                             ((colon-at) (format:error "illegal modifier in ~~["))
                             (else 'num-case)))
                     (set! conditional-arg
                           (if (one-positive-integer? params)
                               (car params)
                               (next-arg)))))
                   (anychar-dispatch))
                  ((#\;)                ; Conditional separator
                   (if (zero? conditional-nest)
                       (format:error "~~; not in ~~[~~] conditional"))
                   (if (not (null? params))
                       (format:error "no parameter allowed in ~~;"))
                   (if (= conditional-nest 1)
                       (let ((clause-str
                              (cond
                               ((eq? modifier 'colon)
                                (set! clause-default #t)
                                (substring format-string clause-pos 
                                           (- format:pos 3)))
                               ((memq modifier '(at colon-at))
                                (format:error "illegal modifier in ~~;"))
                               (else
                                (substring format-string clause-pos
                                           (- format:pos 2))))))
                         (set! clauses (append clauses (list clause-str)))
                         (set! clause-pos format:pos)))
                   (anychar-dispatch))
                  ((#\])                ; Conditional end
                   (if (zero? conditional-nest) (format:error "missing ~~["))
                   (set! conditional-nest (- conditional-nest 1))
                   (if modifier
                       (format:error "no modifier allowed in ~~]"))
                   (if (not (null? params))
                       (format:error "no parameter allowed in ~~]"))
                   (cond
                    ((zero? conditional-nest)
                     (let ((clause-str (substring format-string clause-pos
                                                  (- format:pos 2))))
                       (if clause-default
                           (set! clause-default clause-str)
                           (set! clauses (append clauses (list clause-str)))))
                     (case conditional-type
                       ((if-then)
                        (if conditional-arg
                            (format:format-work (car clauses)
                                                (list conditional-arg))))
                       ((if-else-then)
                        (add-arg-pos
                         (format:format-work (if conditional-arg
                                                 (cadr clauses)
                                                 (car clauses))
                                             (rest-args))))
                       ((num-case)
                        (if (or (not (integer? conditional-arg))
                                (< conditional-arg 0))
                            (format:error "argument not a positive integer"))
                        (if (not (and (>= conditional-arg (length clauses))
                                      (not clause-default)))
                            (add-arg-pos
                             (format:format-work
                              (if (>= conditional-arg (length clauses))
                                  clause-default
                                  (list-ref clauses conditional-arg))
                              (rest-args))))))))
                   (anychar-dispatch))
                  ((#\{)                ; Iteration begin
                   (set! iteration-nest (+ iteration-nest 1))
                   (cond
                    ((= iteration-nest 1)
                     (set! iteration-pos format:pos)
                     (set! iteration-type
                           (case modifier
                             ((at) 'rest-args)
                             ((colon) 'sublists)
                             ((colon-at) 'rest-sublists)
                             (else 'list)))
                     (set! max-iterations (if (one-positive-integer? params)
                                              (car params) #f))))
                   (anychar-dispatch))
                  ((#\})                ; Iteration end
                   (if (zero? iteration-nest) (format:error "missing ~~{"))
                   (set! iteration-nest (- iteration-nest 1))
                   (case modifier
                     ((colon)
                      (if (not max-iterations) (set! max-iterations 1)))
                     ((colon-at at) (format:error "illegal modifier")))
                   (if (not (null? params))
                       (format:error "no parameters allowed in ~~}"))
                   (if (zero? iteration-nest)
                       (let ((iteration-str
                              (substring format-string iteration-pos
                                         (- format:pos (if modifier 3 2)))))
                         (if (string=? iteration-str "")
                             (set! iteration-str (next-arg)))
                         (case iteration-type
                           ((list)
                            (let ((args (next-arg))
                                  (args-len 0))
                              (if (not (list? args))
                                  (format:error "expected a list argument"))
                              (set! args-len (length args))
                              (do ((arg-pos 0 (+ arg-pos
                                                 (format:format-work
                                                  iteration-str
                                                  (list-tail args arg-pos))))
                                   (i 0 (+ i 1)))
                                  ((or (>= arg-pos args-len)
                                       (and max-iterations
                                            (>= i max-iterations)))))))
                           ((sublists)
                            (let ((args (next-arg))
                                  (args-len 0))
                              (if (not (list? args))
                                  (format:error "expected a list argument"))
                              (set! args-len (length args))
                              (do ((arg-pos 0 (+ arg-pos 1)))
                                  ((or (>= arg-pos args-len)
                                       (and max-iterations
                                            (>= arg-pos max-iterations))))
                                (let ((sublist (list-ref args arg-pos)))
                                  (if (not (list? sublist))
                                      (format:error
                                       "expected a list of lists argument"))
                                  (format:format-work iteration-str sublist)))))
                           ((rest-args)
                            (let* ((args (rest-args))
                                   (args-len (length args))
                                   (usedup-args
                                    (do ((arg-pos 0 (+ arg-pos
                                                       (format:format-work
                                                        iteration-str
                                                        (list-tail
                                                         args arg-pos))))
                                         (i 0 (+ i 1)))
                                        ((or (>= arg-pos args-len)
                                             (and max-iterations
                                                  (>= i max-iterations)))
                                         arg-pos))))
                              (add-arg-pos usedup-args)))
                           ((rest-sublists)
                            (let* ((args (rest-args))
                                   (args-len (length args))
                                   (usedup-args
                                    (do ((arg-pos 0 (+ arg-pos 1)))
                                        ((or (>= arg-pos args-len)
                                             (and max-iterations
                                                  (>= arg-pos max-iterations)))
                                         arg-pos)
                                      (let ((sublist (list-ref args arg-pos)))
                                        (if (not (list? sublist))
                                            (format:error "expected list arguments"))
                                        (format:format-work iteration-str sublist)))))
                              (add-arg-pos usedup-args)))
                           (else (format:error "internal error in ~~}")))))
                   (anychar-dispatch))
                  ((#\^)                ; Up and out
                   (let* ((continue
                           (cond
                            ((not (null? params))
                             (not
                              (case (length params)
                                ((1) (zero? (car params)))
                                ((2) (= (list-ref params 0) (list-ref params 1)))
                                ((3) (<= (list-ref params 0)
                                         (list-ref params 1)
                                         (list-ref params 2)))
                                (else (format:error "too much parameters")))))
                            (format:case-conversion ; if conversion stop conversion
                             (set! format:case-conversion string-copy) #t)
                            ((= iteration-nest 1) #t)
                            ((= conditional-nest 1) #t)
                            ((>= arg-pos arg-len)
                             (set! format:pos format-string-len) #f)
                            (else #t))))
                     (if continue
                         (anychar-dispatch))))

;; format directive modifiers and parameters

((#\@)                ; `@' modifier
                   (if (memq modifier '(at colon-at))
                       (format:error "double `@' modifier"))
                   (set! modifier (if (eq? modifier 'colon) 'colon-at 'at))
                   (tilde-dispatch))
                  ((#\:)                ; `:' modifier
                   (if (memq modifier '(colon colon-at))
                       (format:error "double `:' modifier"))
                   (set! modifier (if (eq? modifier 'at) 'colon-at 'colon))
                   (tilde-dispatch))
                  ((#\')                ; Character parameter
                   (if modifier (format:error "misplaced modifier"))
                   (set! params (append params (list (char->integer (next-char)))))
                   (set! param-value-found #t)
                   (tilde-dispatch))
                  ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr
                   (if modifier (format:error "misplaced modifier"))
                   (let ((num-str-beg (- format:pos 1))
                         (num-str-end format:pos))
                     (do ((ch (peek-next-char) (peek-next-char)))
                         ((not (char-numeric? ch)))
                       (next-char)
                       (set! num-str-end (+ 1 num-str-end)))
                     (set! params
                           (append params
                                   (list (string->number
                                          (substring format-string
                                                     num-str-beg
                                                     num-str-end))))))
                   (set! param-value-found #t)
                   (tilde-dispatch))
                  ((#\V)           ; Variable parameter from next argum.
                   (if modifier (format:error "misplaced modifier"))
                   (set! params (append params (list (next-arg))))
                   (set! param-value-found #t)
                   (tilde-dispatch))
                  ((#\#)         ; Parameter is number of remaining args
                   (if param-value-found (format:error "misplaced '#'"))
                   (if modifier (format:error "misplaced modifier"))
                   (set! params (append params (list (length (rest-args)))))
                   (set! param-value-found #t)
                   (tilde-dispatch))
                  ((#\,)                ; Parameter separators
                   (if modifier (format:error "misplaced modifier"))
                   (if (not param-value-found)
                       (set! params (append params '(#f)))) ; append empty paramtr
                   (set! param-value-found #f)
                   (tilde-dispatch))
                  ((#\Q)                ; Inquiry messages
                   (if (eq? modifier 'colon)
                       (format:out-str format:version)
                       (let ((nl (string #\newline)))
                         (format:out-str
                          (string-append
                           "SLIB Common LISP format version " format:version nl
                           "  (C) copyright 1992-1994 by Dirk Lutzebaeck" nl
                           "  please send bug reports to `lutzeb@cs.tu-berlin.de'"
                           nl))))
                   (anychar-dispatch))
                  (else                 ; Unknown tilde directive
                   (format:error "unknown control character `~c'"
                                 (string-ref format-string (- format:pos 1))))))
               (else (anychar-dispatch)))))) ; in case of conditional

(set! format:pos 0)
        (set! format:arg-pos 0)
        (anychar-dispatch)              ; start the formatting
        (set! format:pos recursive-pos-save)
        arg-pos))                 ; return the position in the arg. list

;; when format:read-proof is true, format:obj->str will wrap
    ;; result strings starting with "#<" in an extra pair of double
    ;; quotes.
       
    (define format:read-proof #f)

;; format:obj->str returns a R4RS representation as a string of
    ;; an arbitrary scheme object.

(define (format:obj->str obj slashify)
      (let ((res (if slashify
                     (object->string obj)
                     (call-with-output-string (lambda (p) (display obj p))))))
        (if (and format:read-proof (string-prefix? "#<" res))
            (object->string res)
            res)))

(define format:space-ch (char->integer #\space))
    (define format:zero-ch (char->integer #\0))

(define (format:par pars length index default name)
      (if (> length index)
          (let ((par (list-ref pars index)))
            (if par
                (if name
                    (if (< par 0)
                        (format:error 
                         "~s parameter must be a positive integer" name)
                        par)
                    par)
                default))
          default))

(define (format:out-obj-padded pad-left obj slashify pars)
      (if (null? pars)
          (format:out-str (format:obj->str obj slashify))
          (let ((l (length pars)))
            (let ((mincol (format:par pars l 0 0 "mincol"))
                  (colinc (format:par pars l 1 1 "colinc"))
                  (minpad (format:par pars l 2 0 "minpad"))
                  (padchar (integer->char
                            (format:par pars l 3 format:space-ch #f)))
                  (objstr (format:obj->str obj slashify)))
              (if (not pad-left)
                  (format:out-str objstr))
              (do ((objstr-len (string-length objstr))
                   (i minpad (+ i colinc)))
                  ((>= (+ objstr-len i) mincol)
                   (format:out-fill i padchar)))
              (if pad-left
                  (format:out-str objstr))))))

(define (format:out-num-padded modifier number pars radix)
      (if (not (integer? number)) (format:error "argument not an integer"))
      (let ((numstr (number->string number radix)))
        (if (and (null? pars) (not modifier))
            (format:out-str numstr)
            (let ((l (length pars))
                  (numstr-len (string-length numstr)))
              (let ((mincol (format:par pars l 0 #f "mincol"))
                    (padchar (integer->char
                              (format:par pars l 1 format:space-ch #f)))
                    (commachar (integer->char
                                (format:par pars l 2 (char->integer #\,) #f)))
                    (commawidth (format:par pars l 3 3 "commawidth")))
                (if mincol
                    (let ((numlen numstr-len)) ; calc. the output len of number
                      (if (and (memq modifier '(at colon-at)) (>= number 0))
                          (set! numlen (+ numlen 1)))
                      (if (memq modifier '(colon colon-at))
                          (set! numlen (+ (quotient (- numstr-len 
                                                       (if (< number 0) 2 1))
                                                    commawidth)
                                          numlen)))
                      (if (> mincol numlen)
                          (format:out-fill (- mincol numlen) padchar))))
                (if (and (memq modifier '(at colon-at))
                         (>= number 0))
                    (format:out-char #\+))
                (if (memq modifier '(colon colon-at)) ; insert comma character
                    (let ((start (remainder numstr-len commawidth))
                          (ns (if (< number 0) 1 0)))
                      (format:out-substr numstr 0 start)
                      (do ((i start (+ i commawidth)))
                          ((>= i numstr-len))
                        (if (> i ns)
                            (format:out-char commachar))
                        (format:out-substr numstr i (+ i commawidth))))
                    (format:out-str numstr)))))))

(define (format:tabulate modifier pars)
      (let ((l (length pars)))
        (let ((colnum (format:par pars l 0 1 "colnum"))
              (colinc (format:par pars l 1 1 "colinc"))
              (padch (integer->char (format:par pars l 2 format:space-ch #f))))
          (case modifier
            ((colon colon-at)
             (format:error "unsupported modifier for ~~t"))
            ((at)                       ; relative tabulation
             (format:out-fill
              (if (= colinc 0)
                  colnum                ; colnum = colrel
                  (do ((c 0 (+ c colinc))
                       (col (+ output-col colnum)))
                      ((>= c col)
                       (- c output-col))))
              padch))
            (else                       ; absolute tabulation
             (format:out-fill
              (cond
               ((< output-col colnum)
                (- colnum output-col))
               ((= colinc 0)
                0)
               (else
                (do ((c colnum (+ c colinc)))
                    ((>= c output-col)
                     (- c output-col)))))
              padch))))))

;; roman numerals (from dorai@cs.rice.edu).

(define format:roman-alist
      '((1000 #\M) (500 #\D) (100 #\C) (50 #\L)
        (10 #\X) (5 #\V) (1 #\I)))

(define format:roman-boundary-values
      '(100 100 10 10 1 1 #f))

(define (format:num->old-roman n)
      (if (and (integer? n) (>= n 1))
          (let loop ((n n)
                     (romans format:roman-alist)
                     (s '()))
            (if (null? romans) (list->string (reverse s))
                (let ((roman-val (caar romans))
                      (roman-dgt (cadar romans)))
                  (do ((q (quotient n roman-val) (- q 1))
                       (s s (cons roman-dgt s)))
                      ((= q 0)
                       (loop (remainder n roman-val)
                             (cdr romans) s))))))
          (format:error "only positive integers can be romanized")))

(define (format:num->roman n)
      (if (and (integer? n) (> n 0))
          (let loop ((n n)
                     (romans format:roman-alist)
                     (boundaries format:roman-boundary-values)
                     (s '()))
            (if (null? romans)
                (list->string (reverse s))
                (let ((roman-val (caar romans))
                      (roman-dgt (cadar romans))
                      (bdry (car boundaries)))
                  (let loop2 ((q (quotient n roman-val))
                              (r (remainder n roman-val))
                              (s s))
                    (if (= q 0)
                        (if (and bdry (>= r (- roman-val bdry)))
                            (loop (remainder r bdry) (cdr romans)
                                  (cdr boundaries)
                                  (cons roman-dgt
                                        (append
                                         (cdr (assv bdry romans))
                                         s)))
                            (loop r (cdr romans) (cdr boundaries) s))
                        (loop2 (- q 1) r (cons roman-dgt s)))))))
          (format:error "only positive integers can be romanized")))

;; cardinals & ordinals (from dorai@cs.rice.edu)

(define format:cardinal-ones-list
      '(#f "one" "two" "three" "four" "five"
           "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen"
           "fourteen" "fifteen" "sixteen" "seventeen" "eighteen"
           "nineteen"))

(define format:cardinal-tens-list
      '(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty"
           "ninety"))

(define (format:num->cardinal999 n)
      ;; this procedure is inspired by the Bruno Haible's CLisp
      ;; function format-small-cardinal, which converts numbers
      ;; in the range 1 to 999, and is used for converting each
      ;; thousand-block in a larger number
      (let* ((hundreds (quotient n 100))
             (tens+ones (remainder n 100))
             (tens (quotient tens+ones 10))
             (ones (remainder tens+ones 10)))
        (append
         (if (> hundreds 0)
             (append
              (string->list
               (list-ref format:cardinal-ones-list hundreds))
              (string->list" hundred")
              (if (> tens+ones 0) '(#\space) '()))
             '())
         (if (< tens+ones 20)
             (if (> tens+ones 0)
                 (string->list
                  (list-ref format:cardinal-ones-list tens+ones))
                 '())
             (append
              (string->list
               (list-ref format:cardinal-tens-list tens))
              (if (> ones 0)
                  (cons #\-
                        (string->list
                         (list-ref format:cardinal-ones-list ones)))
                  '()))))))

(define format:cardinal-thousand-block-list
      '("" " thousand" " million" " billion" " trillion" " quadrillion"
        " quintillion" " sextillion" " septillion" " octillion" " nonillion"
        " decillion" " undecillion" " duodecillion" " tredecillion"
        " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
        " octodecillion" " novemdecillion" " vigintillion"))

(define (format:num->cardinal n)
      (cond ((not (integer? n))
             (format:error
              "only integers can be converted to English cardinals"))
            ((= n 0) "zero")
            ((< n 0) (string-append "minus " (format:num->cardinal (- n))))
            (else
             (let ((power3-word-limit
                    (length format:cardinal-thousand-block-list)))
               (let loop ((n n)
                          (power3 0)
                          (s '()))
                 (if (= n 0)
                     (list->string s)
                     (let ((n-before-block (quotient n 1000))
                           (n-after-block (remainder n 1000)))
                       (loop n-before-block
                             (+ power3 1)
                             (if (> n-after-block 0)
                                 (append
                                  (if (> n-before-block 0)
                                      (string->list ", ") '())
                                  (format:num->cardinal999 n-after-block)
                                  (if (< power3 power3-word-limit)
                                      (string->list
                                       (list-ref
                                        format:cardinal-thousand-block-list
                                        power3))
                                      (append
                                       (string->list " times ten to the ")
                                       (string->list
                                        (format:num->ordinal
                                         (* power3 3)))
                                       (string->list " power")))
                                  s)
                                 s)))))))))

(define format:ordinal-ones-list
      '(#f "first" "second" "third" "fourth" "fifth"
           "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth"
           "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth"
           "eighteenth" "nineteenth"))

(define format:ordinal-tens-list
      '(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth"
           "seventieth" "eightieth" "ninetieth"))

(define (format:num->ordinal n)
      (cond ((not (integer? n))
             (format:error
              "only integers can be converted to English ordinals"))
            ((= n 0) "zeroth")
            ((< n 0) (string-append "minus " (format:num->ordinal (- n))))
            (else
             (let ((hundreds (quotient n 100))
                   (tens+ones (remainder n 100)))
               (string-append
                (if (> hundreds 0)
                    (string-append
                     (format:num->cardinal (* hundreds 100))
                     (if (= tens+ones 0) "th" " "))
                    "")
                (if (= tens+ones 0) ""
                    (if (< tens+ones 20)
                        (list-ref format:ordinal-ones-list tens+ones)
                        (let ((tens (quotient tens+ones 10))
                              (ones (remainder tens+ones 10)))
                          (if (= ones 0)
                              (list-ref format:ordinal-tens-list tens)
                              (string-append
                               (list-ref format:cardinal-tens-list tens)
                               "-"
                               (list-ref format:ordinal-ones-list ones))))
                        )))))))

;; format inf and nan.

(define (format:out-inf-nan number width digits edigits overch padch)
      ;; inf and nan are always printed exactly as "+inf.0", "-inf.0" or
      ;; "+nan.0", suitably justified in their field.  We insist on
      ;; printing this exact form so that the numbers can be read back in.
      (let* ((str (number->string number))
             (len (string-length str))
             (dot (string-index str #\.))
             (digits (+ (or digits 0)
                        (if edigits (+ edigits 2) 0))))
        (if (and width overch (< width len))
            (format:out-fill width (integer->char overch))
            (let* ((leftpad (if width
                                (max (- width (max len (+ dot 1 digits))) 0)
                                0))
                   (rightpad (if width
                                 (max (- width leftpad len) 0)
                                 0))
                   (padch (integer->char (or padch format:space-ch)))) 
              (format:out-fill leftpad padch)
              (format:out-str str)
              (format:out-fill rightpad padch)))))

;; format fixed flonums (~F)

(define (format:out-fixed modifier number pars)
      (if (not (or (number? number) (string? number)))
          (format:error "argument is not a number or a number string"))

(let ((l (length pars)))
        (let ((width (format:par pars l 0 #f "width"))
              (digits (format:par pars l 1 #f "digits"))
              (scale (format:par pars l 2 0 #f))
              (overch (format:par pars l 3 #f #f))
              (padch (format:par pars l 4 format:space-ch #f)))

(cond
           ((and (number? number)
                 (or (inf? number) (nan? number)))
            (format:out-inf-nan number width digits #f overch padch))

(digits
            (format:parse-float number #t scale)
            (if (<= (- format:fn-len format:fn-dot) digits)
                (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
                (format:fn-round digits))
            (if width
                (let ((numlen (+ format:fn-len 1)))
                  (if (or (not format:fn-pos?) (eq? modifier 'at))
                      (set! numlen (+ numlen 1)))
                  (if (and (= format:fn-dot 0) (> width (+ digits 1)))
                      (set! numlen (+ numlen 1)))
                  (if (< numlen width)
                      (format:out-fill (- width numlen) (integer->char padch)))
                  (if (and overch (> numlen width))
                      (format:out-fill width (integer->char overch))
                      (format:fn-out modifier (> width (+ digits 1)))))
                (format:fn-out modifier #t)))

(else
            (format:parse-float number #t scale)
            (format:fn-strip)
            (if width
                (let ((numlen (+ format:fn-len 1)))
                  (if (or (not format:fn-pos?) (eq? modifier 'at))
                      (set! numlen (+ numlen 1)))
                  (if (= format:fn-dot 0)
                      (set! numlen (+ numlen 1)))
                  (if (< numlen width)
                      (format:out-fill (- width numlen) (integer->char padch)))
                  (if (> numlen width)	; adjust precision if possible
                      (let ((dot-index (- numlen
                                          (- format:fn-len format:fn-dot))))
                        (if (> dot-index width)
                            (if overch ; numstr too big for required width
                                (format:out-fill width (integer->char overch))
                                (format:fn-out modifier #t))
                            (begin
                              (format:fn-round (- width dot-index))
                              (format:fn-out modifier #t))))
                      (format:fn-out modifier #t)))
                (format:fn-out modifier #t)))))))

;; format exponential flonums (~E)

(define (format:out-expon modifier number pars)
      (if (not (or (number? number) (string? number)))
          (format:error "argument is not a number"))

(let ((l (length pars)))
        (let ((width (format:par pars l 0 #f "width"))
              (digits (format:par pars l 1 #f "digits"))
              (edigits (format:par pars l 2 #f "exponent digits"))
              (scale (format:par pars l 3 1 #f))
              (overch (format:par pars l 4 #f #f))
              (padch (format:par pars l 5 format:space-ch #f))
              (expch (format:par pars l 6 #f #f)))
	      
          (cond
           ((and (number? number)
                 (or (inf? number) (nan? number)))
            (format:out-inf-nan number width digits edigits overch padch))

(digits                      ; fixed precision

(let ((digits (if (> scale 0)
                              (if (< scale (+ digits 2))
                                  (+ (- digits scale) 1)
                                  0)
                              digits)))
              (format:parse-float number #f scale)
              (if (<= (- format:fn-len format:fn-dot) digits)
                  (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
                  (format:fn-round digits))
              (if width
                  (if (and edigits overch (> format:en-len edigits))
                      (format:out-fill width (integer->char overch))
                      (let ((numlen (+ format:fn-len 3))) ; .E+
                        (if (or (not format:fn-pos?) (eq? modifier 'at))
                            (set! numlen (+ numlen 1)))
                        (if (and (= format:fn-dot 0) (> width (+ digits 1)))
                            (set! numlen (+ numlen 1)))	
                        (set! numlen
                              (+ numlen 
                                 (if (and edigits (>= edigits format:en-len))
                                     edigits 
                                     format:en-len)))
                        (if (< numlen width)
                            (format:out-fill (- width numlen)
                                             (integer->char padch)))
                        (if (and overch (> numlen width))
                            (format:out-fill width (integer->char overch))
                            (begin
                              (format:fn-out modifier (> width (- numlen 1)))
                              (format:en-out edigits expch)))))
                  (begin
                    (format:fn-out modifier #t)
                    (format:en-out edigits expch)))))

(else
            (format:parse-float number #f scale)
            (format:fn-strip)
            (if width
                (if (and edigits overch (> format:en-len edigits))
                    (format:out-fill width (integer->char overch))
                    (let ((numlen (+ format:fn-len 3))) ; .E+
                      (if (or (not format:fn-pos?) (eq? modifier 'at))
                          (set! numlen (+ numlen 1)))
                      (if (= format:fn-dot 0)
                          (set! numlen (+ numlen 1)))
                      (set! numlen
                            (+ numlen
                               (if (and edigits (>= edigits format:en-len))
                                   edigits 
                                   format:en-len)))
                      (if (< numlen width)
                          (format:out-fill (- width numlen)
                                           (integer->char padch)))
                      (if (> numlen width) ; adjust precision if possible
                          (let ((f (- format:fn-len format:fn-dot))) ; fract len
                            (if (> (- numlen f) width)
                                (if overch ; numstr too big for required width
                                    (format:out-fill width 
                                                     (integer->char overch))
                                    (begin
                                      (format:fn-out modifier #t)
                                      (format:en-out edigits expch)))
                                (begin
                                  (format:fn-round (+ (- f numlen) width))
                                  (format:fn-out modifier #t)
                                  (format:en-out edigits expch))))
                          (begin
                            (format:fn-out modifier #t)
                            (format:en-out edigits expch)))))
                (begin
                  (format:fn-out modifier #t)
                  (format:en-out edigits expch))))))))
       
    ;; format general flonums (~G)

(define (format:out-general modifier number pars)
      (if (not (or (number? number) (string? number)))
          (format:error "argument is not a number or a number string"))

(let ((l (length pars)))
        (let ((width (if (> l 0) (list-ref pars 0) #f))
              (digits (if (> l 1) (list-ref pars 1) #f))
              (edigits (if (> l 2) (list-ref pars 2) #f))
              (overch (if (> l 4) (list-ref pars 4) #f))
              (padch (if (> l 5) (list-ref pars 5) #f)))
          (cond
           ((and (number? number)
                 (or (inf? number) (nan? number)))
            ;; FIXME: this isn't right.
            (format:out-inf-nan number width digits edigits overch padch))
           (else
            (format:parse-float number #t 0)
            (format:fn-strip)
            (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm
                   (ww (if width (- width ee) #f)) ; see Steele's CL book p.395
                   (n (if (= format:fn-dot 0) ; number less than (abs 1.0) ?
                          (- (format:fn-zlead))
                          format:fn-dot))
                   (d (if digits
                          digits
                          (max format:fn-len (min n 7)))) ; q = format:fn-len
                   (dd (- d n)))
              (if (<= 0 dd d)
                  (begin
                    (format:out-fixed modifier number (list ww dd #f overch padch))
                    (format:out-fill ee #\space)) ;~@T not implemented yet
                  (format:out-expon modifier number pars))))))))

;; format dollar flonums (~$)

(define (format:out-dollar modifier number pars)
      (if (not (or (number? number) (string? number)))
          (format:error "argument is not a number or a number string"))

(let ((l (length pars)))
        (let ((digits (format:par pars l 0 2 "digits"))
              (mindig (format:par pars l 1 1 "mindig"))
              (width (format:par pars l 2 0 "width"))
              (padch (format:par pars l 3 format:space-ch #f)))

(cond
           ((and (number? number)
                 (or (inf? number) (nan? number)))
            (format:out-inf-nan number width digits #f #f padch))

(else
            (format:parse-float number #t 0)
            (if (<= (- format:fn-len format:fn-dot) digits)
                (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
                (format:fn-round digits))
            (let ((numlen (+ format:fn-len 1)))
              (if (or (not format:fn-pos?) (memq modifier '(at colon-at)))
                  (set! numlen (+ numlen 1)))
              (if (and mindig (> mindig format:fn-dot))
                  (set! numlen (+ numlen (- mindig format:fn-dot))))
              (if (and (= format:fn-dot 0) (not mindig))
                  (set! numlen (+ numlen 1)))
              (if (< numlen width)
                  (case modifier
                    ((colon)
                     (if (not format:fn-pos?)
                         (format:out-char #\-))
                     (format:out-fill (- width numlen) (integer->char padch)))
                    ((at)
                     (format:out-fill (- width numlen) (integer->char padch))
                     (format:out-char (if format:fn-pos? #\+ #\-)))
                    ((colon-at)
                     (format:out-char (if format:fn-pos? #\+ #\-))
                     (format:out-fill (- width numlen) (integer->char padch)))
                    (else
                     (format:out-fill (- width numlen) (integer->char padch))
                     (if (not format:fn-pos?)
                         (format:out-char #\-))))
                  (if format:fn-pos?
                      (if (memq modifier '(at colon-at)) (format:out-char #\+))
                      (format:out-char #\-))))
            (if (and mindig (> mindig format:fn-dot))
                (format:out-fill (- mindig format:fn-dot) #\0))
            (if (and (= format:fn-dot 0) (not mindig))
                (format:out-char #\0))
            (format:out-substr format:fn-str 0 format:fn-dot)
            (format:out-char #\.)
            (format:out-substr format:fn-str format:fn-dot format:fn-len))))))

; the flonum buffers

(define format:fn-max 400)          ; max. number of number digits
    (define format:fn-str (make-string format:fn-max)) ; number buffer
    (define format:fn-len 0)            ; digit length of number
    (define format:fn-dot #f)           ; dot position of number
    (define format:fn-pos? #t)          ; number positive?
    (define format:en-max 10)           ; max. number of exponent digits
    (define format:en-str (make-string format:en-max)) ; exponent buffer
    (define format:en-len 0)            ; digit length of exponent
    (define format:en-pos? #t)          ; exponent positive?

(define (format:parse-float num fixed? scale)
      (let ((num-str (if (string? num)
                         num
                         (number->string (exact->inexact num)))))
        (set! format:fn-pos? #t)
        (set! format:fn-len 0)
        (set! format:fn-dot #f)
        (set! format:en-pos? #t)
        (set! format:en-len 0)
        (do ((i 0 (+ i 1))
             (left-zeros 0)
             (mantissa? #t)
             (all-zeros? #t)
             (num-len (string-length num-str))
             (c #f))                ; current exam. character in num-str
            ((= i num-len)
             (if (not format:fn-dot)
                 (set! format:fn-dot format:fn-len))

(if all-zeros?
                 (begin
                   (set! left-zeros 0)
                   (set! format:fn-dot 0)
                   (set! format:fn-len 1)))

;; now format the parsed values according to format's need

(if fixed?

(begin                 ; fixed format m.nnn or .nnn
                   (if (and (> left-zeros 0) (> format:fn-dot 0))
                       (if (> format:fn-dot left-zeros) 
                           (begin       ; norm 0{0}nn.mm to nn.mm
                             (format:fn-shiftleft left-zeros)
                             (set! format:fn-dot (- format:fn-dot left-zeros))
                             (set! left-zeros 0))
                           (begin       ; normalize 0{0}.nnn to .nnn
                             (format:fn-shiftleft format:fn-dot)
                             (set! left-zeros (- left-zeros format:fn-dot))
                             (set! format:fn-dot 0))))
                   (if (or (not (= scale 0)) (> format:en-len 0))
                       (let ((shift (+ scale (format:en-int))))
                         (cond
                          (all-zeros? #t)
                          ((> (+ format:fn-dot shift) format:fn-len)
                           (format:fn-zfill
                            #f (- shift (- format:fn-len format:fn-dot)))
                           (set! format:fn-dot format:fn-len))
                          ((< (+ format:fn-dot shift) 0)
                           (format:fn-zfill #t (- (- shift) format:fn-dot))
                           (set! format:fn-dot 0))
                          (else
                           (if (> left-zeros 0)
                               (if (<= left-zeros shift) ; shift always > 0 here
                                   (format:fn-shiftleft shift) ; shift out 0s
                                   (begin
                                     (format:fn-shiftleft left-zeros)
                                     (set! format:fn-dot (- shift left-zeros))))
                               (set! format:fn-dot (+ format:fn-dot shift))))))))

(let ((negexp          ; expon format m.nnnEee
                        (if (> left-zeros 0)
                            (- left-zeros format:fn-dot -1)
                            (if (= format:fn-dot 0) 1 0))))
                   (if (> left-zeros 0)
                       (begin           ; normalize 0{0}.nnn to n.nn
                         (format:fn-shiftleft left-zeros)
                         (set! format:fn-dot 1))
                       (if (= format:fn-dot 0)
                           (set! format:fn-dot 1)))
                   (format:en-set (- (+ (- format:fn-dot scale) (format:en-int))
                                     negexp))
                   (cond 
                    (all-zeros?
                     (format:en-set 0)
                     (set! format:fn-dot 1))
                    ((< scale 0)        ; leading zero
                     (format:fn-zfill #t (- scale))
                     (set! format:fn-dot 0))
                    ((> scale format:fn-dot)
                     (format:fn-zfill #f (- scale format:fn-dot))
                     (set! format:fn-dot scale))
                    (else
                     (set! format:fn-dot scale)))))
             #t)

;; do body      
          (set! c (string-ref num-str i)) ; parse the output of number->string
          (cond                         ; which can be any valid number
           ((char-numeric? c)           ; representation of R4RS except 
            (if mantissa?               ; complex numbers
                (begin
                  (if (char=? c #\0)
                      (if all-zeros?
                          (set! left-zeros (+ left-zeros 1)))
                      (begin
                        (set! all-zeros? #f)))
                  (string-set! format:fn-str format:fn-len c)
                  (set! format:fn-len (+ format:fn-len 1)))
                (begin
                  (string-set! format:en-str format:en-len c)
                  (set! format:en-len (+ format:en-len 1)))))
           ((or (char=? c #\-) (char=? c #\+))
            (if mantissa?
                (set! format:fn-pos? (char=? c #\+))
                (set! format:en-pos? (char=? c #\+))))
           ((char=? c #\.)
            (set! format:fn-dot format:fn-len))
           ((char=? c #\e)
            (set! mantissa? #f))
           ((char=? c #\E)
            (set! mantissa? #f))
           ((char-whitespace? c) #t)
           ((char=? c #\d) #t)          ; decimal radix prefix
           ((char=? c #\#) #t)
           (else
            (format:error "illegal character `~c' in number->string" c))))))

(define (format:en-int)         ; convert exponent string to integer
      (if (= format:en-len 0)
          0
          (do ((i 0 (+ i 1))
               (n 0))
              ((= i format:en-len) 
               (if format:en-pos?
                   n
                   (- n)))
            (set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i))
                                   format:zero-ch))))))

(define (format:en-set en)          ; set exponent string number
      (set! format:en-len 0)
      (set! format:en-pos? (>= en 0))
      (let ((en-str (number->string en)))
        (do ((i 0 (+ i 1))
             (en-len (string-length en-str))
             (c #f))
            ((= i en-len))
          (set! c (string-ref en-str i))
          (if (char-numeric? c)
              (begin
                (string-set! format:en-str format:en-len c)
                (set! format:en-len (+ format:en-len 1)))))))

(define (format:fn-zfill left? n) ; fill current number string with 0s
      (if (> (+ n format:fn-len) format:fn-max) ; from the left or right
          (format:error "number is too long to format (enlarge format:fn-max)"))
      (set! format:fn-len (+ format:fn-len n))
      (if left?
          (do ((i format:fn-len (- i 1))) ; fill n 0s to left
              ((< i 0))
            (string-set! format:fn-str i
                         (if (< i n)
                             #\0
                             (string-ref format:fn-str (- i n)))))
          (do ((i (- format:fn-len n) (+ i 1))) ; fill n 0s to the right
              ((= i format:fn-len))
            (string-set! format:fn-str i #\0))))

(define (format:fn-shiftleft n) ; shift left current number n positions
      (if (> n format:fn-len)
          (format:error "internal error in format:fn-shiftleft (~d,~d)"
                        n format:fn-len))
      (do ((i n (+ i 1)))
          ((= i format:fn-len)
           (set! format:fn-len (- format:fn-len n)))
        (string-set! format:fn-str (- i n) (string-ref format:fn-str i))))

(define (format:fn-round digits)    ; round format:fn-str
      (set! digits (+ digits format:fn-dot))
      (do ((i digits (- i 1))		; "099",2 -> "10"
           (c 5))                       ; "023",2 -> "02"
          ((or (= c 0) (< i 0))         ; "999",2 -> "100"
           (if (= c 1)			; "005",2 -> "01"
               (begin			; carry overflow
                 (set! format:fn-len digits)
                 (format:fn-zfill #t 1) ; add a 1 before fn-str
                 (string-set! format:fn-str 0 #\1)
                 (set! format:fn-dot (+ format:fn-dot 1)))
               (set! format:fn-len digits)))
        (set! c (+ (- (char->integer (string-ref format:fn-str i))
                      format:zero-ch) c))
        (string-set! format:fn-str i (integer->char
                                      (if (< c 10) 
                                          (+ c format:zero-ch)
                                          (+ (- c 10) format:zero-ch))))
        (set! c (if (< c 10) 0 1))))

(define (format:fn-out modifier add-leading-zero?)
      (if format:fn-pos?
          (if (eq? modifier 'at) 
              (format:out-char #\+))
          (format:out-char #\-))
      (if (= format:fn-dot 0)
          (if add-leading-zero?
              (format:out-char #\0))
          (format:out-substr format:fn-str 0 format:fn-dot))
      (format:out-char #\.)
      (format:out-substr format:fn-str format:fn-dot format:fn-len))

(define (format:en-out edigits expch)
      (format:out-char (if expch (integer->char expch) #\E))
      (format:out-char (if format:en-pos? #\+ #\-))
      (if edigits 
          (if (< format:en-len edigits)
              (format:out-fill (- edigits format:en-len) #\0)))
      (format:out-substr format:en-str 0 format:en-len))

(define (format:fn-strip)           ; strip trailing zeros but one
      (string-set! format:fn-str format:fn-len #\0)
      (do ((i format:fn-len (- i 1)))
          ((or (not (char=? (string-ref format:fn-str i) #\0))
               (<= i format:fn-dot))
           (set! format:fn-len (+ i 1)))))

(define (format:fn-zlead)           ; count leading zeros
      (do ((i 0 (+ i 1)))
          ((or (= i format:fn-len)
               (not (char=? (string-ref format:fn-str i) #\0)))
           (if (= i format:fn-len)      ; found a real zero
               0
               i))))

;;; some global functions not found in SLIB

(define (string-capitalize-first str) ; "hello" -> "Hello"
      (let ((cap-str (string-copy str))   ; "hELLO" -> "Hello"
            (non-first-alpha #f)          ; "*hello" -> "*Hello"
            (str-len (string-length str))) ; "hello you" -> "Hello you"
        (do ((i 0 (+ i 1)))
            ((= i str-len) cap-str)
          (let ((c (string-ref str i)))
            (if (char-alphabetic? c)
                (if non-first-alpha
                    (string-set! cap-str i (char-downcase c))
                    (begin
                      (set! non-first-alpha #t)
                      (string-set! cap-str i (char-upcase c)))))))))

;; Aborts the program when a formatting error occures. This is a null
    ;; argument closure to jump to the interpreters toplevel continuation.

(define (format:abort) (error "error in format"))
    
    (let ((arg-pos (format:format-work format-string format-args))
          (arg-len (length format-args)))
      (cond
       ((> arg-pos arg-len)
        (set! format:arg-pos (+ arg-len 1))
        (display format:arg-pos)
        (format:error "~a missing argument~:p" (- arg-pos arg-len)))
       (else
        (if flush-output?
            (force-output port))
        (if destination
            #t
            (let ((str (get-output-string port)))
              (close-port port)
              str)))))))

(begin-deprecated
 (set! format
       (let ((format format))
         (case-lambda
           ((destination format-string . args)
            (if (string? destination)
                (begin
                  (issue-deprecation-warning
                   "Omitting the destination on a call to format is deprecated."
                   "Pass #f as the destination, before the format string.")
                  (apply format #f destination format-string args))
                (apply format destination format-string args)))
           ((deprecated-format-string-only)
            (issue-deprecation-warning
             "Omitting the destination port on a call to format is deprecated."
             "Pass #f as the destination port, before the format string.")
            (format #f deprecated-format-string-only))))))

;; Thanks to Shuji Narazaki
(module-set! the-root-module 'format format)

cmd: