;;; "format.scm" Common LISP text output formatter for SLIB
; Written 1992-1994 by Dirk Lutzebaeck (address@hidden)
; 2004 Aubrey Jaffer: made reentrant; call slib:error for errors.
;
; This code is in the public domain.

; Authors of the original version (< 1.4) were Ken Dickey and Aubrey Jaffer.
; Please send error reports to the email address above.
; For documentation see slib.texi and format.doc.
; For testing load formatst.scm.
;
; Version 3.1

; Modified for thread safety; JFW, Aug 25 2011

; Modified for CHICKEN Kon Lovett, Sep 25 2005
; - no local defines for string & number operations
;
; - unprocessed arguments are not an error
;
; - fix for E format; wasn't leaving off leading 0 when result-len > len
; so considered overflow
;
; - exports configuration symbols
;
; - does not use intermediate string when output is a port
;
; - moved defines to toplevel

(declare
 (unit clformat)
 (no-bound-checks)
 (no-argc-checks)
 (no-procedure-checks)
 (always-bound
  format:error-save)
 (uses data-structures ports)
 )

(require-library extras)

(module
 clformat
 (format:symbol-case-conv
  format:iobj-case-conv
  format:expch
  format:iteration-bounded
  format:max-iterations
  format:floats
  format:complex-numbers
  format:radix-pref
  #;format:ascii-non-printable-charnames
  format:fn-max
  format:en-max
  format:unprocessed-arguments-error?
  #;format:version
  #;format:iobj->str
  clformat)

 (import scheme chicken)
 (import srfi-13)
 (import data-structures ports)
 (import (except extras format))

;;; Configuration ------------------------------------------------------------

(define format:symbol-case-conv #f)
;; Symbols are converted by symbol->string so the case of the printed
;; symbols is implementation dependent. format:symbol-case-conv is a
;; one arg closure which is either #f (no conversion), string-upcase!,
;; string-downcase! or string-capitalize!.

(define format:iobj-case-conv #f)
;; As format:symbol-case-conv but applies for the representation of
;; implementation internal objects.

(define format:expch #\E)
;; The character prefixing the exponent value in ~e printing.

(define format:iteration-bounded #t)
;; If #t, "~{...~}" iterates no more than format:max-iterations times;
;; if #f, there is no bound.

(define format:max-iterations 100)
;; Compatible with previous versions.

(define format:floats #t)
;; Detects if the scheme system implements flonums (see at eof).

(define format:complex-numbers #f)
;; Detects if the scheme system implements complex numbers.
;; See use below for invocation-time detection of complex support.

(define format:radix-pref (char=? #\# (string-ref (number->string 8 8) 0)))
;; Detects if number->string adds a radix prefix.

(define format:ascii-non-printable-charnames
  '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel"
     "bs"  "ht"  "nl"  "vt"  "np"  "cr"  "so"  "si"
     "dle" "dc1" "dc2" "dc3" "dc4" "nak" "syn" "etb"
     "can" "em"  "sub" "esc" "fs"  "gs"  "rs"  "us" "space"))

(define format:fn-max 200)              ; max. number of number digits
(define format:en-max 10)               ; max. number of exponent digits

(define format:unprocessed-arguments-error? #f) ; CL says this is not an error

;;; End of configuration ----------------------------------------------------

(define format:version "3.1")

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

(define format:parameter-characters
  '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\') )

(define format:conditional-directives-characters
  (append '(#\[ #\] #\; #\: #\@ #\^) format:parameter-characters) )

(define format:iteration-directives-characters
  (append '(#\{ #\} #\: #\@ #\^) format:parameter-characters) )

;; cardinals & ordinals (from address@hidden)

(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: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: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") )

;; roman numerals (from address@hidden).

(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))

;; State (originally "globals")

(define-record-type <clformat-state>
  (make-clformat-state
   args
   arg-pos
   port
   column
   pos
   read-proof
   flush
   case-conversion
   fn-str
   fn-len
   fn-pos?
   fn-dot
   en-str
   en-len
   en-pos?
   )
  clformat-state?
  (args format:args format:args-set!)
  (arg-pos format:arg-pos format:arg-pos-set!)
  (port format:port format:port-set!)
  (column format:output-col format:output-col-set!)
  (pos format:pos format:pos-set!)
  (read-proof format:read-proof format:read-proof-set!)
  (flush format:flush-output format:flush-output-set!)
  (case-conversion format:case-conversion format:case-conversion-set!)
  (fn-str format:fn-str format:fn-str-set!)
  (fn-len format:fn-len format:fn-len-set!)
  (fn-pos? format:fn-pos? format:fn-pos?-set!)
  (fn-dot format:fn-dot format:fn-dot-set!)
  (en-str format:en-str format:en-str-set!)
  (en-len format:en-len format:en-len-set!)
  (en-pos? format:en-pos? format:en-pos?-set!)
  )

;;

(define (format:list-head l k)
  (if (fx= k 0)
      '()
      (cons (car l) (format:list-head (cdr l) (- k 1)))))

;; 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"))

;; error handler

(define (format:error-handler clfs . args)           ; never returns!
  (let ((format-args (format:args clfs))
        (port #f))
    (if (and (>= (length format-args) 2)
             (string? (cadr format-args)))
	(raise
	 (let ((format-string (cadr format-args)))
	   (unless (zero? (format:arg-pos clfs))
		   (format:arg-pos (- (format:arg-pos clfs) 1)))
	   (clformat port "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~
																~{~a ~}===>~{~a ~})~%        "
		     (car format-args)
		     (substring format-string 0 (format:pos clfs))
		     (substring format-string (format:pos clfs)
				(string-length format-string))
		     (format:list-head (cddr format-args) (format:arg-pos clfs))
		     (list-tail (cddr format-args) (format:arg-pos clfs)))))
	(clformat port
		"~%FORMAT: error with call: (format~{ ~a~})~%        "
		(format:args clfs)))))

(define format:error
  (let ((ceh (make-parameter format:error-handler)))
    (lambda args
      (let ((h (ceh)))
	(parameterize ((ceh format:intern-error)) (h args))))))

(define (format:intern-error clfs . args)   ;if something goes wrong in format:error
  (display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline)
  (display "        format args: ") (write (format:args clfs)) (newline)
  (display "        error args:  ") (write args) (newline)
  (format:abort))

;; format string and char output routines on format:port

(define (format:out-str-noconv clfs str)
  (display str (format:port clfs))
  (format:output-col-set! clfs (fx+ (format:output-col clfs) (string-length str))))

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

(define (format:out-char clfs ch)
  (let ((cv (format:case-conversion clfs)))
    (if cv
	(display (cv (string ch)) (format:port clfs))
	(write-char ch (format:port clfs))))
  (format:output-col-set!
   clfs (if (char=? ch #\newline) 0 (fx+ (format:output-col clfs) 1))))

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

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

;;

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

(define (format:out-obj-padded clfs pad-left obj slashify pars)
  (if (null? pars)
      (format:out-str clfs (format:obj->str clfs 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 clfs obj slashify)))
	  (unless pad-left
		  (format:out-str clfs objstr))
	  (do ((objstr-len (string-length objstr))
	       (i minpad (fx+ i colinc)))
	      ((fx>= (fx+ objstr-len i) mincol)
	       (format:out-fill clfs i padchar)))
	  (when pad-left
		(format:out-str clfs objstr))))))

(define (format:out-num-padded clfs modifier number pars radix)
  (unless (fixnum? number)
	  (set! number (inexact->exact (truncate number)))
	  ;(format:error clfs "argument not an integer" number)
	  )
  (let ((numstr (number->string number radix)))
    (when (and format:radix-pref (not (fx= radix 10)))
	  (set! numstr (substring numstr 2 (string-length numstr))))
    (if (and (null? pars) (not modifier))
	(format:out-str clfs 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
		  (when (and (memq modifier '(at colon-at)) (positive? number))
			(set! numlen (fx+ numlen 1)))
		  (when (memq modifier '(colon colon-at))
			(set! numlen
			      (fx+ numlen
				   (fx/ (fx- numstr-len (if (negative? number) 2 1))
					commawidth))))
		  (when (fx> mincol numlen)
			(format:out-fill clfs (fx- mincol numlen) padchar))))
	    (if (and (memq modifier '(at colon-at))
		     (positive? number))
		(format:out-char clfs #\+))
	    (if (memq modifier '(colon colon-at)) ; insert comma character
		(let ((start (fxmod numstr-len commawidth))
		      (ns (if (negative? number) 1 0)))
		  (format:out-substr clfs numstr 0 start)
		  (do ((i start (fx+ i commawidth)))
		      ((fx>= i numstr-len))
		    (if (fx> i ns)
			(format:out-char clfs commachar))
		    (format:out-substr clfs numstr i (fx+ i commawidth))))
		(format:out-str clfs numstr)))))))

(define (format:tabulate clfs 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 clfs "unsupported modifier for ~~t" modifier))
	((at)                         ; relative tabulation
	 (format:out-fill clfs
	  (if (fx= colinc 0)
	      colnum                  ; colnum = colrel
	      (do ((c 0 (fx+ c colinc))
		   (col (fx+ (format:output-col clfs) colnum)))
		  ((fx>= c col)
		   (fx- c (format:output-col clfs)))))
	  padch))
	(else                         ; absolute tabulation
	 (format:out-fill clfs
	  (cond
	   ((fx< (format:output-col clfs) colnum)
	    (fx- colnum (format:output-col clfs)))
	   ((fx= colinc 0)
	    0)
	   (else
	    (do ((c colnum (fx+ c colinc)))
		((fx>= c (format:output-col clfs))
		 (fx- c (format:output-col clfs))))))
	  padch))))))

(define (format:num->old-roman clfs 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)))
		  ((zero? q)
		   (loop (remainder n roman-val)
			 (cdr romans) s))))))
      (format:error clfs "only positive integers can be romanized")))

(define (format:num->roman clfs n)
  (if (and (integer? n) (positive? n))
      (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 (zero? q)
		    (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 clfs "only positive integers can be romanized")))

(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 (positive? hundreds)
	 (append
	  (string->list (vector-ref format:cardinal-ones-list hundreds))
	  (string->list" hundred")
	  (if (> tens+ones 0) '(#\space) '()))
	 '())
     (if (< tens+ones 20)
	 (if (positive? tens+ones)
	     (string->list (vector-ref format:cardinal-ones-list tens+ones))
	     '())
	 (append
	  (string->list (vector-ref format:cardinal-tens-list tens))
	  (if (positive? ones)
	      (cons #\-
		    (string->list (vector-ref format:cardinal-ones-list ones)))
	      '()))))))

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

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

;; format fixed flonums (~F)

(define (format:out-fixed clfs modifier number pars)
  (unless (or (number? number) (string? number))
	  (format:error clfs "argument is not a number or a number string" number))
  (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)))

      (if digits

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

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

;; format exponential flonums (~E)

(define (format:out-expon clfs modifier number pars)
  (unless (or (number? number) (string? number))
	  (format:error clfs "argument is not a number" 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)))

      (if digits                      ; fixed precision

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

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

;; format general flonums (~G)

(define (format:out-general clfs modifier number pars)
  (unless (or (number? number) (string? number))
	  (format:error clfs "argument is not a number or a number string" number))
  (let ((l (length pars)))
    (let ((width (if (fx> l 0) (list-ref pars 0) #f))
	  (digits (if (fx> l 1) (list-ref pars 1) #f))
	  (edigits (if (fx> l 2) (list-ref pars 2) #f))
	  (overch (if (fx> l 4) (list-ref pars 4) #f))
	  (padch (if (fx> l 5) (list-ref pars 5) #f)))
      (format:parse-float
       clfs
       (if (string? number) number (number->string number)) #t 0)
      (format:fn-strip clfs)
      (let* ((ee (if edigits (fx+ edigits 2) 4)) ; for the following algorithm
	     (ww (if width (fx- width ee) #f)) ; see Steele's CL book p.395
	     (n (if (fx= (format:fn-dot clfs) 0) ; number less than (abs 1.0) ?
		    (fxneg (format:fn-zlead clfs))
		    (format:fn-dot clfs)))
	     (d (if digits
		    digits
		    (fxmax (format:fn-len clfs) (fxmin n 7)))) ; q = format:fn-len
	     (dd (fx- d n)))
	(if (and (fx<= 0 dd) (fx<= dd d))
	    (begin
	      (format:out-fixed clfs modifier number (list ww dd #f overch padch))
	      (format:out-fill clfs ee #\space)) ;address@hidden not implemented yet
	    (format:out-expon clfs modifier number pars))))))

;; format dollar flonums (~$)

(define (format:out-dollar clfs modifier number pars)
  (unless (or (number? number) (string? number))
	  (format:error clfs "argument is not a number or a number string" number))
  (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)))
      
      (format:parse-float
       clfs
       (if (string? number) number (number->string number)) #t 0)
      (if (fx<= (fx- (format:fn-len clfs) (format:fn-dot clfs)) digits)
	  (format:fn-zfill clfs #f (fx- digits (fx- (format:fn-len clfs) (format:fn-dot clfs))))
	  (format:fn-round clfs digits))
      (let ((numlen (fx+ (format:fn-len clfs) 1)))
	(when (or (not (format:fn-pos? clfs)) (memq modifier '(at colon-at)))
	      (set! numlen (fx+ numlen 1)))
	(when (and mindig (fx> mindig (format:fn-dot clfs)))
	      (set! numlen (fx+ numlen (fx- mindig (format:fn-dot clfs)))))
	(when (and (fx= (format:fn-dot clfs) 0) (not mindig))
	      (set! numlen (fx+ numlen 1)))
	(if (fx< numlen width)
	    (case modifier
	      ((colon)
	       (if (not (format:fn-pos? clfs))
		   (format:out-char clfs #\-))
	       (format:out-fill clfs (fx- width numlen) (integer->char padch)))
	      ((at)
	       (format:out-fill clfs (fx- width numlen) (integer->char padch))
	       (format:out-char clfs (if (format:fn-pos? clfs) #\+ #\-)))
	      ((colon-at)
	       (format:out-char clfs (if (format:fn-pos? clfs) #\+ #\-))
	       (format:out-fill clfs (fx- width numlen) (integer->char padch)))
	      (else
	       (format:out-fill clfs (fx- width numlen) (integer->char padch))
	       (unless (format:fn-pos? clfs)
		       (format:out-char clfs #\-))))
	    (if (format:fn-pos? clfs)
		(if (memq modifier '(at colon-at)) (format:out-char clfs #\+))
		(format:out-char clfs #\-))))
      (when (and mindig (fx> mindig (format:fn-dot clfs)))
	    (format:out-fill clfs (fx- mindig (format:fn-dot clfs)) #\0))
      (when (and (fx= (format:fn-dot clfs) 0) (not mindig))
	    (format:out-char clfs #\0))
      (format:out-substr clfs (format:fn-str clfs) 0 (format:fn-dot clfs))
      (format:out-char clfs #\.)
      (format:out-substr clfs (format:fn-str clfs) (format:fn-dot clfs) (format:fn-len clfs)))))

;; prepare state to refine a floating number

(define (format:parse-float clfs num-str fixed? scale)
  (define fn-str (make-string format:fn-max))
  (define en-str (make-string format:en-max))
  (format:fn-str-set! clfs fn-str)
  (format:fn-pos?-set! clfs #t)
  (format:fn-len-set! clfs 0)
  (format:fn-dot-set! clfs #f)
  (format:en-pos?-set! clfs #t)
  (format:en-str-set! clfs en-str)
  (format:en-len-set! clfs 0)
  (do ((i 0 (fx+ i 1))
       (left-zeros 0)
       (mantissa? #t)
       (all-zeros? #t)
       (num-len (string-length num-str))
       (c #f))                  ; current exam. character in num-str
      ((fx= i num-len)
       (unless (format:fn-dot clfs)
	       (format:fn-dot-set! clfs (format:fn-len clfs)))

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

       ;; now format the parsed values according to format's need
       (if fixed?

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

	   (let ((negexp              ; expon format m.nnnEee
		  (if (fx> left-zeros 0)
		      (fx+ (fx- left-zeros (format:fn-dot clfs)) 1)
		      (if (fx= (format:fn-dot clfs) 0) 1 0))))
	     (if (fx> left-zeros 0)
		 (begin               ; normalize 0{0}.nnn to n.nn
		   (format:fn-shiftleft clfs left-zeros)
		   (format:fn-dot-set! clfs 1))
		 (when (fx= (format:fn-dot clfs) 0)
		       (format:fn-dot-set! clfs 1)))
	     (format:en-set clfs (fx- (fx+ (fx- (format:fn-dot clfs) scale) (format:en-int clfs)) negexp))
	     (cond
	      (all-zeros?
	       (format:en-set clfs 0)
	       (format:fn-dot-set! clfs 1))
	      ((fx< scale 0)          ; leading zero
	       (format:fn-zfill clfs #t (fxneg scale))
	       (format:fn-dot-set! clfs 0))
	      ((fx> scale (format:fn-dot clfs))
	       (format:fn-zfill clfs #f (fx- scale (format:fn-dot clfs)))
	       (format:fn-dot-set! clfs scale))
	      (else
	       (format:fn-dot-set! clfs 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)
		(when all-zeros?
		      (set! left-zeros (fx+ left-zeros 1)))
		(set! all-zeros? #f))
	    (string-set! fn-str (format:fn-len clfs) c)
	    (format:fn-len-set! clfs (fx+ (format:fn-len clfs) 1)))
	  (begin
	    (string-set! en-str (format:en-len clfs) c)
	    (format:en-len-set! clfs (fx+ (format:en-len clfs) 1)))))
     ((or (char=? c #\-) (char=? c #\+))
      (if mantissa?
	  (format:fn-pos?-set! clfs (char=? c #\+))
	  (format:en-pos?-set! clfs (char=? c #\+))))
     ((char=? c #\.)
      (format:fn-dot-set! clfs (format:fn-len clfs)))
     ((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 clfs "illegal character in number->string" c)))))

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

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

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

(define (format:fn-shiftleft clfs n) ; shift left current number n positions
  (define f:fn-len (format:fn-len clfs))
  (define f:fn-str (format:fn-str clfs))
  (when (fx> n f:fn-len)
	(format:error clfs "internal error in format:fn-shiftleft"
		      (list n f:fn-len)))
  (do ((i n (fx+ i 1)))
      ((fx= i f:fn-len)
       (format:fn-len-set! clfs (fx- f:fn-len n)))
    (string-set! f:fn-str (fx- i n) (string-ref f:fn-str i))))

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

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

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

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

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

;; format:char->str converts a character into a slashified string as
;; done by `write'. The procedure is dependent on the integer
;; representation of characters and assumes a character number
;; according to the ASCII character set.

(define (format:char->str ch)
  (let ((int-rep (char->integer ch)))
    (if (fx< int-rep 0)                 ; if chars are [-128...+127]
        (set! int-rep (fx+ int-rep 256)))
    (string-append
     "#\\"
     (cond
      ((char=? ch #\newline) "newline")
      ((and (fx>= int-rep 0) (fx<= int-rep 32))
       (vector-ref format:ascii-non-printable-charnames int-rep))
      ((fx= int-rep 127) "del")
      ((fx>= int-rep 128)                       ; octal representation
       (if format:radix-pref
           (let ((s (number->string int-rep 8)))
             (substring s 2 (string-length s)))
           (number->string int-rep 8)))
      (else (string ch))))))

;; format:iobj->str reveals the implementation dependent
;; representation of #<...> objects with the use of display and
;; call-with-output-string.

(define (format:iobj->str iobj read-proof)
  (if (or read-proof
          format:iobj-case-conv)
      (string-append
       (if read-proof "\"" "")
       (if format:iobj-case-conv
	   (format:iobj-case-conv
	    (call-with-output-string (lambda (p) (display iobj p))))
	   (call-with-output-string (lambda (p) (display iobj p))))
       (if read-proof "\"" ""))
      (call-with-output-string (lambda (p) (display iobj p)))))

;; format:obj->str returns a R4RS representation as a string of an
;; arbitrary scheme object.
;;
;; First parameter is the object, second parameter is a boolean if
;; the representation should be slashified as `write' does.
;;
;; It uses format:char->str which converts a character into a
;; slashified string as `write' does and which is implementation
;; dependent.
;;
;; It uses format:iobj->str to print out internal objects as quoted
;; strings so that the output can always be processed by (read)

(define (format:obj->str clfs obj slashify)
  (cond
   ((string? obj)
    (if slashify
	(let ((obj-len (string-length obj)))
	  (string-append
	   "\""
	   (let loop ((i 0) (j 0))   ; taken from Marc Feeley's pp.scm
	     (if (fx= j obj-len)
		 (string-append (substring obj i j) "\"")
		 (let ((c (string-ref obj j)))
		   (if (or (char=? c #\\)
			   (char=? c #\"))
		       (string-append (substring obj i j) "\\"
				      (loop j (fx+ j 1)))
		       (loop i (fx+ j 1))))))))
	obj))

   ((boolean? obj) (if obj "#t" "#f"))

   ((number? obj) (number->string obj))

   ((symbol? obj)
    (if format:symbol-case-conv
	(format:symbol-case-conv (symbol->string obj))
	(symbol->string obj)))

   ((char? obj)
    (if slashify
	(format:char->str obj)
	(string obj)))

   ((null? obj) "()")

   ((input-port? obj)
    (format:iobj->str obj (format:read-proof clfs)))

   ((output-port? obj)
    (format:iobj->str obj (format:read-proof clfs)))

   ((list? obj)
    (string-append
     "("
     (let loop ((obj-list obj))
       (if (null? (cdr obj-list))
	   (format:obj->str clfs (car obj-list) #t)
	   (string-append
	    (format:obj->str clfs (car obj-list) #t)
	    " "
	    (loop (cdr obj-list)))))
     ")"))

   ((pair? obj)
    (string-append
     "("
     (format:obj->str clfs (car obj) #t)
     " . "
     (format:obj->str clfs (cdr obj) #t)
     ")"))

   ((vector? obj)
    (string-append "#" (format:obj->str clfs (vector->list obj) #t)))

   (else                                ; only objects with an #<...>
    (format:iobj->str obj (format:read-proof clfs)))))
                                        ; representation should fall in here

;;

(define (format: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 (fx+ i 1)))
        ((fx= 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)))))))))
;;

(define (format:format-work clfs 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 clfs))

	   (next-char											; gets the next char from format-string
	    (lambda ()
	      (let ((ch (peek-next-char)))
		(format:pos-set! clfs (fx+ 1 (format:pos clfs)))
		ch)))

	   (peek-next-char
	    (lambda ()
	      (if (fx>= (format:pos clfs) format-string-len)
		  (format:error clfs "illegal format string")
		  (string-ref format-string (format:pos clfs)))))

	   (one-positive-integer?
	    (lambda (params)
	      (cond
	       ((null? params) #f)
	       ((and (fixnum? (car params))
		     (fx>= (car params) 0)
		     (fx= (length params) 1)) #t)
	       (else (format:error clfs "one positive integer parameter expected")))))

	   (next-arg
	    (lambda ()
	      (if (fx>= arg-pos arg-len)
		  (begin
		    (format:arg-pos-set! clfs (+ arg-len 1))
		    (format:error clfs "missing argument(s)")))
	      (add-arg-pos 1)
	      (list-ref arglist (fx- arg-pos 1))))

	   (prev-arg
	    (lambda ()
	      (add-arg-pos -1)
	      (if (fx< arg-pos 0)
		  (format:error clfs "missing backward argument(s)"))
	      (list-ref arglist arg-pos)))

	   (rest-args
	    (lambda ()
	      (let loop ((l arglist) (k arg-pos)) ; list-tail definition
		(if (fx= k 0) l (loop (cdr l) (fx- k 1))))))

	   (add-arg-pos
	    (lambda (n)
	      (set! arg-pos (fx+ n arg-pos))
	      (format:arg-pos-set! clfs arg-pos)))

	   (anychar-dispatch              ; dispatches the format-string
	    (lambda ()
	      (if (fx>= (format:pos clfs) 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
		      (when (and (fx= 0 conditional-nest) (fx= 0 iteration-nest))
			    (format:out-char clfs char))
		      (anychar-dispatch)))))))

	   (tilde-dispatch
	    (lambda ()
	      (cond
	       ((fx>= (format:pos clfs) format-string-len)
		(format:out-str clfs "~")				; tilde at end of string is just output
		arg-pos)                  	; used for ~? continuance
	       ((and (or (fx= 0 conditional-nest)
			 (memv (peek-next-char)
			       format:conditional-directives-characters))
		     (or (fx= 0 iteration-nest)
			 (memv (peek-next-char)
			       format:iteration-directives-characters)))

		  ;;;; ((#\a) ; any but backward compatible with underlying Scheme
		  ;;;;  (format:out-str-noconv clfs (format "~a" (next-arg)))
		  ;;;;  (anychar-dispatch))

		(case (char-upcase (next-char))

		  ;; format directives

		  ((#\A)                  ; Any -- for humans
		   (format:read-proof-set! clfs (memq modifier '(colon colon-at)))
		   (format:out-obj-padded clfs (memq modifier '(at colon-at))
					  (next-arg) #f params)
		   (anychar-dispatch))
		  ((#\S)                  ; Slashified -- for parsers
		   (format:read-proof-set! clfs (memq modifier '(colon colon-at)))
		   (format:out-obj-padded clfs (memq modifier '(at colon-at))
					  (next-arg) #t params)
		   (anychar-dispatch))
		  ((#\D)                  ; Decimal
		   (format:out-num-padded clfs modifier (next-arg) params 10)
		   (anychar-dispatch))
		  ((#\X)                  ; Hexadecimal
		   (format:out-num-padded clfs modifier (next-arg) params 16)
		   (anychar-dispatch))
		  ((#\O)                  ; Octal
		   (format:out-num-padded clfs modifier (next-arg) params 8)
		   (anychar-dispatch))
		  ((#\B)                  ; Binary
		   (format:out-num-padded clfs modifier (next-arg) params 2)
		   (anychar-dispatch))
		  ((#\R)
		   (if (null? params)
		       (format:out-obj-padded clfs ; 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))
			 clfs (next-arg))
			#f params)
		       (format:out-num-padded clfs ; any Radix
			modifier (next-arg) (cdr params) (car params)))
		   (anychar-dispatch))
		  ((#\F)                  ; Fixed-format floating-point
		   (if format:floats
		       (format:out-fixed clfs modifier (next-arg) params)
		       (format:out-str clfs (number->string (next-arg))))
		   (anychar-dispatch))
		  ((#\E)                  ; Exponential floating-point
		   (if format:floats
		       (format:out-expon clfs modifier (next-arg) params)
		       (format:out-str clfs (number->string (next-arg))))
		   (anychar-dispatch))
		  ((#\G)                  ; General floating-point
		   (if format:floats
		       (format:out-general clfs modifier (next-arg) params)
		       (format:out-str clfs (number->string (next-arg))))
		   (anychar-dispatch))
		  ((#\$)                  ; Dollars floating-point
		   (if format:floats
		       (format:out-dollar clfs modifier (next-arg) params)
		       (format:out-str clfs (number->string (next-arg))))
		   (anychar-dispatch))
		  ((#\I)                  ; Complex numbers
		   (unless format:complex-numbers
			   (format:error
			    clfs "complex numbers not supported by this scheme system"))
		   (let ((z (next-arg)))
		     (unless (complex? z)
			     (format:error clfs "argument not a complex number"))
		     (format:out-fixed clfs modifier (real-part z) params)
		     (format:out-fixed clfs 'at (imag-part z) params)
		     (format:out-char clfs #\i))
		   (anychar-dispatch))
		  ((#\C)                  ; Character
		   (let ((ch (if (one-positive-integer? params)
				 (integer->char (car params))
				 (next-arg))))
		     (unless (char? ch)
			     (format:error clfs "~~c expects a character" ch))
		     (case modifier
		       ((at)
			(format:out-str clfs (format:char->str ch)))
		       ((colon)
			(let ((c (char->integer ch)))
			  (when (fx< c 0)
				(set! c (fx+ c 256)))       	; compensate complement impl.
			  (cond
			   ((fx< c #x20) ; assumes that control chars are < #x20
			    (format:out-char clfs #\^)
			    (format:out-char clfs (integer->char (fx+ c #x40))))
			   ((fx>= c #x7f)
			    (format:out-str clfs "#\\")
			    (format:out-str clfs
			     (if format:radix-pref
				 (let ((s (number->string c 8)))
				   (substring s 2 (string-length s)))
				 (number->string c 8))))
			   (else
			    (format:out-char clfs ch)))))
		       (else (format:out-char clfs ch))))
		   (anychar-dispatch))
		  ((#\P)                  ; Plural
		   (when (memq modifier '(colon colon-at))
			 (prev-arg))
		   (let ((arg (next-arg)))
		     (unless (number? arg)
			     (format:error clfs "~~p expects a number argument" arg))
		     (if (fx= arg 1)
			 (when (memq modifier '(at colon-at))
			       (format:out-char clfs #\y))
			 (if (memq modifier '(at colon-at))
			     (format:out-str clfs "ies")
			     (format:out-char clfs #\s))))
		   (anychar-dispatch))
		  ((#\~)                  ; Tilde
		   (if (one-positive-integer? params)
		       (format:out-fill clfs (car params) #\~)
		       (format:out-char clfs #\~))
		   (anychar-dispatch))
		  ((#\%)                  ; Newline
		   (if (one-positive-integer? params)
		       (format:out-fill clfs (car params) #\newline)
		       (format:out-char clfs #\newline))
		   (format:output-col-set! clfs 0)
		   (anychar-dispatch))
		  ((#\&)                  ; Fresh line
		   (if (one-positive-integer? params)
		       (begin
			 (when (fx> (car params) 0)
			       (format:out-fill clfs
				(fx- (car params) (if (fx> (format:output-col clfs) 0) 0 1))
				#\newline))
			 (format:output-col-set! clfs 0))
		       (when (fx> (format:output-col clfs) 0)
			     (format:out-char clfs #\newline)))
		   (anychar-dispatch))
		  ((#\_)                  ; Space character
		   (if (one-positive-integer? params)
		       (format:out-fill clfs (car params) #\space)
		       (format:out-char clfs #\space))
		   (anychar-dispatch))
		  ((#\/)                  ; Tabulator character
		   (if (one-positive-integer? params)
		       (format:out-fill clfs (car params) #\tab)
		       (format:out-char clfs #\tab))
		   (anychar-dispatch))
		  ((#\|)                  ; Page seperator
		   (if (one-positive-integer? params)
		       (format:out-fill clfs (car params) #\page)
		       (format:out-char clfs #\page))
		   (format:output-col-set! clfs 0)
		   (anychar-dispatch))
		  ((#\T)                  ; Tabulate
		   (format:tabulate clfs modifier params)
		   (anychar-dispatch))
		  ((#\Y)                  ; Pretty-print
		   (pretty-print (next-arg) (format:port clfs))
		   (format:output-col-set! clfs 0)
		   (anychar-dispatch))
		  ((#\? #\K)         ; Indirection (is "~K" in T-Scheme)
		   (cond
		    ((memq modifier '(colon colon-at))
		     (format:error clfs "illegal modifier in ~~?" modifier))
		    ((eq? modifier 'at)
		     (let* ((frmt (next-arg))
			    (args (rest-args)))
		       (add-arg-pos (format:format-work clfs frmt args))))
		    (else
		     (let* ((frmt (next-arg))
			    (args (next-arg)))
		       (format:format-work clfs frmt args))))
		   (anychar-dispatch))
		  ((#\!)                  ; Flush output
		   (format:flush-output-set! clfs #t)
		   (anychar-dispatch))
		  ((#\newline)            ; Continuation lines
		   (when (eq? modifier 'at)
			 (format:out-char clfs #\newline))
		   (when (fx< (format:pos clfs) format-string-len)
			 (do ((ch (peek-next-char) (peek-next-char)))
			     ((or (not (char-whitespace? ch))
				  (fx= (format:pos clfs) (fx- format-string-len 1))))
			   (if (eq? modifier 'colon)
			       (format:out-char clfs (next-char))
			       (next-char))))
		   (anychar-dispatch))
		  ((#\*)                  ; Argument jumping
		   (case modifier
		     ((colon)             ; jump backwards
		      (if (one-positive-integer? params)
			  (do ((i 0 (fx+ i 1)))
			      ((fx= 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 clfs "illegal modifier `:@' in ~~* directive"))
		     (else                ; jump forward
		      (if (one-positive-integer? params)
			  (do ((i 0 (fx+ i 1)))
			      ((fx= i (car params)))
			    (next-arg))
			  (next-arg))))
		   (anychar-dispatch))
		  ((#\()                  ; Case conversion begin
		   (format:case-conversion-set!
		    clfs
		    (case modifier
		      ((at) format:string-capitalize-first)
		      ((colon)
					; string-titlecase
		       format:string-capitalize-first
		       )
		      ((colon-at) string-upcase)
		      (else string-downcase)))
		   (anychar-dispatch))
		  ((#\))                  ; Case conversion end
		   (unless (format:case-conversion clfs)
			   (format:error clfs "missing ~~)"))
		   (format:case-conversion-set! clfs #f)
		   (anychar-dispatch))
		  ((#\[)                  ; Conditional begin
		   (set! conditional-nest (fx+ conditional-nest 1))
		   (cond
		    ((fx= conditional-nest 1)
		     (set! clause-pos (format:pos clfs))
		     (set! clause-default #f)
		     (set! clauses '())
		     (set! conditional-type
			   (case modifier
			     ((at) 'if-then)
			     ((colon) 'if-else-then)
			     ((colon-at) (format:error clfs "illegal modifier in ~~]"))
			     (else 'num-case)))
		     (set! conditional-arg
			   (if (one-positive-integer? params)
			       (car params)
			       (next-arg)))))
		   (anychar-dispatch))
		  ((#\;)                  ; Conditional separator
		   (when (fx= 0 conditional-nest)
			 (format:error clfs "~~; not in ~~]~~[ conditional"))
		   (unless (null? params)
			   (format:error clfs "no parameter allowed in ~~;"))
		   (when (fx= conditional-nest 1)
			 (let ((clause-str
				(cond
				 ((eq? modifier 'colon)
				  (set! clause-default #t)
				  (substring format-string clause-pos
					     (fx- (format:pos clfs) 3)))
				 ((memq modifier '(at colon-at))
				  (format:error clfs "illegal modifier in ~~;"))
				 (else
				  (substring format-string clause-pos
					     (fx- (format:pos clfs) 2))))))
			   (set! clauses (append clauses (list clause-str)))
			   (set! clause-pos (format:pos clfs))))
		   (anychar-dispatch))
		  ((#\])                  ; Conditional end
		   (when (fx= 0 conditional-nest)
			 (format:error clfs "missing ~~]"))
		   (set! conditional-nest (fx- conditional-nest 1))
		   (when modifier
			 (format:error clfs "no modifier allowed in ~~["))
		   (unless (null? params)
			   (format:error clfs "no parameter allowed in ~~["))
		   (cond
		    ((fx= 0 conditional-nest)
		     (let ((clause-str (substring format-string clause-pos
						  (fx- (format:pos clfs) 2))))
		       (if clause-default
			   (set! clause-default clause-str)
			   (set! clauses (append clauses (list clause-str)))))
		     (case conditional-type
		       ((if-then)
			(when conditional-arg
			      (format:format-work clfs (car clauses)
						  (list conditional-arg))))
		       ((if-else-then)
			(add-arg-pos
			 (format:format-work clfs
			  (if conditional-arg (cadr clauses) (car clauses))
			  (rest-args))))
		       ((num-case)
			(when (or (not (integer? conditional-arg))
				  (fx< conditional-arg 0))
			      (format:error clfs "argument not a positive integer"))
			(when (not (and (fx>= conditional-arg (length clauses))
					(not clause-default)))
			      (add-arg-pos
			       (format:format-work
				clfs
				(if (fx>= conditional-arg (length clauses))
				    clause-default
				    (list-ref clauses conditional-arg))
				(rest-args))))))))
		   (anychar-dispatch))
		  ((#\{)                  ; Iteration begin
		   (set! iteration-nest (fx+ iteration-nest 1))
		   (cond
		    ((fx= iteration-nest 1)
		     (set! iteration-pos (format:pos clfs))
		     (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
		   (when (fx= 0 iteration-nest)
			 (format:error clfs "missing ~~{"))
		   (set! iteration-nest (fx- iteration-nest 1))
		   (case modifier
		     ((colon)
		      (unless max-iterations (set! max-iterations 1)))
		     ((colon-at at) (format:error clfs "illegal modifier" modifier))
		     (else (unless max-iterations
				   (set! max-iterations format:max-iterations))))
		   (unless (null? params)
			   (format:error clfs "no parameters allowed in ~~}" params))
		   (when (fx= 0 iteration-nest)
			 (let ((iteration-str
				(substring format-string iteration-pos
					   (fx- (format:pos clfs) (if modifier 3 2)))))
			   (when (string=? iteration-str "")
				 (set! iteration-str (next-arg)))
			   (case iteration-type
			     ((list)
			      (let ((args (next-arg))
				    (args-len 0))
				(unless (list? args)
					(format:error clfs "expected a list argument" args))
				(set! args-len (length args))
				(do ((arg-pos 0 (fx+ arg-pos
						     (format:format-work
						      clfs
						      iteration-str
						      (list-tail args arg-pos))))
				     (i 0 (fx+ i 1)))
				    ((or (fx>= arg-pos args-len)
					 (and format:iteration-bounded
					      (fx>= i max-iterations)))))))
			     ((sublists)
			      (let ((args (next-arg))
				    (args-len 0))
				(unless (list? args)
					(format:error clfs "expected a list argument" args))
				(set! args-len (length args))
				(do ((arg-pos 0 (fx+ arg-pos 1)))
				    ((or (fx>= arg-pos args-len)
					 (and format:iteration-bounded
					      (fx>= arg-pos max-iterations))))
				  (let ((sublist (list-ref args arg-pos)))
				    (unless (list? sublist)
					    (format:error
					     clfs "expected a list of lists argument" args))
				    (format:format-work clfs iteration-str sublist)))))
			     ((rest-args)
			      (let* ((args (rest-args))
				     (args-len (length args))
				     (usedup-args
				      (do ((arg-pos 0 (fx+ arg-pos
							   (format:format-work
							    clfs
							    iteration-str
							    (list-tail
							     args arg-pos))))
					   (i 0 (fx+ i 1)))
					  ((or (fx>= arg-pos args-len)
					       (and format:iteration-bounded
						    (fx>= 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 (fx+ arg-pos 1)))
					  ((or (fx>= arg-pos args-len)
					       (and format:iteration-bounded
						    (fx>= arg-pos max-iterations)))
					   arg-pos)
					(let ((sublist (list-ref args arg-pos)))
					  (if (not (list? sublist))
					      (format:error clfs "expected list arguments" args))
					  (format:format-work clfs iteration-str sublist)))))
				(add-arg-pos usedup-args)))
			     (else (format:error clfs "internal error in ~~}")))))
		   (anychar-dispatch))
		  ((#\^)                  ; Up and out
		   (let* ((continue
			   (cond
			    ((not (null? params))
			     (not
			      (case (length params)
				((1) (fx= 0 (car params)))
				((2) (fx= (list-ref params 0) (list-ref params 1)))
				((3) (and (fx<= (list-ref params 0) (list-ref params 1))
					  (fx<= (list-ref params 0) (list-ref params 2))))
				(else (format:error clfs "too many parameters")))))
			    ((format:case-conversion clfs) ; if conversion stop conversion
			     (format:case-conversion-set! clfs #f) #t)
			    ((fx= iteration-nest 1) #t)
			    ((fx= conditional-nest 1) #t)
			    ((fx>= arg-pos arg-len)
			     (format:pos-set! clfs format-string-len) #f)
			    (else #t))))
		     (when continue
			   (anychar-dispatch))))

		  ;; format directive modifiers and parameters

		  ((#\@)                  ; `@' modifier
		   (when (memq modifier '(at colon-at))
			 (format:error clfs "double `@' modifier"))
		   (set! modifier (if (eq? modifier 'colon) 'colon-at 'at))
		   (tilde-dispatch))
		  ((#\:)                  ; `:' modifier
		   (when (memq modifier '(colon colon-at))
			 (format:error clfs "double `:' modifier"))
		   (set! modifier (if (eq? modifier 'at) 'colon-at 'colon))
		   (tilde-dispatch))
		  ((#\')                  ; Character parameter
		   (when modifier
			 (format:error clfs "misplaced modifier" 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
		   (when modifier
			 (format:error clfs "misplaced modifier" modifier))
		   (let ((num-str-beg (fx- (format:pos clfs) 1))
			 (num-str-end (format:pos clfs)))
		     (do ((ch (peek-next-char) (peek-next-char)))
			 ((not (char-numeric? ch)))
		       (next-char)
		       (set! num-str-end (fx+ 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.
		   (when modifier
			 (format:error clfs "misplaced modifier" modifier))
		   (set! params (append params (list (next-arg))))
		   (set! param-value-found #t)
		   (tilde-dispatch))
		  ((#\#)         ; Parameter is number of remaining args
		   (when modifier
			 (format:error clfs "misplaced modifier" modifier))
		   (set! params (append params (list (length (rest-args)))))
		   (set! param-value-found #t)
		   (tilde-dispatch))
		  ((#\,)                  ; Parameter separators
		   (when modifier
			 (format:error clfs "misplaced modifier" modifier))
		   (unless 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 clfs format:version)
		       (let ((nl (string #\newline)))
			 (format:out-str
			  clfs
			  (string-append
			   "SLIB Common LISP format version " format:version nl
			   "  This code is in the public domain." nl
			   "  Please send bug reports to address@hidden'"
			   nl))))
		   (anychar-dispatch))
		  (else                   ; Unknown tilde directive
		   (format:error clfs "unknown control character"
				 (string-ref format-string (fx- (format:pos clfs) 1))))))
	       (else (anychar-dispatch)))))) ; in case of conditional

    (format:pos-set! clfs 0)
    (format:arg-pos-set! clfs 0)
    (anychar-dispatch)                ; start the formatting
    (format:pos-set! clfs recursive-pos-save)
    arg-pos))

;; the output handler for a port

(define (format:out clfs fmt args)
  (format:case-conversion-set! clfs #f)    ; modifier case conversion procedure
  (format:flush-output-set! clfs #f)       ; ~! reset
  (let ((arg-pos (format:format-work clfs fmt args))
	(arg-len (length args)))
    (cond
     ((fx< arg-pos arg-len)
      (format:arg-pos-set! clfs (+ arg-pos 1))
      (format:pos-set! clfs (string-length fmt))
      (if format:unprocessed-arguments-error?
	  (format:error clfs "superfluous arguments" (fx- arg-len arg-pos))))
     ((fx> arg-pos arg-len)
      (format:arg-pos-set! clfs (+ arg-len 1))
      (format:error clfs "missing arguments" (fx- arg-pos arg-len))))))

;; We should keep separate track of columns for each port.

(define *format:get-port-column* (make-parameter 0))

(define (format:get-port-column port) (*format:get-port-column*))

(define (format:set-port-column! port col)
  (format:get-port-column col))

;;; Format entry-point

;@
(define (clformat* clfs args)
  (let ((destination (car args))
	(arglist (cdr args)))
    (cond
     ((or (and (boolean? destination) ; port output
	       destination)
	  (output-port? destination)
	  (number? destination))
      (let ((port (cond ((boolean? destination) (current-output-port))
			((output-port? destination) destination)
			((number? destination) (current-error-port)))))
	(format:port-set! clfs port)    ; port for output routines
	(format:output-col-set! clfs (format:get-port-column port))
	(format:out clfs (car arglist) (cdr arglist))
	(format:set-port-column! port (format:output-col clfs))
	(if (format:flush-output clfs) (flush-output port))
	#t))
     ((and (boolean? destination)     ; string output
	   (not destination))
      (call-with-output-string
       (lambda (port)
	 (format:port-set! clfs port)
	 (format:output-col-set! clfs 0)
	 (format:out clfs (car arglist) (cdr arglist)))))
     (else
      (format:error clfs "illegal destination" destination)))))

(define (format . args)
  ;; If the first argument is a string, then that's the format string.
  ;; (Scheme->C)
  ;; In this case, put the argument list in canonical form.
  (if (string? (car args)) (set! args (cons #f args)) args)
  (let ((clfs (make-clformat-state
		args
		0    ;; arg-pos
		#f   ;; port
		0    ;; column
		0    ;; pos
		#f   ;; read-proof
		#f   ;; flush
		#f   ;; case-conversion
		#f   ;; fn-str
		0    ;; fn-len
		#t   ;; fn-pos?
		#f   ;; fn-dot
		#f   ;; en-str
		0    ;; en-len
		#t   ;; en-pos?
		)))
     (if (fx< (length args) 1)
	 (format:error clfs "not enough arguments"))
     (clformat* clfs args)))

 )

(import (prefix format m:))
(define clformat m:format)