; FILE AUTOMATICALLY GENERATED!
;
; This file was automatically generated by the svnwiki-scheme-library extension.
; The authoritative source for this is:
;
;   http://wiki.freaks-unidos.net/weblogs/azul/format-compiler
;
; Generation data:
;
;   Input revision: 16998
;   User: www-data
;   Machine: mononykus.freaks-unidos.net
;   Date: Mon Jul  5 21:33:46 2010

(require-library extras)

(module format-compiler-base *

(import chicken scheme)
(use ports posix srfi-13 srfi-1 srfi-14 data-structures)
(import (except extras format))

(define-record compiler table escape)

(define (formatter->table case-sensitive formatters . rest-xrenamed)
  (let-optionals rest-xrenamed ((default-formatter formatter-unknown-control-error))
    (let ((table (make-vector 256 default-formatter)))
      (for-each
        (lambda (definitions)
          (for-each
            (if case-sensitive
                (lambda (binding)
                  (vector-set! table (char->integer (car binding)) (cadr binding)))
                (lambda (binding)
                  (vector-set! table (char->integer (char-upcase   (car binding))) (cadr binding))
                  (vector-set! table (char->integer (char-downcase (car binding))) (cadr binding))))
            definitions))
        (reverse formatters))
      table)))

(define-record compiler-state compiler fmt fmt-pos default-clause-follows nest)

(define (compiler-state-nest-push! state char)
  (let ((state (if (escape-call? state)
                 (escape-call-compiler-state state)
                 state)))
    (compiler-state-nest-set! state
      (cons char (compiler-state-nest state)))))

(define (compiler-state-nest-pop! state char)
  (let ((state (if (escape-call? state)
                 (escape-call-compiler-state state)
                 state)))
    (when (null? (compiler-state-nest state))
      (formatter-error "Nesting error, missing control character" char))
    (unless (char=? (car (compiler-state-nest state)) char)
      (formatter-error "Improper nesting for character" char))
    (compiler-state-nest-set! state (cdr (compiler-state-nest state)))))

(define-record escape-call compiler-state start colon atsign params)

(define-record state out obj obj-pos colpos params)

(define (make-default-state out objs)
  (assert (port? out))
  (assert (list? objs))
  (make-state out (list->vector objs) 0 0 '()))

(define (state-obj-pos-inc! state . rest-xrenamed)
  (let-optionals rest-xrenamed ((times 1))
    (state-obj-pos-set! state (fx+ (state-obj-pos state) times)) ) )

(define (state-obj-ref state . rest-xrenamed)
  (let-optionals rest-xrenamed ((inctimes 0))
    (let ((obj (vector-ref (state-obj state) (state-obj-pos state))))
      (state-obj-pos-inc! state inctimes)
      obj)))

(define (formatter-unknown-control-error call)
  (let ((state (escape-call-compiler-state call)))
    (formatter-error "Unknown control character"
      (string-ref (compiler-state-fmt state) (- (compiler-state-fmt-pos state) 1)))))

(define (formatter-error . rest-xrenamed)
  (apply error 'format-modular rest-xrenamed))

(define (make-format-compiler case-sensitive escape formatters)
  (let ((compiler (make-compiler (formatter->table case-sensitive formatters) escape)))
    (lambda (fmt)
      (let ((proc (compile-format-string (make-compiler-state compiler fmt 0 #f '()))))
        (lambda (out . args)
          (cond
            ((not out)
             (call-with-output-string (lambda (out) (proc (make-default-state out args)))))
            ((boolean? out)
             (proc (make-default-state (current-output-port) args)))
            ((output-port? out)
             (proc (make-default-state out args)))
            (else
             (formatter-error "invalid destination" out))))))))

(define (compile-format-string state)
  (let* ((fmt (compiler-state-fmt state))
         (fmt-length (string-length fmt))
         (pos (compiler-state-fmt-pos state))
         (pos-escape (string-index
                       fmt
                       (compiler-escape (compiler-state-compiler state))
                       (compiler-state-fmt-pos state))))
    (compiler-state-fmt-pos-set! state (if pos-escape (+ pos-escape 1) fmt-length))
    (formatter-write-substring fmt pos (or pos-escape fmt-length)
      (if pos-escape
        (compile-escape-sequence
          (make-escape-call state pos-escape #f #f 0))
        (constantly #f)))))

(define (compile-escape-sequence call)
  (let* ((state (escape-call-compiler-state call))
         (fmt (compiler-state-fmt state))
         (fmt-length (string-length fmt))
         (fmt-pos (compiler-state-fmt-pos state)))
    (cond
      ((< fmt-pos fmt-length)
       (compiler-state-fmt-pos-set! state (+ 1 fmt-pos))
       ((vector-ref (compiler-table (compiler-state-compiler state))
          (char->integer (string-ref fmt fmt-pos)))
        call))
      (else
       (escape-call-cancel call)))))

(define (escape-call-cancel call)
  (let ((fmt (compiler-state-fmt (escape-call-compiler-state call))))
    (formatter-write-substring fmt (escape-call-start call) 
      (string-length fmt))))

(define (compile-nested-format-strings state)
  (let loop ((depth (length (compiler-state-nest state)))
             (proc-list '())
             (default-proc #f))
    (if (< (length (compiler-state-nest state)) depth)
      (values (reverse proc-list) default-proc)
      (let ((default-follows (compiler-state-default-clause-follows state))
            (proc (compile-format-string state)))
        (loop
          depth
          (cons proc proc-list)
          (if default-follows proc default-proc))))))

(define (params-consuming-proc proc . rest-xrenamed)
  (let-optionals rest-xrenamed ((keep-going #t))
    (lambda (call)
      (assert (escape-call? call))
      (let ((num-params (escape-call-params call)))
        (escape-call-params-set! call 0)
        (let ((state-proc (proc call num-params))
              (rest-xrenamed (and keep-going
                                  (compile-format-string (escape-call-compiler-state call)))))
          (lambda (state)
            (let ((result (state-proc state (reverse (state-params state)))))
              (state-params-set! state '())
              (if keep-going (rest-xrenamed state) result))))))))

(define (output-generating-proc proc)
  (lambda (state)
    (proc state (state-out state))))

(define (formatter-write-char char . rest-xrenamed)
  (let-optionals rest-xrenamed ((times 1) (rest-xrenamed (constantly #f)))
    (assert (number? times))
    (output-generating-proc
      (let loop ((i 0))
        (if (< i times)
          (let ((rest-xrenamed (loop (+ i 1))))
            (lambda (state out)
              (write-char char out)
              (rest-xrenamed state out)))
          (lambda (state out)
            (state-colpos-set! state
              (if (char=? char #\newline) 0 (+ (state-colpos state) times)))
            (rest-xrenamed state)))))))

(define (formatter-write-substring str start end . rest-xrenamed)
  (assert (string? str))
  (let-optionals rest-xrenamed ((proc (constantly #f)))
    (output-generating-proc
      (let* ((last-newline (string-index-right str #\newline start end))
             (delta (- end (or last-newline start))))
        (let loop ((i start))
          (if (< i end)
            (let ((c (string-ref str i)) (proc (loop (+ i 1))))
              (lambda (state out)
                (write-char c out)
                (proc state out)))
            (lambda (state out)
              (state-colpos-set! state
                (if last-newline delta (+ (state-colpos state) delta)))
              (proc state))))))))

(define (formatter-write-string str . rest-xrenamed)
  (assert (string? str))
  (apply formatter-write-substring str 0 (string-length str) rest-xrenamed))

(define (formatter-out-char-list state char-list)
  (for-each (cut formatter-write-char state <>) char-list))

(define *format-compiler-version*
  "$Id$")

(define *format-compiler-revision* "$Revision$")

(define formatter-version
  (let ((out (string-append
               "Format Compiler\n"
               *format-compiler-version*
               "\nAlejandro Forero Cuervo <azul@freaks-unidos.net>\n")))
    (lambda (call)
      (formatter-write-string
        (if (escape-call-colon call) *format-compiler-version* out)
        (compile-format-string (escape-call-compiler-state call))))))

(define *formatter-version*
  `((#\Q ,formatter-version)))

(define (test-params str)
  (call-with-current-continuation
    (lambda (return)
      ((compile-format-string
         (make-compiler-state 
           (make-compiler
             (formatter->table #f
               `(,*formatter-params* 
                 ((#\X ,(lambda (call)
                          (lambda (state)
                            (return (cons (escape-call-params call)
                                       (reverse (state-params state))))))))))
             #\~)
           (string-append "~" str "X") 0 #f '()))
       (make-state 'port '() 0 0 '())))))

(define (add-param call skip-comma proc)
  (assert (escape-call? call))
  (escape-call-params-set! call (+ 1 (escape-call-params call)))
  (let* ((state (escape-call-compiler-state call))
         (fmt (compiler-state-fmt state))
         (fmt-pos (compiler-state-fmt-pos state)))
    (when (and skip-comma
               (< (+ fmt-pos 1) (string-length fmt))
               (char=? (string-ref fmt fmt-pos) #\,))
      (compiler-state-fmt-pos-set! state (+ fmt-pos 1))))
  (let ((rest-xrenamed (compile-escape-sequence call)))
    (lambda (state)
      (state-params-set! state (cons (proc state) (state-params state)))
      (rest-xrenamed state))))

(define (add-param-character-from-format call)
  (let ((state (escape-call-compiler-state call)))
    (cond
      ((= (compiler-state-fmt-pos state) (string-length (compiler-state-fmt state)))
       (escape-call-cancel call))
      (else
       (compiler-state-fmt-pos-set! state (+ (compiler-state-fmt-pos state) 1))
       (add-param call #t
         (constantly
           (string-ref (compiler-state-fmt state)
                       (- (compiler-state-fmt-pos state) 1))))))))

(define (find-end-of-number fmt i)
  (if (and (< i (string-length fmt))
           (let ((c (string-ref fmt i)))
            (or (char-numeric? c) (char=? c #\+) (char=? c #\-))))
    (find-end-of-number fmt (+ i 1))
    i))

(define (numeric-arg call)
  (let* ((state (escape-call-compiler-state call))
         (fmt (compiler-state-fmt state))
         (start (- (compiler-state-fmt-pos state) 1))
         (end (find-end-of-number fmt (compiler-state-fmt-pos state))))
    (compiler-state-fmt-pos-set! state end)
    (add-param call #t (constantly (string->number (substring fmt start end))))))

(define *formatter-params*
  `((#\: ,(lambda (call)
            (escape-call-colon-set! call #t)
            (compile-escape-sequence call)))
    (#\@ ,(lambda (call)
            (escape-call-atsign-set! call #t)
            (compile-escape-sequence call)))
    (#\' ,add-param-character-from-format)
    (#\# ,(lambda (call)
            (add-param call #t
              (lambda (state)
                (- (vector-length (state-obj state)) (state-obj-pos state))))))
    (#\, ,(lambda (call) (add-param call #f (constantly #f))))
    (#\V ,(lambda (call)
            (add-param call #t (lambda (state) (state-obj-ref state 1)))))
    (#\+ ,numeric-arg)
    (#\- ,numeric-arg)
    (#\0 ,numeric-arg)
    (#\1 ,numeric-arg)
    (#\2 ,numeric-arg)
    (#\3 ,numeric-arg)
    (#\4 ,numeric-arg)
    (#\5 ,numeric-arg)
    (#\6 ,numeric-arg)
    (#\7 ,numeric-arg)
    (#\8 ,numeric-arg)
    (#\9 ,numeric-arg)))

(define (case-convert-char start-first-word start-rest rest-xrenamed)
  (let ((current start-first-word))
    (lambda (c)
      (let ((result (current c)))
        (if (or (char-numeric? c) (char-alphabetic? c))
          (set! current rest-xrenamed)
          (set! current start-rest))
        result))))

(define (case-convert-string str . rest-xrenamed)
  (list->string
    (map-in-order (apply case-convert-char rest-xrenamed) (string->list str))))

(define (caseconv-start call num-params)
  (let ((state (escape-call-compiler-state call)))
    (compiler-state-nest-push! call #\()
    (let ((conv (compile-format-string state))
          (atsign (escape-call-atsign call))
          (colon (escape-call-colon call))
          (boolean->conv (lambda (b) (if b char-upcase char-downcase))))
      (lambda (state params)
        (let ((old-output-port (state-out state))
              (old-colpos (state-colpos state))
              (output (with-output-to-string
                        (lambda ()
                          (state-out-set! state (current-output-port))
                          (conv state)))))
          (state-out-set! state old-output-port)
          (state-colpos-set! state old-colpos)
          ((formatter-write-string
             (case-convert-string
               output
               (boolean->conv (or atsign colon))
               (boolean->conv colon)
               (boolean->conv (and atsign colon)))
             (constantly #f))
           state))))))

(define (caseconv-end call num-params)
  (compiler-state-nest-pop! call #\()
  (constantly #f))

(define *formatter-caseconv*
  `((#\( ,(params-consuming-proc caseconv-start))
    (#\) ,(params-consuming-proc caseconv-end #f))))

(define (formatter-flush call)
  (let ((rest-xrenamed (compile-format-string (escape-call-compiler-state call))))
    (lambda (state)
      (flush-output (state-out state))
      (rest-xrenamed state))))

(define *formatter-flush*
  `((#\! ,formatter-flush)))

(define (formatter-cond-end end-of-block)
  (lambda (call num-params)
    (let ((state (escape-call-compiler-state call)))
      (compiler-state-nest-pop! state #\[)
      (unless end-of-block
        (compiler-state-nest-push! state #\[))
      (compiler-state-default-clause-follows-set! state (escape-call-colon call))
      (constantly #f))))

(define (get-cond-check call num-params)
  (cond
    ((escape-call-colon call)
     (lambda (state _) (if (state-obj-ref state 1) 1 0)))
    ((escape-call-atsign call)
     (lambda (state _)
       (cond
         ((state-obj-ref state) 0)
         (else
          (state-obj-pos-inc! state)
          -1))))
    ((zero? num-params)
     (lambda (state _)
       (state-obj-ref state 1)))
    (else
     (unless (= num-params 1)
       (warning "Parameters will be ignored"))
     (lambda (_ params)
       (car params)))))

(define (formatter-cond-start call num-params)
  (let ((state (escape-call-compiler-state call)))
    (compiler-state-nest-push! state #\[)
    (receive (proc-list default-proc)
             (compile-nested-format-strings state)
      (let ((proc-vector (list->vector proc-list))
            (check (get-cond-check call num-params)))
        (lambda (state params)
          (let ((pos (check state params)))
            (cond
              ((and (<= 0 pos) (< pos (vector-length proc-vector)))
               ((vector-ref proc-vector pos) state))
              (default-proc
               (default-proc state))
              (else
               (error "Invalid position and no default clause" pos)))))))))

(define *formatter-cond*
  `((#\[ ,(params-consuming-proc formatter-cond-start))
    (#\; ,(params-consuming-proc (formatter-cond-end #f) #f))
    (#\] ,(params-consuming-proc (formatter-cond-end #t) #f))))

(define (up-and-out-proc num-params)
  (if (zero? num-params)
    (lambda (state _)
      (= (state-obj-pos state) (vector-length (state-obj state))))
    (lambda (_ params)
      (apply
        (case num-params
          ((1) zero?)
          ((2) =)
          ((3) <=)
          (else (error "Invalid number of parameters" num-params)))
        params))))

(define (formatter-iteration-end end-of-block)
  (params-consuming-proc
    (lambda (call num-params)
      (let ((state (escape-call-compiler-state call)))
        (compiler-state-nest-pop! state #\{)
        (cond
         (end-of-block
          (constantly #t))
         (else
          (compiler-state-nest-push! state #\{)
          (up-and-out-proc num-params)))))
    #f))

(define (run-one-iteration proc-list state)
  (unless ((car proc-list) state)
    (run-one-iteration (cdr proc-list) state)))

(define (formatter-iteration-start call num-params)
  (let ((state (escape-call-compiler-state call)))
    (compiler-state-nest-push! state #\{)
    (receive (proc-list _)
             (compile-nested-format-strings state)
      (let ((atsign (escape-call-atsign call))
            (colon (escape-call-colon call))
            (limit-proc (if (positive? num-params) car (constantly #f))))
        (lambda (state params)
          (let* ((obj-original (state-obj state))
                 (obj-pos-original (state-obj-pos state)))
            (unless atsign
              (state-obj-set! state (list->vector (vector-ref obj-original obj-pos-original)))
              (state-obj-pos-set! state 0))
            (let loop ((limit (limit-proc params)))
              (let ((obj-before (state-obj state))
                    (obj-pos-before (state-obj-pos state)))
                (when (and (or (not limit) (positive? limit))
                           (< obj-pos-before (vector-length obj-before)))
                  (when colon
                    (state-obj-set! state (list->vector (vector-ref obj-before obj-pos-before)))
                    (state-obj-pos-set! state 0))
                  (run-one-iteration proc-list state)
                  (when colon
                    (state-obj-set! state obj-before)
                    (state-obj-pos-set! state (+ obj-pos-before 1)))
                  (loop (and limit (- limit 1))))))
            (unless atsign
              (state-obj-set! state obj-original)
              (state-obj-pos-set! state (+ obj-pos-original 1)))))))))

(define *formatter-iteration*
  `((#\{ ,(params-consuming-proc formatter-iteration-start))
    (#\} ,(formatter-iteration-end #t))
    (#\^ ,(formatter-iteration-end #f))))

(define (formatter-chars char cond-skip)
  (params-consuming-proc
    (lambda (call num-params)
      (let ((start-proc (if (= num-params 1) car (constantly 1))))
        (lambda (state params)
          ((formatter-write-char
             char
             (if (and cond-skip (zero? (state-colpos state))) 0 1)
             (formatter-write-char char (- (start-proc params) 1)))
           state))))))

;(define (formatter-chars-skip-whitespace)
;  (formatter-function
;    (lambda (state start params colon atsign)
;      ; Ignore or print leading newline?
;      (when atsign
;        (*formatter-out-char state #\newline))
;      (state-fmt-pos-set! state (fx+ (state-fmt-pos state) 1))
;      ; Ignore or print subsequent whitespace?
;      (state-fmt-pos-set! state
;        (let* ((fmt (state-fmt state))
;               (fmtlen (string-length fmt)))
;          (let loop ((fmtpos (state-fmtpos state)))
;            (if (fx>= fmtpos fmtlen)
;                fmtlen
;                (let ((char (string-ref fmt fmtpos)))
;                  (if (char-whitespace? char)
;                      (begin
;                        (when colon
;                          (*formatter-out-char state char))
;                        (loop (fx+ fmtpos 1)))
;                      fmtpos)))))))))

(define *formatter-chars*
  `((#\% ,(formatter-chars #\newline #f))
    (#\& ,(formatter-chars #\newline #t))
    (#\| ,(formatter-chars #\page #f))
    (#\/ ,(formatter-chars #\tab #f))
    (#\~ ,(formatter-chars #\~ #f))
    (#\_ ,(formatter-chars #\space #f))
;    (#\newline ,(formatter-chars-skip-whitespace))
))

(define (formatter-indirection call num-params)
  (let ((compiler (compiler-state-compiler (escape-call-compiler-state call))))
    (lambda (state params)
      (let ((fmt (state-obj-ref state 1)))
        ((compile-format-string (make-compiler-state compiler fmt 0 #f '()))
         (make-default-state
           (state-out state)
           (if (escape-call-atsign call) params (state-obj-ref state 1))))))))

(define *formatter-indirection*
  `((#\? ,(params-consuming-proc formatter-indirection))
    (#\K ,(params-consuming-proc formatter-indirection))))

(define (tabulate colnum colinc relative tabchar state)
  ((formatter-write-char
     tabchar
     (cond
       ((and (not relative) (< (state-colpos state) colnum))
        (- colnum (state-colpos state)))
       ((zero? colinc) 0)
       (else
        (modulo (- colinc (+ (if relative colnum 0) (state-colpos state))) colinc))))
   state))

(define (formatter-tabulate call num-params)
  (lambda (state params)
    (let-optionals params ((colnum #f) (colinc #f) (tabchar #\space))
      (tabulate colnum colinc (escape-call-atsign call) tabchar state))))

(define *formatter-tabulate*
  `((#\T ,(params-consuming-proc formatter-tabulate))))

(define (formatter-jump call num-params)
  (let* ((colon (escape-call-colon call))
         (atsign (escape-call-atsign call))
         (base (cond
                 ((not atsign) state-obj-pos)
                 (colon (lambda (s) (- (vector-length (state-obj s)) 1)))
                 (else (constantly 0))))
         (direction (if colon - +))
         (steps-proc (if (zero? num-params)
                       (constantly (if atsign 0 1))
                       car)))
    (lambda (state params)
      (state-obj-pos-set! state
        (min (- (vector-length (state-obj state)) 1)
             (max 0 (direction (base state) (steps-proc params))))))))

(define *formatter-jump*
  `((#\* ,(params-consuming-proc formatter-jump))))

(cond-expand
  (chicken)
  (else
    (define *char-output-mappings*
      `((#\newline 'newline)
        (#\space 'space)
        (#\tab 'tab)))

    (define (char-name char)
      (and-let* ((value (assoc char *char-names*)))
        (cadr value)))))

(cond-expand
  (chicken
    (define (char-graphic? char)
      (char-set-contains? char-set:graphic char)))
  (else
    (define (char-graphic? char)
      (let ((num (char->integer char)))
        (and (<= 32 num) (< num 127))))))

(define (out-char-spell-out char)
  (let ((name (char-name char)))
   (cond
     (name
      (formatter-write-string (string-append "#\\" (symbol->string name))))
     ((char-graphic? char)
      (formatter-write-char char))
     (else
      (let* ((str (number->string (char->integer char) 16))
             (strlen (string-length str)))
        (formatter-write-string (case strlen ((2) "x") ((4) "u") (else "U")) 1
          (formatter-write-char #\0 (- (cond ((<= strlen 2) 2) ((<= strlen 4) 4) (else 8)) strlen)
            (formatter-write-string str))))))))

(define (out-char-control char)
  (let ((num (char->integer char)))
    (cond
      ((< num #x20)
       (formatter-write-char #\^ 1
         (formatter-write-char (integer->char (+ num #x40)) 1)))
      ((>= num #x7f)
       (formatter-write-string "#\\"
         (formatter-write-string (number->string num 8))))
      (else
       (formatter-write-char char)))))

(define (formatter-char call num-params)
  (assert (escape-call? call))
  (let ((printer (cond
                   ((escape-call-colon call) out-char-spell-out)
                   ((escape-call-atsign call) out-char-control)
                   (else formatter-write-char))))
    (lambda (state params)
      (assert (state? state))
      (let ((char (state-obj-ref state 1)))
        (assert (char? char))
        ((printer char) state)))))

(define (calc-padding len min-col col-inc min-pad)
  (if (< (+ len min-pad) min-col)
    (calc-padding len min-col col-inc (+ min-pad col-inc))
    min-pad))

(define (formatter-pretty-print call)
  (params-consuming-proc call
    (lambda (state params)
      (pretty-print (state-obj-ref state 1) (state-out state)))))

(define (output-string-with-padding state str pad-char left-padding min-col col-inc min-pad)
  (unless left-padding ((formatter-write-string str) state))
  ((formatter-write-char pad-char (calc-padding (string-length str) min-col col-inc min-pad)) state)
  (when left-padding ((formatter-write-string str) state)))

(define (formatter-padded show-func)
  (params-consuming-proc
    (lambda (call num-params)
      (lambda (state params)
        (let-optionals params ((min-col #f) (col-inc #f) (min-pad #f) (pad-char #\space))
          (let ((str (with-output-to-string (lambda () (show-func (state-obj-ref state 1))))))
            (output-string-with-padding
              state
              str
              (or pad-char #\space)
              (escape-call-atsign call)
              (or min-col 0)
              (or col-inc 1)
              (or min-pad 0))))))))

(define *formatter-objs*
  `((#\C ,(params-consuming-proc formatter-char))
    (#\A ,(formatter-padded display))
    (#\S ,(formatter-padded write))
    (#\Y ,formatter-pretty-print)))

(define (get-number state inc)
  (let ((num (state-obj-ref state inc)))
    (unless (number? num)
      (formatter-error "invalid number" num))
    num))

(define (get-float state inc)
  (let ((num (get-number state inc)))
    (if (or (real? num) (rational? num) (integer? num))
      num
      (exact->inexact num))))

(define (integer->list number always-sign base)
  (let ((tail (string->list (number->string number base))))
    (if (and always-sign (not (negative? number)))
        (cons #\+ tail)
        tail)))

(define (add-comma char width input)
  (if char
    (cdr
      (fold-right
        (lambda (c rest-xrenamed)
          (if (or (< 1 (car rest-xrenamed))
                  (char=? c #\+)
                  (char=? c #\-))
            (cons (- (car rest-xrenamed) 1) (cons c (cdr rest-xrenamed)))
            (cons width (cons* c char (cdr rest-xrenamed)))))
        (list (+ 1 width))
        input))
    input))

(define (formatter-integer-with-radix radix call num-params)
  (lambda (state params)
    (let-optionals (if radix params (cdr params)) ((min-col #f) (pad-char #f) (comma-char #f) (comma-width #f))
      (let ((num (get-number state 1)))
        (if (integer? num)
          (let ((result (add-comma
                          (and (escape-call-colon call) (or comma-char #\,))
                          (or comma-width 3)
                          (integer->list num (escape-call-atsign call) (or radix (car params))))))
            ((formatter-write-char
               (or pad-char #\space)
               (max 0 (- (or min-col 0) (length result)))
               (formatter-write-string (list->string result)))
             state))
          (output-string-with-padding state
            (with-output-to-string (lambda () (display num)))
            (or pad-char #\space)
            #f
            (or min-col 0)
            1
            0))))))

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

(define (formatter-roman old-style i)
  (let loop ((i i) (numbers *roman-numerals*))
    (if (positive? i)
      (let ((num (caar numbers)) (char (cadar numbers)))
        (cond
          ((>= i num)
           (formatter-write-char char (quotient i num)
             (loop (remainder i num) numbers)))
          ((and (not old-style)
                (> (* 2 i) num)
                (find (compose (lambda (x) (<= (+ x 1) (- num x) i)) car)
                      numbers))
           =>
           (lambda (smaller)
             (formatter-write-char (cadr smaller) 1
               (formatter-write-char char 1
                 (loop (- i (- num (car smaller))) (cdr numbers))))))
          (else
           (loop i (cdr numbers)))))
      (constantly #f))))

(define-record number-system zero ones tens hundred thousands prefix)

(define (make-ordinal last)
  (make-number-system
    (formatter-write-string "zeroth")
    '#("" "first" "second" "third" "fourth" "fifth" "sixth" "seventh"
       "eighth" "ninth" "tenth" "eleventh" "twelveth" "thirteenth" "fourteenth"
       "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth")
    '#("" "tenth" "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth"
       "seventieth" "eightieth" "ninetieth")
    " hundredth"
    '#("" " thousandth" " millionth" " billionth" " trillionth" " quadrillionth"
       " quintillionth" " sextillionth" " septillionth" " octillionth"
       " nonillionth" " decillionth" " undecillionth" " duodecillionth"
       " tredecillionth" " quattuordecillionth" " quindecillionth"
       " sexdecillionth" " septendecillionth" " octodecillionth"
       " novemdecillionth" " vigintillionth")
    last))

(define *cardinal*
  (make-number-system
    (formatter-write-string "zero")
    '#("" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine" "ten"
       "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen" "seventeen"
       "eighteen" "nineteen")
    '#(#f "ten" "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty"
       "ninety")
    " hundred"
    '#("" " thousand" " million" " billion" " trillion" " quadrillion"
       " quintillion" " sextillion" " septillion" " octillion" " nonillion"
       " decillion" " undecillion" " duodecillion" " tredecillion"
       " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
       " octodecillion" " novemdecillion" " vigintillion")
    #f))

(define *ordinal* (make-ordinal *cardinal*))

(define (list-digits-in-base number base)
  (let loop ((number number) (result '()) (exponent 0))
    (if (zero? number)
      result
      (let ((r (remainder number base)) (q (quotient number base)))
        (if (zero? r)
          (loop q result (+ exponent 1))
          (loop q (cons `(,r ,exponent) result) (+ exponent 1)))))))

(define (format-english-20 number system . rest-xrenamed)
  (apply formatter-write-string
         (vector-ref (number-system-ones system) number)
         rest-xrenamed))

(define (format-english-1000 number system rest-xrenamed)
  (let ((hundreds (quotient number 100)) (number (remainder number 100)))
    ((if (zero? hundreds)
       identity
       (lambda (rest-xrenamed)
         (format-english-20 hundreds (or (number-system-prefix system) system)
           (formatter-write-string
             (number-system-hundred
               (or (and (not (zero? number)) (number-system-prefix system)) system))
             rest-xrenamed))))
     (if (< number 20)
       (format-english-20 number system rest-xrenamed)
       (let ((tens (quotient number 10)) (number (remainder number 10)))
         (formatter-write-string
           (vector-ref
             (number-system-tens
               (or (and (not (zero? number)) (number-system-prefix system)) system))
             tens)
           (if (zero? number)
             rest-xrenamed
             (formatter-write-string "-" (format-english-20 number system)))))))))

(define (formatter-english-positive number system)
  (let loop ((digits (list-digits-in-base number 1000)))
    (format-english-1000
      (caar digits)
      (or (and (positive? (cadar digits)) (number-system-prefix system)) system)
      (formatter-write-string
        (vector-ref
          (number-system-thousands
            (or (and (not (null? (cdr digits))) (number-system-prefix system)) system))
          (cadar digits))
        (if (null? (cdr digits))
          (constantly #f)
          (formatter-write-string ", " (loop (cdr digits))))))))

(define (formatter-english ordinal number)
  (unless (integer? number)
    (formatter-error "invalid integer" number))
  (let ((system (if ordinal *ordinal* *cardinal*)))
    (if (zero? number)
      (number-system-zero system)
      (formatter-write-string (if (negative? number) "minus " "")
        (formatter-english-positive (abs number) system)))))

(define (formatter-radix call num-params)
  (if (positive? num-params)
    (formatter-integer-with-radix #f call num-params)
    (let ((handler (if (escape-call-atsign call)
                     (cut formatter-roman (escape-call-colon call) <>)
                     (cut formatter-english (escape-call-colon call) <>))))
      (lambda (state params)
        ((handler (state-obj-ref state 1)) state)))))

;(define (formatter-float-list width overflow-ch pad-char float)
;  (let ((len (length float)))
;    (formatter-write-char (or pad-char #\space) (max 0 (- (or width 0) len))
;      (if (and width overflow-ch (> len width))
;        (formatter-write-char overflow-ch width)
;        (formatter-write-list float)))))

;(define (formatter-fixed-float call)
;  (params-consuming-proc
;    (lambda (state params)
;      (let-optionals params ((width #f) (digits #f) (scale #f) (overflow-ch #f) (pad-char #f))
;        (let ((num (get-float state 1)))
;          (formatter-float-list width overflow-ch pad-char
;            (fixed-float-list (* num (expt 10 (or scale 0))) atsign width digits)))))))

(define *formatter-numbers*
  `((#\X ,(params-consuming-proc (cut formatter-integer-with-radix 16 <...>)))
    (#\D ,(params-consuming-proc (cut formatter-integer-with-radix 10 <...>)))
    (#\O ,(params-consuming-proc (cut formatter-integer-with-radix 8 <...>)))
    (#\B ,(params-consuming-proc (cut formatter-integer-with-radix 2 <...>)))
    (#\R ,(params-consuming-proc formatter-radix))

    ;(#\G ,(formatter-function formatter-general-float))
    ;(#\F ,(formatter-function formatter-fixed-float))
    ;(#\E ,(formatter-function formatter-exponential))
    ;(#\$ ,(formatter-function formatter-dollar))
    ;(#\I ,(formatter-function formatter-complex))
    ))

(define (formatter-plural call num-params)
  (let ((increase (if (escape-call-colon call) 0 1))
        (singular (formatter-write-string (if (escape-call-atsign call) "y" "")))
        (plural (formatter-write-string (if (escape-call-atsign call) "ies" "s"))))
    (lambda (state params)
      ((if (eqv? 1 (state-obj-ref state increase)) singular plural) state))))

(define *formatter-plural*
  `((#\P ,(params-consuming-proc formatter-plural))))

(define *format-spec*
  `(,*formatter-flush*
    ,*formatter-plural*
    ,*formatter-tabulate*
    ,*formatter-params*
    ,*formatter-iteration*
    ,*formatter-caseconv*
    ,*formatter-chars*
    ,*formatter-numbers*
    ,*formatter-cond*
    ,*formatter-indirection*
    ,*formatter-jump*
    ,*formatter-objs*
    ,*formatter-version*))

(define format
  (let ((compiler (make-format-compiler #f #\~ *format-spec*)))
    (lambda (port fmt . args) (apply (compiler fmt) port args))))

)