fmt
                                 ---

                    Combinator Formatting Library

                   http://synthcode.com/scheme/fmt/


This directory contains a portable combinator-based formatting library
for Scheme.  It has been tested on Chicken, Gauche, MzScheme 3.x and
Scheme48.

Documentation is in the file fmt.html.

0.8.4

;;;; fmt-c.scm -- fmt module for emitting/pretty-printing C code
;;
;; Copyright (c) 2007 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

#!r6rs
(library
 (fmt c)
 (export
  fmt-in-macro? fmt-expression? fmt-return? fmt-default-type
  fmt-newline-before-brace? fmt-braceless-bodies?
  fmt-indent-space fmt-switch-indent-space fmt-op fmt-gen
  c-in-expr c-in-stmt c-in-test
  c-paren c-maybe-paren c-type c-literal? c-literal char->c-char
  c-struct c-union c-class c-enum c-typedef c-cast
  c-expr c-expr/sexp c-apply c-op c-indent c-current-indent-string
  c-wrap-stmt c-open-brace c-close-brace
  c-block c-braced-block c-begin
  c-fun c-var c-prototype c-param c-param-list
  c-while c-for c-if c-switch
  c-case c-case/fallthrough c-default
  c-break c-continue c-return c-goto c-label
  c-static c-const c-extern c-volatile c-auto c-restrict c-inline
  c++ c-- c+ c- c* c/ c% c& c^ c~ c! c&& c<< c>> c== c!= ;  |c\||  |c\|\||
  c< c> c<= c>= c= c+= c-= c*= c/= c%= c&= c^= c<<= c>>= ;++c --c ;  |c\|=|
  c++/post c--/post c. c->
  c-bit-or c-or c-bit-or=
  cpp-if cpp-ifdef cpp-ifndef cpp-elif cpp-endif cpp-else cpp-undef
  cpp-include cpp-define cpp-wrap-header cpp-pragma cpp-line
  cpp-error cpp-warning cpp-stringify cpp-sym-cat
  c-comment c-block-comment c-attribute
  )

 (import (chezscheme) 
	 (fmt fmt)
	 (only (srfi s1 lists) every)
	 (only (srfi s13 strings) substring/shared string-index string-index-right))

 (include "fmt-c.scm")

 )

;;;; fmt-c.scm -- fmt module for emitting/pretty-printing C code
;;
;; Copyright (c) 2007 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; additional state information

(define (fmt-in-macro? st) (fmt-ref st 'in-macro?))
(define (fmt-expression? st) (fmt-ref st 'expression?))
(define (fmt-return? st) (fmt-ref st 'return?))
(define (fmt-default-type st) (fmt-ref st 'default-type 'int))
(define (fmt-newline-before-brace? st) (fmt-ref st 'newline-before-brace?))
(define (fmt-braceless-bodies? st) (fmt-ref st 'braceless-bodies?))
(define (fmt-non-spaced-ops? st) (fmt-ref st 'non-spaced-ops?))
(define (fmt-no-wrap? st) (fmt-ref st 'no-wrap?))
(define (fmt-indent-space st) (fmt-ref st 'indent-space))
(define (fmt-switch-indent-space st) (fmt-ref st 'switch-indent-space))
(define (fmt-op st) (fmt-ref st 'op 'stmt))
(define (fmt-gen st) (fmt-ref st 'gen))

(define (c-in-expr proc) (fmt-let 'expression? #t proc))
(define (c-in-stmt proc) (fmt-let 'expression? #f proc))
(define (c-in-test proc) (fmt-let 'in-cond? #t (c-in-expr proc)))
(define (c-with-op op proc) (fmt-let 'op op proc))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; be smart about operator precedence

(define (c-op-precedence x)
  (if (string? x)
      (cond
        ((or (string=? x ".") (string=? x "->")) 10)
        ((or (string=? x "++") (string=? x "--")) 20)
        ((string=? x "|") 65)
        ((string=? x "||") 75)
        ((string=? x "|=") 85)
        ((or (string=? x "+=") (string=? x "-=")) 85)
        (else 95))
      (case x
        ;;((|::|) 5) ; C++
        ((paren bracket) 5)
        ((dot arrow post-decrement post-increment) 10)
        ((**) 15)                       ; Perl
        ((unary+ unary- ! ~ cast unary-* unary-& sizeof) 20) ; ++ --
        ((=~ !~) 25)                    ; Perl
        ((* / %) 30)
        ((+ -) 35)
        ((<< >>) 40)
        ((< > <= >=) 45)
        ((lt gt le ge) 45)              ; Perl
        ((== !=) 50)
        ((eq ne cmp) 50)                ; Perl
        ((&) 55)
        ((^) 60)
        ;;((|\||) 65)
        ((&&) 70)
        ;;((|\|\||) 75)
        ;;((.. ...) 77)                   ; Perl
        ((?) 80)
        ((= *= /= %= &= ^= <<= >>=) 85) ; |\|=| ;  += -=
        ((comma) 90)
        ((=>) 90)                       ; Perl
        ((not) 92)                      ; Perl
        ((and) 93)                      ; Perl
        ((or xor) 94)                   ; Perl
        (else 95))))

(define (c-op< x y) (< (c-op-precedence x) (c-op-precedence y)))

(define (c-paren x) (cat "(" x ")"))

(define (c-maybe-paren op x)
  (lambda (st)
    ((fmt-let 'op op
              (if (or (fmt-in-macro? st) (c-op< (fmt-op st) op))
                  (c-paren x)
                  x))
     st)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; default literals writer

(define (c-control-operator? x)
  (memq x '(if while switch repeat do for fun begin)))

(define (c-literal? x)
  (or (number? x) (string? x) (char? x) (boolean? x)))

(define (char->c-char c)
  (string-append "'" (c-escape-char c #\') "'"))

(define (c-escape-char c quote-char)
  (let ((n (char->integer c)))
    (if (<= 32 n 126)
        (if (or (eqv? c quote-char) (eqv? c #\\))
            (string #\\ c)
            (string c))
        (case n
          ((7) "\\a") ((8) "\\b") ((9) "\\t") ((10) "\\n")
          ((11) "\\v") ((12) "\\f") ((13) "\\r")
          (else (string-append "\\x" (number->string (char->integer c) 16)))))))

(define (c-format-number x)
  (if (and (integer? x) (exact? x))
      (lambda (st)
        ((case (fmt-radix st)
           ((16) (cat "0x" (string-upcase (number->string x 16))))
           ((8) (cat "0" (number->string x 8)))
           (else (dsp (number->string x))))
         st))
      (dsp (number->string x))))

(define (c-format-string x)
  (lambda (st) ((cat #\" (apply-cat (c-string-escaped x)) #\") st)))

(define (c-string-escaped x)
  (let loop ((parts '()) (idx (string-length x)))
    (cond ((string-index-right x c-needs-string-escape? 0 idx)
           => (lambda (special-idx)
                (loop (cons (c-escape-char (string-ref x special-idx) #\")
                            (cons (substring/shared x (+ special-idx 1) idx)
                                  parts))
                      special-idx)))
          (else
           (cons (substring/shared x 0 idx) parts)))))

(define (c-needs-string-escape? c)
  (if (<= 32 (char->integer c) 127) (memv c '(#\" #\\)) #t))

(define (c-simple-literal x)
  (c-wrap-stmt
   (cond ((char? x) (dsp (char->c-char x)))
         ((boolean? x) (dsp (if x "1" "0")))
         ((number? x) (c-format-number x))
         ((string? x) (c-format-string x))
         ((null? x) (dsp "NULL"))
         ((eof-object? x) (dsp "EOF"))
         (else (dsp (write-to-string x))))))

(define (c-literal x)
  (lambda (st)
    ((if (and (fmt-in-macro? st) (c-op< 'paren (fmt-op st))
              (not (c-literal? x)))
         (c-paren (c-simple-literal x))
         (c-simple-literal x))
     st)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; default expression generator

(define (c-expr/sexp x)
  (if (procedure? x)
      x
      (lambda (st)
        (cond
         ((pair? x)
          (case (car x)
            ((if) ((apply c-if (cdr x)) st))
            ((for) ((apply c-for (cdr x)) st))
            ((while) ((apply c-while (cdr x)) st))
            ((switch) ((apply c-switch (cdr x)) st))
            ((case) ((apply c-case (cdr x)) st))
            ((case/fallthrough) ((apply c-case/fallthrough (cdr x)) st))
            ((default) ((apply c-default (cdr x)) st))
            ((break) (c-break st))
            ((continue) (c-continue st))
            ((return) ((apply c-return (cdr x)) st))
            ((goto) ((apply c-goto (cdr x)) st))
            ((typedef) ((apply c-typedef (cdr x)) st))
            ((struct union class) ((apply c-struct/aux x) st))
            ((enum) ((apply c-enum (cdr x)) st))
            ((inline auto restrict register volatile extern static)
             ((cat (car x) " " (apply-cat (cdr x))) st))
            ;; non C-keywords must have some character invalid in a C
            ;; identifier to avoid conflicts - by default we prefix %
            ((vector-ref)
             ((c-wrap-stmt
               (cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]"))
              st))
            ((vector-set!)
             ((c= (c-in-expr
                   (cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]"))
                  (c-expr (cadddr x)))
              st))
            ((extern/C) ((apply c-extern/C (cdr x)) st))
            ((%apply) ((apply c-apply (cdr x)) st))
            ((%define) ((apply cpp-define (cdr x)) st))
            ((%include) ((apply cpp-include (cdr x)) st))
            ((%fun) ((apply c-fun (cdr x)) st))
            ((%cond)
             (let lp ((ls (cdr x)) (res '()))
               (if (null? ls)
                   ((apply c-if (reverse res)) st)
                   (lp (cdr ls)
                       (cons (if (pair? (cddar ls))
                                 (apply c-begin (cdar ls))
                                 (cadar ls))
                             (cons (caar ls) res))))))
            ((%prototype) ((apply c-prototype (cdr x)) st))
            ((%var) ((apply c-var (cdr x)) st))
            ((%begin) ((apply c-begin (cdr x)) st))
            ((%attribute) ((apply c-attribute (cdr x)) st))
            ((%line) ((apply cpp-line (cdr x)) st))
            ((%pragma %error %warning)
             ((apply cpp-generic (substring/shared (symbol->string (car x)) 1)
                     (cdr x)) st))
            ((%if %ifdef %ifndef %elif)
             ((apply cpp-if/aux (substring/shared (symbol->string (car x)) 1)
                     (cdr x)) st))
            ((%endif) ((apply cpp-endif (cdr x)) st))
            ((%block) ((apply c-braced-block (cdr x)) st))
            ((%comment) ((apply c-comment (cdr x)) st))
            ((:) ((apply c-label (cdr x)) st))
            ((%cast) ((apply c-cast (cdr x)) st))
            ((+ - & * / % ! ~ ^ && < > <= >= == != << >>
                = *= /= %= &= ^= >>= <<=) ; |\|| |\|\|| |\|=|
             ((apply c-op x) st))
            ((bitwise-and bit-and) ((apply c-op '& (cdr x)) st))
            ((bitwise-ior bit-or) ((apply c-op "|" (cdr x)) st))
            ((bitwise-xor bit-xor) ((apply c-op '^ (cdr x)) st))
            ((bitwise-not bit-not) ((apply c-op '~ (cdr x)) st))
            ((arithmetic-shift) ((apply c-op '<< (cdr x)) st))
            ((bitwise-ior= bit-or=) ((apply c-op "|=" (cdr x)) st))
            ((%or) ((apply c-op "||" (cdr x)) st))
            ((%. %field) ((apply c-op "." (cdr x)) st))
            ((%->) ((apply c-op "->" (cdr x)) st))
            (else
             (cond
              ((eq? (car x) (string->symbol "."))
               ((apply c-op "." (cdr x)) st))
              ((eq? (car x) (string->symbol "->"))
               ((apply c-op "->" (cdr x)) st))
              ((eq? (car x) (string->symbol "++"))
               ((apply c-op "++" (cdr x)) st))
              ((eq? (car x) (string->symbol "--"))
               ((apply c-op "--" (cdr x)) st))
              ((eq? (car x) (string->symbol "+="))
               ((apply c-op "+=" (cdr x)) st))
              ((eq? (car x) (string->symbol "-="))
               ((apply c-op "-=" (cdr x)) st))
              (else ((c-apply x) st))))))
         ((vector? x)
          ((c-wrap-stmt
            (fmt-try-fit
             (fmt-let 'no-wrap? #t
                      (cat "{" (fmt-join c-expr (vector->list x) ", ") "}"))
             (lambda (st)
               (let* ((col (fmt-col st))
                      (sep (string-append "," (make-nl-space col))))
                 ((cat "{" (fmt-join c-expr (vector->list x) sep)
                       "}" nl)
                  st)))))
           st))
         (else
          ((c-literal x) st))))))

(define (c-apply ls)
  (c-wrap-stmt
   (c-with-op
    'paren
    (cat (c-expr (car ls))
         (let ((flat (fmt-let 'no-wrap? #t (fmt-join c-expr (cdr ls) ", "))))
           (fmt-if
            fmt-no-wrap?
            (c-paren flat)
            (c-paren
             (fmt-try-fit
              flat
              (lambda (st)
                (let* ((col (fmt-col st))
                       (sep (string-append "," (make-nl-space col))))
                  ((fmt-join c-expr (cdr ls) sep) st)))))))))))

(define (c-expr x)
  (lambda (st) (((or (fmt-gen st) c-expr/sexp) x) st)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; comments, with Emacs-friendly escaping of nested comments

(define (make-comment-writer st)
  (let ((output (fmt-ref st 'writer)))
    (lambda (str st)
      (let ((lim (- (string-length str) 1)))
        (let lp ((i 0) (st st))
          (let ((j (string-index str #\/ i)))
            (if j
                (let ((st (if (and (> j 0)
                                   (eqv? #\* (string-ref str (- j 1))))
                              (output
                               "\\/"
                               (output (substring/shared str i j) st))
                              (output (substring/shared str i (+ j 1)) st))))
                  (lp (+ j 1)
                      (if (and (< j lim) (eqv? #\* (string-ref str (+ j 1))))
                          (output "\\" st)
                          st)))
                (output (substring/shared str i) st))))))))

(define (c-comment . args)
  (lambda (st)
    ((cat "/*" (fmt-let 'writer (make-comment-writer st)
                        (apply-cat args))
          "*/")
     st)))

(define (make-block-comment-writer st)
  (let ((output (make-comment-writer st))
        (indent (string-append (make-nl-space (+ (fmt-col st) 1)) "* ")))
    (lambda (str st)
      (let ((lim (string-length str)))
        (let lp ((i 0) (st st))
          (let ((j (string-index str #\newline i)))
            (if j
                (lp (+ j 1)
                    (output indent (output (substring/shared str i j) st)))
                (output (substring/shared str i) st))))))))

(define (c-block-comment . args)
  (lambda (st)
    (let ((col (fmt-col st))
          (row (fmt-row st))
          (indent (c-current-indent-string st)))
      ((cat "/* "
            (fmt-let 'writer (make-block-comment-writer st) (apply-cat args))
            (lambda (st)
              (cond
                ((= row (fmt-row st)) ((dsp " */") st))
                ;;((= (+ 3 col) (fmt-col st)) ((dsp "*/") st))
                (else ((cat fl indent " */") st)))))
       st))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; preprocessor

(define (make-cpp-writer st)
  (let ((output (fmt-ref st 'writer)))
    (lambda (str st)
      (let lp ((i 0) (st st))
        (let ((j (string-index str #\newline i)))
          (if j
              (lp (+ j 1)
                  (output
                   nl-str
                   (output " \\" (output (substring/shared str i j) st))))
              (output (substring/shared str i) st)))))))

(define (cpp-include file)
  (if (string? file)
      (cat fl "#include " (wrt file) fl)
      (cat fl "#include <" file ">" fl)))

(define (list-dot x)
  (cond ((pair? x) (list-dot (cdr x)))
        ((null? x) #f)
        (else x)))

(define (replace-tree from to x)
  (let replace ((x x))
    (cond ((eq? x from) to)
          ((pair? x) (cons (replace (car x)) (replace (cdr x))))
          (else x))))

(define (cpp-define x . body)
  (define (name-of x) (c-expr (if (pair? x) (cadr x) x)))
  (lambda (st)
    (let* ((body (cond
                   ((and (pair? x) (list-dot x))
                    => (lambda (dot)
                         (if (eq? dot '...)
                             body
                             (replace-tree dot '__VA_ARGS__ body))))
                   (else body)))
           (tail
            (if (pair? body)
                (cat " "
                     (fmt-let 'writer (make-cpp-writer st)
                              (fmt-let 'in-macro? (pair? x)
                                       ((if (or (not (pair? x))
                                                (and (null? (cdr body))
                                                     (c-literal? (car body))))
                                            (lambda (x) x)
                                            c-paren)
                                        (c-in-expr (apply c-begin body))))))
                (lambda (x) x))))
      ((c-in-expr
        (if (pair? x)
            (cat fl "#define " (name-of (car x))
                 (c-paren
                  (fmt-join/dot name-of
                                (lambda (dot) (dsp "..."))
                                (cdr x)
                                ", "))
                 tail fl)
            (cat fl "#define " (c-expr x) tail fl)))
       st))))

(define (cpp-expr x)
  (if (or (symbol? x) (string? x)) (dsp x) (c-expr x)))

(define (cpp-if/aux name check . o)
  (let* ((pass (and (pair? o) (car o)))
         (comment (if (member name '("ifdef" "ifndef"))
                      (cat "  "
                           (c-comment
                            " " (if (equal? name "ifndef") "! " "")
                            check " "))
                      ""))
         (endif (if pass (cat fl "#endif" comment) ""))
         (tail (cond
                ((and (pair? o) (pair? (cdr o)))
                 (if (pair? (cddr o))
                     (apply cpp-elif (cdr o))
                     (cat (cpp-else) (cadr o) endif)))
                (else endif))))
    (lambda (st)
      (let ((indent (c-current-indent-string st)))
        ((cat fl "#" name " " (cpp-expr check) fl
              (if pass (cat indent pass) "") fl
              tail fl)
         st)))))

(define (cpp-if check . o)
  (apply cpp-if/aux "if" check o))
(define (cpp-ifdef check . o)
  (apply cpp-if/aux "ifdef" check o))
(define (cpp-ifndef check . o)
  (apply cpp-if/aux "ifndef" check o))
(define (cpp-elif check . o)
  (apply cpp-if/aux "elif" check o))
(define (cpp-else . o)
  (cat fl "#else " (if (pair? o) (c-comment (car o)) "") fl))
(define (cpp-endif . o)
  (cat fl "#endif " (if (pair? o) (c-comment (car o)) "") fl))

(define (cpp-wrap-header name . body)
  (let ((name name)) ; consider auto-mangling
    (cpp-ifndef name (c-begin (cpp-define name) nl (apply c-begin body) nl))))

(define (cpp-line num . o)
  (cat fl "#line " num (if (pair? o) (cat " " (car o)) "") fl))

(define (cpp-generic name . ls)
  (cat fl "#" name (apply-cat ls) fl))

(define (cpp-undef . args) (apply cpp-generic "undef" args))
(define (cpp-pragma . args) (apply cpp-generic "pragma" args))
(define (cpp-error . args) (apply cpp-generic "error" args))
(define (cpp-warning . args) (apply cpp-generic "warning" args))

(define (cpp-stringify x)
  (cat "#" x))

(define (cpp-sym-cat . args)
  (fmt-join dsp args " ## "))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; general indentation and brace rules

(define (c-current-indent-string st . o)
  (make-space (max 0 (+ (fmt-col st) (if (pair? o) (car o) 0)))))

(define (c-indent st . o)
  (dsp (make-space (max 0 (+ (fmt-col st) (or (fmt-indent-space st) 4)
                             (if (pair? o) (car o) 0))))))

(define (c-indent/switch st)
  (dsp (make-space (+ (fmt-col st) (or (fmt-switch-indent-space st) 4)))))

(define (c-open-brace st)
  (if (fmt-newline-before-brace? st)
      (cat nl (c-current-indent-string st) "{" nl)
      (cat " {" nl)))

(define (c-close-brace st)
  (dsp "}"))

(define (c-wrap-stmt x)
  (fmt-if fmt-expression?
          (c-expr x)
          (cat (fmt-if fmt-return? "return " "")
               (c-in-expr (c-expr x)) ";" nl)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; code blocks

(define (c-block . args)
  (apply c-block/aux 0 args))

(define (c-block/aux offset header body0 . body)
   (let ((inner (apply c-begin body0 body)))
     (if (or (pair? body)
             (not (or (c-literal? body0)
                      (and (pair? body0)
                           (not (c-control-operator? (car body0)))))))
         (c-braced-block/aux offset header inner)
         (lambda (st)
           (if (fmt-braceless-bodies? st)
               ((cat header fl (c-indent st offset) inner fl) st)
               ((c-braced-block/aux offset header inner) st))))))

(define (c-braced-block . args)
  (apply c-braced-block/aux 0 args))

(define (c-braced-block/aux offset header . body)
   (lambda (st)
     ((cat header (c-open-brace st) (c-indent st offset)
           (apply c-begin body) fl
           (c-current-indent-string st offset) (c-close-brace st))
      st)))

(define (c-begin . args)
  (apply c-begin/aux #f args))

(define (c-begin/aux ret? body0 . body)
   (if (null? body)
       (c-expr body0)
       (lambda (st)
         (if (fmt-expression? st)
             ((fmt-try-fit
               (fmt-let 'no-wrap? #t (fmt-join c-expr (cons body0 body) ", "))
               (lambda (st)
                 (let ((indent (c-current-indent-string st)))
                   ((fmt-join c-expr (cons body0 body) (cat "," nl indent)) st))))
              st)
             (let ((orig-ret? (fmt-return? st)))
               ((fmt-join/last c-expr
                               (lambda (x) (fmt-let 'return? orig-ret? (c-expr x)))
                               (cons body0 body)
                               (cat fl (c-current-indent-string st)))
                (fmt-set! st 'return? (and ret? orig-ret?))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; data structures

(define (c-struct/aux type x . o)
  (let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
         (body (if name (car o) x))
         (o (if (null? o) o (cdr o))))
    (c-wrap-stmt
     (cat
      (c-braced-block
       (cat type (if (and name (not (equal? name ""))) (cat " " name) ""))
       (cat
        (c-in-stmt
         (if (list? body)
             (apply c-begin (map c-wrap-stmt (map c-param body)))
             (c-wrap-stmt (c-expr body))))))
      (if (pair? o) (cat " " (apply c-begin o)) (dsp ""))))))

(define (c-struct . args) (apply c-struct/aux "struct" args))
(define (c-union . args) (apply c-struct/aux "union" args))
(define (c-class . args) (apply c-struct/aux "class" args))

(define (c-enum x . o)
  (define (c-enum-one x)
    (if (pair? x) (cat (car x) " = " (c-expr (cadr x))) (dsp x)))
  (let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
         (vals (if name (car o) x)))
    (c-wrap-stmt
     (cat
      (c-braced-block
       (if name (cat "enum " name) (dsp "enum"))
       (c-in-expr (apply c-begin (map c-enum-one vals))))))))

(define (c-attribute . args)
  (cat "__attribute__ ((" (fmt-join c-expr args ", ") "))"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; basic control structures

(define (c-while check . body)
  (cat (c-block (cat "while (" (c-in-test (c-expr check)) ")")
                (c-in-stmt (apply c-begin body)))
       fl))

(define (c-for init check update . body)
  (cat
   (c-block
    (c-in-expr
     (cat "for (" (c-expr init) "; " (c-in-test (c-expr check)) "; "
          (c-expr update ) ")"))
    (c-in-stmt (apply c-begin body)))
   fl))

(define (c-param x)
  (cond
    ((procedure? x) x)
    ((pair? x) (c-type (car x) (cadr x)))
    (else (cat (lambda (st) ((c-type (fmt-default-type st)) st)) " " x))))

(define (c-param-list ls)
  (c-in-expr (fmt-join/dot c-param (lambda (dot) (dsp "...")) ls ", ")))

(define (c-fun type name params . body)
  (cat (c-block (c-in-expr (c-prototype type name params))
                (fmt-let 'return? (not (eq? 'void type))
                         (c-in-stmt (apply c-begin body))))
       fl))

(define (c-prototype type name params . o)
  (c-wrap-stmt
   (cat (c-type type) " " (c-expr name) " (" (c-param-list params) ")"
        (fmt-join/prefix c-expr o " "))))

(define (c-static x) (cat "static " (c-expr x)))
(define (c-const x) (cat "const " (c-expr x)))
(define (c-restrict x) (cat "restrict " (c-expr x)))
(define (c-volatile x) (cat "volatile " (c-expr x)))
(define (c-auto x) (cat "auto " (c-expr x)))
(define (c-inline x) (cat "inline " (c-expr x)))
(define (c-extern x) (cat "extern " (c-expr x)))
(define (c-extern/C . body)
  (cat "extern \"C\" {" nl (apply c-begin body) nl "}" nl))

(define (c-type type . o)
  (let ((name (and (pair? o) (car o))))
    (cond
     ((pair? type)
      (case (car type)
        ((%fun)
         (cat (c-type (cadr type) #f)
              " (*" (or name "") ")("
              (fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
        ((%array)
         (let ((name (cat name "[" (if (pair? (cddr type))
                                       (c-expr (caddr type))
                                       "")
                          "]")))
           (c-type (cadr type) name)))
        ((%pointer *)
         (let ((name (cat "*" (if name (c-expr name) ""))))
           (c-type (cadr type)
                   (if (and (pair? (cadr type)) (eq? '%array (caadr type)))
                       (c-paren name)
                       name))))
        ((enum) (apply c-enum name (cdr type)))
        ((struct union class)
         (cat (apply c-struct/aux (car type) (cdr type)) " " name))
        (else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " "))))
     ((not type)
      (lambda (st) ((c-type (or (fmt-default-type st) 'int) name) st)))
     (else
      (cat (if (eq? '%pointer type) '* type) (if name (cat " " name) ""))))))

(define (c-var type name . init)
  (c-wrap-stmt
   (if (pair? init)
       (cat (c-type type name) " = " (c-expr (car init)))
       (c-type type (if (pair? name)
                        (fmt-join c-expr name ", ")
                        (c-expr name))))))

(define (c-cast type expr)
  (cat "(" (c-type type) ")" (c-expr expr)))

(define (c-typedef type alias . o)
  (c-wrap-stmt
   (cat "typedef " (c-type type alias) (fmt-join/prefix c-expr o " "))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Generalized IF: allows multiple tail forms for if/else if/.../else
;; blocks.  A final ELSE can be signified with a test of #t or 'else,
;; or by simply using an odd number of expressions (by which the
;; normal 2 or 3 clause IF forms are special cases).

(define (c-if/stmt c p . rest)
  (lambda (st)
    (let ((indent (c-current-indent-string st)))
      ((let lp ((c c) (p p) (ls rest))
         (if (or (eq? c 'else) (eq? c #t))
             (if (not (null? ls))
                 (error "forms after else clause in IF" c p ls)
                 (cat (c-block/aux -1 " else" p) fl))
             (let ((tail (if (pair? ls)
                             (if (pair? (cdr ls))
                                 (lp (car ls) (cadr ls) (cddr ls))
                                 (lp 'else (car ls) '()))
                             fl)))
               (cat (c-block/aux
                     (if (eq? ls rest) 0 -1)
                     (cat (if (eq? ls rest) (lambda (x) x) " else ")
                          "if (" (c-in-test (c-expr c)) ")") p)
                    tail))))
       st))))

(define (c-if/expr c p . rest)
  (let lp ((c c) (p p) (ls rest))
    (cond
      ((or (eq? c 'else) (eq? c #t))
       (if (not (null? ls))
           (error "forms after else clause in IF" c p ls)
           (c-expr p)))
      ((pair? ls)
       (cat (c-in-test (c-expr c)) " ? " (c-expr p) " : "
            (if (pair? (cdr ls))
                (lp (car ls) (cadr ls) (cddr ls))
                (lp 'else (car ls) '()))))
      (else
       (c-or (c-in-test (c-expr c)) (c-expr p))))))

(define (c-if . args)
  (fmt-if fmt-expression?
          (apply c-if/expr args)
          (apply c-if/stmt args)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; switch statements, automatic break handling

(define (c-label name)
  (lambda (st)
    (let ((indent (make-space (max 0 (- (fmt-col st) 2)))))
      ((cat fl indent name ":" fl) st))))

(define c-break
  (c-wrap-stmt (dsp "break")))
(define c-continue
  (c-wrap-stmt (dsp "continue")))
(define (c-return . result)
  (if (pair? result)
      (c-wrap-stmt (cat "return " (c-expr (car result))))
      (c-wrap-stmt (dsp "return"))))
(define (c-goto label)
  (c-wrap-stmt (cat "goto " (c-expr label))))

(define (c-switch val . clauses)
  (lambda (st)
    ((cat "switch (" (c-in-expr val) ")" (c-open-brace st)
          (c-indent/switch st)
          (c-in-stmt (apply c-begin/aux #t (map c-switch-clause clauses))) fl
          (c-current-indent-string st) (c-close-brace st) fl)
     st)))

(define (c-switch-clause/breaks x)
  (lambda (st)
    (let* ((break?
            (and (car x)
                 (not (member (cadr x) '(case/fallthrough
                                         default/fallthrough
                                         else/fallthrough)))))
           (explicit-case? (member (cadr x) '(case case/fallthrough)))
           (indent (c-current-indent-string st))
           (indent-body (c-indent st))
           (sep (string-append ":" nl-str indent)))
      ((cat (c-in-expr
             (fmt-join/suffix
              dsp
              (cond
               ((pair? (cadr x))
                (map (lambda (y) (cat (dsp "case ") (c-expr y)))
                     (cadr x)))
               (explicit-case?
                (map (lambda (y) (cat (dsp "case ") (c-expr y)))
                     (if (list? (caddr x))
                         (caddr x)
                         (list (caddr x)))))
               ((member (cadr x)
                        '(default else default/fallthrough else/fallthrough))
                (list (dsp "default")))
               (else
                (error
                 "unknown switch clause, expected a list or default but got"
                 (cadr x))))
              sep))
            (make-space (or (fmt-indent-space st) 4))
            (fmt-join c-expr
                      (if explicit-case? (cdddr x) (cddr x))
                      indent-body)
            (if (and break? (not (fmt-return? st)))
                (cat fl indent-body c-break)
                ""))
       st))))

(define (c-switch-clause x)
  (if (procedure? x) x (c-switch-clause/breaks (cons #t x))))
(define (c-switch-clause/no-break x)
  (if (procedure? x) x (c-switch-clause/breaks (cons #f x))))

(define (c-case x . body)
  (c-switch-clause (cons (if (pair? x) x (list x)) body)))
(define (c-case/fallthrough x . body)
  (c-switch-clause/no-break (cons (if (pair? x) x (list x)) body)))
(define (c-default . body)
  (c-switch-clause/breaks (cons #t (cons 'else body))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; operators

(define (c-op op first . rest)
  (if (null? rest)
      (c-unary-op op first)
      (apply c-binary-op op first rest)))

(define (c-binary-op op . ls)
  (define (lit-op? x) (or (c-literal? x) (symbol? x)))
  (let ((str (display-to-string op)))
    (c-wrap-stmt
     (c-maybe-paren
      op
      (if (or (equal? str ".") (equal? str "->"))
          (fmt-join c-expr ls str)
          (let ((flat
                 (fmt-let 'no-wrap? #t
                          (lambda (st)
                            ((fmt-join c-expr
                                       ls
                                       (if (and (fmt-non-spaced-ops? st)
                                                (every lit-op? ls))
                                           str
                                           (string-append " " str " ")))
                             st)))))
            (fmt-if
             fmt-no-wrap?
             flat
             (fmt-try-fit
              flat
              (lambda (st)
                   ((fmt-join c-expr
                              ls
                              (cat nl (make-space (+ 2 (fmt-col st))) str " "))
                    st))))))))))

(define (c-unary-op op x)
  (c-wrap-stmt
   (cat (display-to-string op) (c-maybe-paren op (c-expr x)))))

;; some convenience definitions

(define (c++ . args) (apply c-op "++" args))
(define (c-- . args) (apply c-op "--" args))
(define (c+ . args) (apply c-op '+ args))
(define (c- . args) (apply c-op '- args))
(define (c* . args) (apply c-op '* args))
(define (c/ . args) (apply c-op '/ args))
(define (c% . args) (apply c-op '% args))
(define (c& . args) (apply c-op '& args))
;; (define (|c\|| . args) (apply c-op '|\|| args))
(define (c^ . args) (apply c-op '^ args))
(define (c~ . args) (apply c-op '~ args))
(define (c! . args) (apply c-op '! args))
(define (c&& . args) (apply c-op '&& args))
;; (define (|c\|\|| . args) (apply c-op '|\|\|| args))
(define (c<< . args) (apply c-op '<< args))
(define (c>> . args) (apply c-op '>> args))
(define (c== . args) (apply c-op '== args))
(define (c!= . args) (apply c-op '!= args))
(define (c< . args) (apply c-op '< args))
(define (c> . args) (apply c-op '> args))
(define (c<= . args) (apply c-op '<= args))
(define (c>= . args) (apply c-op '>= args))
(define (c= . args) (apply c-op '= args))
(define (c+= . args) (apply c-op "+=" args))
(define (c-= . args) (apply c-op "-=" args))
(define (c*= . args) (apply c-op '*= args))
(define (c/= . args) (apply c-op '/= args))
(define (c%= . args) (apply c-op '%= args))
(define (c&= . args) (apply c-op '&= args))
;; (define (|c\|=| . args) (apply c-op '|\|=| args))
(define (c^= . args) (apply c-op '^= args))
(define (c<<= . args) (apply c-op '<<= args))
(define (c>>= . args) (apply c-op '>>= args))

(define (c. . args) (apply c-op "." args))
(define (c-> . args) (apply c-op "->" args))

(define (c-bit-or . args) (apply c-op "|" args))
(define (c-or . args) (apply c-op "||" args))
(define (c-bit-or= . args) (apply c-op "|=" args))

(define (c++/post x)
  (cat (c-maybe-paren 'post-increment (c-expr x)) "++"))
(define (c--/post x)
  (cat (c-maybe-paren 'post-decrement (c-expr x)) "--"))

;;;; fmt-color.scm -- colored output
;;
;; Copyright (c) 2006-2007 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

(define (fmt-color st) (fmt-ref st 'color))
(define (fmt-in-html? st) (fmt-ref st 'in-html?))
(define (fmt-use-html-font? st) (fmt-ref st 'use-html-font?))

(define (color->ansi x)
  (if (number? x)
      (let ((r (arithmetic-shift x -16))
            (g (bitwise-and (arithmetic-shift x -8) #xFF))
            (b (bitwise-and x #xFF)))
        ;; just picks the highest color value - need to detect blends
        (color->ansi
         (cond
           ((> r g) (if (> r b) 'red 'blue))
           ((> g b) 'green)
           (else 'blue))))
      (case x
        ((bold) "1")
        ((dark) "2")
        ((underline) "4")
        ((black) "30")
        ((red) "31")
        ((green) "32")
        ((yellow) "33")
        ((blue) "34")
        ((magenta) "35")
        ((cyan) "36")
        ((white) "37")
        (else "0"))))

(define (ansi-escape color)
  (cat (integer->char 27) "[" (color->ansi color) "m"))

(define (fmt-in-html . args)
  (fmt-let 'in-html? #t (apply-cat args)))

(define (fmt-colored color . args)
  (fmt-if fmt-in-html?
          (cond
            ((eq? color 'bold)
             (cat "<b>" (apply-cat args) "</b>"))
            ((eq? color 'underline)
             (cat "<u>" (apply-cat args) "</u>"))
            (else
             (let ((cname (if (number? color) (cat "#" color) color)))
               (fmt-if fmt-use-html-font?
                       (cat "<font color=\"" cname "\">" (apply-cat args)
                            "</font>")
                       (cat "<span style=color:\"" cname "\">"
                            (apply-cat args) "</span>")))))
          (lambda (st)
            (let ((old-color (fmt-color st)))
              ((fmt-let 'color color
                        (cat (ansi-escape color)
                             (apply-cat args)
                             (if (or (memv color '(bold underline))
                                     (memv old-color '(bold underline)))
                                 (ansi-escape 'reset)
                                 (lambda (st) st))
                             (ansi-escape old-color)))
               st)))))

(define (fmt-red . args) (fmt-colored 'red (apply-cat args)))
(define (fmt-blue . args) (fmt-colored 'blue (apply-cat args)))
(define (fmt-green . args) (fmt-colored 'green (apply-cat args)))
(define (fmt-cyan . args) (fmt-colored 'cyan (apply-cat args)))
(define (fmt-yellow . args) (fmt-colored 'yellow (apply-cat args)))
(define (fmt-magenta . args) (fmt-colored 'magenta (apply-cat args)))
(define (fmt-white . args) (fmt-colored 'white (apply-cat args)))
(define (fmt-black . args) (fmt-colored 'black (apply-cat args)))
(define (fmt-bold . args) (fmt-colored 'bold (apply-cat args)))
(define (fmt-underline . args) (fmt-colored 'underline (apply-cat args)))

;;;; fmt-block.scm -- columnar formatting
;;
;; Copyright (c) 2006-2011 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Columnar formatting
;;
;; A line-oriented formatter.  Takes a list of
;;   (line-fmt1 gen-fmt1 line-fmt2 gen-fmt2 ...)
;; and formats each of the gen-fmt1 formats as columns, printed
;; side-by-side, each line allowing post-processing done by line-fmt1
;; (just use dsp if you want to display the lines verbatim).

;; Continuations come to the rescue to make this work properly,
;; letting us weave the output between different columns without
;; needing to build up intermediate strings.

(define (fmt-columns . ls)
  (lambda (orig-st)
    (call-with-current-continuation
     (lambda (return)
       (define (infinite? x)
         (and (pair? x) (pair? (cdr x)) (pair? (cddr x)) (caddr x)))
       (let ((q1 '())
             (q2 '())
             (remaining (length (remove infinite? ls))))
         (define (enq! proc) (set! q2 (cons proc q2)))
         (define (deq!) (let ((proc (car q1))) (set! q1 (cdr q1)) proc))
         (define (line-init!) (set! q1 (reverse q2)) (set! q2 '()))
         (define (line-done?) (null? q1))
         (define line-buf '())
         (define line-non-empty? #f)
         (define (write-column fmt str finite?)
           (set! line-buf (cons (cons fmt str) line-buf))
           (if finite? (set! line-non-empty? #t)))
         (define (write-line)
           (cond
            (line-non-empty?
             (for-each
              (lambda (x) (set! orig-st (((car x) (cdr x)) orig-st)))
              (reverse line-buf))
             (set! orig-st (nl orig-st))))
           (set! line-buf '())
           (set! line-non-empty? #f)
           (line-init!))
         (define (next cont)
           (enq! cont)
           (cond
            ((line-done?) 
             (write-line)
             (if (not (positive? remaining)) (finish) ((deq!) #f)))
            (else ((deq!) #f))))
         (define (finish)
           (write-line)
           (return orig-st))
         (define (make-empty-col fmt)
           (define (blank *ignored*)
             (write-column fmt "" #f)
             (next blank))    ; infinite loop, next terminates for us
           blank)
         (define (make-col st fmt gen finite?)
           (let ((acc '()))            ; buffer incomplete lines
             (lambda (*ignored*)
               (define (output* str st)
                 (let lp ((i 0))
                   (let ((nli (string-index str #\newline i)))
                     (cond
                      (nli
                       (let ((line
                              (string-concatenate-reverse
                               (cons (substring/shared str i nli) acc))))
                         (set! acc '())
                         (write-column fmt line finite?)
                         (call-with-current-continuation next) 
                         (lp (+ nli 1))))
                      (else
                       (set! acc (cons (substring/shared str i) acc))))))
                 ;; update - don't output or the string port will fill up
                 (fmt-update str st))
               ;; gen threads through it's own state, ignore result
               (gen (fmt-set-writer! (copy-fmt-state st) output*))
               ;; reduce # of remaining finite columns
               (set! remaining (- remaining 1))
               ;; write any remaining accumulated output
               (if (pair? acc)
                   (let ((s (string-concatenate-reverse acc)))
                     (write-column fmt s (and finite? (not (equal? s ""))))))
               ;; (maybe) loop with an empty column in place
               (if (not (positive? remaining))
                   (finish)
                   (next (make-empty-col fmt))))))
         ;; queue up the initial formatters
         (for-each
          (lambda (col)
            (let ((st (fmt-set-port! (copy-fmt-state orig-st)
                                     (open-output-string))))
              (enq! (make-col st (car col) (dsp (cadr col))
                              (not (infinite? col))))))
          ls)
         (line-init!)
         ;; start
         ((deq!) #f))))))

(define (columnar . ls)
  (define (proportional-width? w)
    (and (number? w)
         (or (< 0 w 1)
             (and (inexact? w) (= w 1.0)))))
  (define (whitespace-pad? st)
    (char-whitespace? (or (fmt-pad-char st) #\space)))
  (define (build-column ls)
    (let-optionals* ls ((fixed-width #f)
                        (width #f)
                        (last? #t)
                        (tail '())
                        (gen #f)
                        (prefix '())
                        (align 'left)
                        (infinite? #f))
      (define (scale-width st)
        (max 1 (inexact->exact
                (truncate (* width (- (fmt-width st) fixed-width))))))
      (define (padder)
        (if (proportional-width? width)
            (case align
              ((right)
               (lambda (str) (lambda (st) ((pad/left (scale-width st) str) st))))
              ((center)
               (lambda (str) (lambda (st) ((pad/both (scale-width st) str) st))))
              (else
               (lambda (str) (lambda (st) ((pad/right (scale-width st) str) st)))))
            (case align
              ((right) (lambda (str) (pad/left width str)))
              ((center) (lambda (str) (pad/both width str)))
              (else (lambda (str) (pad/right width str))))))
      (define (affix x)
        (cond
         ((pair? tail)
          (lambda (str)
            (cat (string-concatenate prefix)
                 (x str)
                 (string-concatenate tail))))
         ((pair? prefix)
          (lambda (str) (cat (string-concatenate prefix) (x str))))
         (else x)))
      (list
       ;; line formatter
       (affix
        (let ((pad (padder)))
          (if (and last? (not (pair? tail)) (eq? align 'left))
              (lambda (str)
                (lambda (st)
                  (((if (whitespace-pad? st) dsp pad) str) st)))
              pad)))
       ;; generator
       (if (proportional-width? width)
           (lambda (st) ((with-width (scale-width st) gen) st))
           (with-width width gen))
       infinite?
       )))
  (define (adjust-widths ls border-width)
    (let* ((fixed-ls
            (filter (lambda (x) (and (number? (car x)) (>= (car x) 1))) ls))
           (fixed-total (fold + border-width (map car fixed-ls)))
           (scaled-ls (filter (lambda (x) (proportional-width? (car x))) ls))
           (denom (- (length ls) (+ (length fixed-ls) (length scaled-ls))))
           (rest (if (zero? denom)
                     0
                     (exact->inexact
                      (/ (- 1 (fold + 0 (map car scaled-ls))) denom)))))
      (if (negative? rest)
          (error 'columnar "fractional widths must sum to less than 1"
                 (map car scaled-ls)))
      (map
       (lambda (col)
         (cons fixed-total
               (if (not (number? (car col))) (cons rest (cdr col)) col)))
       ls)))
  (define (finish ls border-width)
    (apply fmt-columns
           (map build-column (adjust-widths (reverse ls) border-width))))
  (let lp ((ls ls) (strs '()) (align 'left) (infinite? #f)
           (width #t) (border-width 0) (res '()))
    (cond
     ((null? ls)
      (if (pair? strs)
          (finish (cons (cons (caar res)
                              (cons #t (cons (append (reverse strs)
                                                     (caddar res))
                                             (cdddar res))))
                        (cdr res))
                  border-width)
          (finish (cons (cons (caar res) (cons #t (cddar res))) (cdr res))
                  border-width)))
     ((string? (car ls))
      (if (string-index (car ls) #\newline)
          (error 'columnar "column string literals can't contain newlines")
          (lp (cdr ls) (cons (car ls) strs) align infinite?
              width (+ border-width (string-length (car ls))) res)))
     ((number? (car ls))
      (lp (cdr ls) strs align infinite? (car ls) border-width res))
     ((eq? (car ls) 'infinite)
      (lp (cdr ls) strs align #t width border-width res))
     ((symbol? (car ls))
      (lp (cdr ls) strs (car ls) infinite? width border-width res))
     ((procedure? (car ls))
      (lp (cdr ls) '() 'left #f #t border-width
          (cons (list width #f '() (car ls) (reverse strs) align infinite?)
                res)))
     (else
      (error 'columnar "invalid column" (car ls))))))

(define (max-line-width string-width str)
  (let lp ((i 0) (hi 0))
    (let ((j (string-index str #\newline i)))
      (if j
          (lp (+ j 1) (max hi (string-width (substring str i j))))
          (max hi (string-width (substring str i (string-length str))))))))

(define (pad-finite st proc width)
  (let* ((str ((fmt-to-string proc) (copy-fmt-state st)))
         (w (max-line-width (or (fmt-string-width st) string-length) str)))
    (list (cat str)
          (if (and (integer? width) (exact? width))
              (max width w)
              w))))

(define (tabular . ls)
  (lambda (st)
    (let lp ((ls ls) (infinite? #f) (width #t) (res '()))
      (cond
       ((null? ls)
        ((apply columnar (reverse res)) st))
       ((number? (car ls))
        (lp (cdr ls) infinite? (car ls) res))
       ((eq? 'infinite (car ls))
        (lp (cdr ls) #t width (cons (car ls) res)))
       ((procedure? (car ls))
        (if infinite?
            (if width
                (lp (cdr ls) #f #t (cons (car ls) (cons width res)))
                (lp (cdr ls) #f #t (cons (car ls) res)))
            (let ((gen+width (pad-finite st (car ls) width)))
              (lp (cdr ls) #f #t (append gen+width res)))))
       (else
        (lp (cdr ls) infinite? width (cons (car ls) res)))))))

;; break lines only, don't fmt-join short lines or justify
(define (fold-lines . ls)
  (lambda (st)
    (define output (fmt-writer st))
    (define (kons-in-line str st)
      (let ((len ((or (fmt-string-width st) string-length) str))
            (space (- (fmt-width st) (fmt-col st))))
        (cond
          ((or (<= len space) (not (positive? space)))
           (output str st))
          (else
           (kons-in-line
            (substring/shared str space len)
            (output nl-str
                    (output (substring/shared str 0 space) st)))))))
    ((fmt-let
      'writer
      (lambda (str st)
        (let lp ((str str) (st st))
          (let ((nli (string-index str #\newline)))
            (cond
              ((not nli)
               (kons-in-line str st))
              (else
               (lp (substring/shared str (+ nli 1))
                   (output nl-str
                           (kons-in-line
                            (substring/shared str 0 nli)
                            st))))))))
      (apply-cat ls))
     st)))

(define (wrap-fold-words seq knil max-width get-width line . o)
  (let* ((last-line (if (pair? o) (car o) line))
         (vec (if (list? seq) (list->vector seq) seq))
         (len (vector-length vec))
         (len-1 (- len 1))
         (breaks (make-vector len #f))
         (penalties (make-vector len #f))
         (widths
          (list->vector
           (map get-width (if (list? seq) seq (vector->list vec))))))
    (define (largest-fit i)
      (let lp ((j (+ i 1)) (width (vector-ref widths i)))
        (let ((width (+ width 1 (vector-ref widths j))))
          (cond
            ((>= width max-width) (- j 1))
            ((>= j len-1) len-1)
            (else (lp (+ j 1) width))))))
    (define (min-penalty! i)
      (cond
        ((>= i len-1) 0)
        ((vector-ref penalties i))
        (else
         (vector-set! penalties i (expt (+ max-width 1) 3))
         (vector-set! breaks i i)
         (let ((k (largest-fit i)))
           (let lp ((j i) (width 0))
             (if (<= j k)
                 (let* ((width (+ width (vector-ref widths j)))
                        (break-penalty
                         (+ (max 0 (expt (- max-width (+ width (- j i))) 3))
                            (min-penalty! (+ j 1)))))
                   (cond
                     ((< break-penalty (vector-ref penalties i))
                      (vector-set! breaks i j)
                      (vector-set! penalties i break-penalty)))
                   (lp (+ j 1) width)))))
         (if (>= (vector-ref breaks i) len-1)
             (vector-set! penalties i 0))
         (vector-ref penalties i))))
    (define (sub-list i j)
      (let lp ((i i) (res '()))
        (if (> i j)
            (reverse res)
            (lp (+ i 1) (cons (vector-ref vec i) res)))))
    (cond
     ((zero? len)
      ;; degenerate case
      (last-line '() knil))
     (else
      ;; compute optimum breaks
      (vector-set! breaks len-1 len-1)
      (vector-set! penalties len-1 0)
      (min-penalty! 0)
      ;; fold
      (let lp ((i 0) (acc knil))
        (let ((break (vector-ref breaks i)))
          (if (>= break len-1)
              (last-line (sub-list i len-1) acc)
              (lp (+ break 1) (line (sub-list i break) acc)))))))))

;; XXXX don't split, traverse the string manually and keep track of
;; sentence endings so we can insert two spaces
(define (wrap-fold str . o)
  (apply wrap-fold-words (string-tokenize str) o))

(define (wrap-lines . ls)
  (define (print-line ls st)
    (nl ((fmt-join dsp ls " ") st)))
  (define buffer '())
  (lambda (st)
    ((fmt-let
      'writer
      (lambda (str st) (set! buffer (cons str buffer)) st)
      (apply-cat ls))
     st)
    (wrap-fold (string-concatenate-reverse buffer)
               st (fmt-width st)
               (or (fmt-string-width st) string-length)
               print-line)))

(define (justify . ls)
  (lambda (st)
    (let ((width (fmt-width st))
          (string-width (or (fmt-string-width st) string-length))
          (output (fmt-writer st))
          (buffer '()))
      (define (justify-line ls st)
        (if (null? ls)
            (nl st)
            (let* ((sum (fold (lambda (s n) (+ n (string-width s))) 0 ls))
                   (len (length ls))
                   (diff (max 0 (- width sum)))
                   (sep (make-string (if (= len 1)
                                         0
                                         (quotient diff (- len 1)))
                                     #\space))
                   (rem (if (= len 1)
                            diff
                            (remainder diff (- len 1)))))
              (output
               (call-with-output-string
                 (lambda (p)
                   (display (car ls) p)
                   (let lp ((ls (cdr ls)) (i 1))
                     (cond
                       ((pair? ls)
                        (display sep p)
                        (if (<= i rem) (write-char #\space p))
                        (display (car ls) p)
                        (lp (cdr ls) (+ i 1)))))
                   (newline p)))
               st))))
      (define (justify-last ls st)
        (nl ((fmt-join dsp ls " ") st)))
      ((fmt-let
        'writer
        (lambda (str st) (set! buffer (cons str buffer)) st)
        (apply-cat ls))
       st)
      (wrap-fold (string-concatenate-reverse buffer)
                 st width string-width justify-line justify-last))))

(define (fmt-file path)
  (lambda (st)
    (call-with-input-file path
      (lambda (p)
        (let lp ((st st))
          (let ((line (read-line p)))
            (if (eof-object? line)
                st
                (lp (nl ((dsp line) st))))))))))

(define (line-numbers . o)
  (let ((start (if (pair? o) (car o) 1)))
    (fmt-join/range dsp start #f nl-str)))

;;;; fmt-gauche.scm -- Gauche fmt extension
;;
;; Copyright (c) 2006-2011 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

(define-module text.fmt
  (use srfi-1)
  (use srfi-6)
  (use srfi-13)
  (export
   new-fmt-state
   fmt fmt-start fmt-if fmt-capture fmt-let fmt-bind fmt-null
   fmt-ref fmt-set! fmt-add-properties! fmt-set-property!
   fmt-col fmt-set-col! fmt-row fmt-set-row!
   fmt-radix fmt-set-radix! fmt-precision fmt-set-precision!
   fmt-properties fmt-set-properties! fmt-width fmt-set-width!
   fmt-writer fmt-set-writer! fmt-port fmt-set-port!
   fmt-decimal-sep fmt-set-decimal-sep!
   fmt-file fmt-try-fit cat apply-cat nl fl nl-str
   fmt-join fmt-join/last fmt-join/dot
   fmt-join/prefix fmt-join/suffix fmt-join/range
   pad pad/right pad/left pad/both trim trim/left trim/both trim/length
   fit fit/left fit/both tab-to space-to wrt wrt/unshared dsp
   pretty pretty/unshared slashified maybe-slashified
   num num/si num/fit num/comma radix fix decimal-align ellipses
   upcase downcase titlecase pad-char comma-char decimal-char
   with-width wrap-lines fold-lines justify
   make-string-fmt-transformer
   make-space make-nl-space display-to-string write-to-string
   fmt-columns columnar tabular line-numbers
   ))
(select-module text.fmt)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SRFI-69 compatible hashtables

(define (make-eq?-table)
  (make-hash-table 'eq?))
(define hash-table-ref/default hash-table-get)
(define hash-table-set! hash-table-put!)
(define (hash-table-walk tab proc) (hash-table-for-each tab proc))

(define (mantissa+exponent num)
  (let ((vec (decode-float num)))
    (list (vector-ref vec 0) (vector-ref vec 1))))

;;;; fmt-js.scm -- javascript formatting utilities
;;
;; Copyright (c) 2011-2012 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (js-expr x)
  (fmt-let 'gen js-expr/sexp
           (lambda (st) (((or (fmt-gen st) js-expr/sexp) x) st))))

(define (js-expr/sexp x)
  (cond
   ((procedure? x)
    x)
   ((pair? x)
    (case (car x)
      ((%fun function) (apply js-function (cdr x)))
      ((%var var) (apply js-var (cdr x)))
      ((eq? ===) (apply js=== (cdr x)))
      ((>>>) (apply js>>> (cdr x)))
      ((%array) (js-array x))
      ((%object) (js-object (cdr x)))
      ((%comment) (js-comment x))
      (else (c-expr/sexp x))))
   ((vector? x) (js-array x))
   ((boolean? x) (cat (if x "true" "false")))
   ((char? x) (js-expr/sexp (string x)))
   (else (c-expr/sexp x))))

(define (js-function . x)
  (let* ((name (and (symbol? (car x)) (car x)))
         (params (if name (cadr x) (car x)))
         (body (if name (cddr x) (cdr x))))
    (c-block
     (cat "function " (dsp (or name ""))  "("
          (fmt-join dsp params ", ") ")")
     (fmt-let 'return? #t (c-in-stmt (apply c-begin body))))))

(define (js-var . args)
  (apply c-var 'var args))

(define (js=== . args)
  (apply c-op "===" args))

(define (js>>> . args)
  (apply c-op ">>>" args))

(define (js-comment . args)
  (columnar "// " (apply-cat args)))

(define (js-array x)
  (let ((ls (vector->list x)))
    (c-wrap-stmt
     (fmt-try-fit
      (fmt-let 'no-wrap? #t (cat "[" (fmt-join js-expr ls ", ") "]"))
      (lambda (st)
        (let* ((col (fmt-col st))
               (sep (string-append "," (make-nl-space col))))
          ((cat "[" (fmt-join js-expr ls sep) "]" nl) st)))))))

(define (js-pair x)
  (cat (js-expr (car x)) ": " (js-expr (cdr x))))

(define (js-object ls)
  (c-in-expr
   (fmt-try-fit
    (fmt-let 'no-wrap? #t (cat "{" (fmt-join js-pair ls ", ") "}"))
    (lambda (st)
      (let* ((col (fmt-col st))
             (sep (string-append "," (make-nl-space col))))
        ((cat "{" (fmt-join js-pair ls sep) "}" nl) st))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; fmt-pretty.scm -- pretty printing format combinator
;;
;; Copyright (c) 2006-2007 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; additional settings

(define (fmt-shares st) (fmt-ref st 'shares))
(define (fmt-set-shares! st x) (fmt-set! st 'shares x))
(define (fmt-copy-shares st)
  (fmt-set-shares! (copy-fmt-state st) (copy-shares (fmt-shares st))))

(define (copy-shares shares)
  (let ((tab (make-eq?-table)))
    (hash-table-walk
     (car shares)
     (lambda (obj x) (eq?-table-set! tab obj (cons (car x) (cdr x)))))
    (cons tab (cdr shares))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; utilities

(define (fmt-shared-write obj proc)
  (lambda (st)
    (let* ((shares (fmt-shares st))
           (cell (and shares (eq?-table-ref (car shares) obj))))
      (if (pair? cell)
          (cond
            ((cdr cell)
             ((fmt-writer st) (gen-shared-ref (car cell) "#") st))
            (else
             (set-car! cell (cdr shares))
             (set-cdr! cell #t)
             (set-cdr! shares (+ (cdr shares) 1))
             (proc ((fmt-writer st) (gen-shared-ref (car cell) "=") st))))
          (proc st)))))

(define (fmt-join/shares fmt ls . o)
  (let ((sep (dsp (if (pair? o) (car o) " "))))
    (lambda (st)
      (if (null? ls)
          st
          (let* ((shares (fmt-shares st))
                 (tab (car shares))
                 (output (fmt-writer st)))
            (let lp ((ls ls) (st st))
              (let ((st ((fmt (car ls)) st))
                    (rest (cdr ls)))
                (cond
                 ((null? rest) st)
                 ((pair? rest)
                  (call-with-shared-ref/cdr rest st shares
                      (lambda (st) (lp rest st))
                    sep))
                 (else ((fmt rest) (output ". " (sep st))))))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; pretty printing

(define (non-app? x)
  (if (pair? x)
      (or (not (or (null? (cdr x)) (pair? (cdr x))))
          (non-app? (car x)))
      (not (symbol? x))))

(define syntax-abbrevs
  '((quote . "'") (quasiquote . "`") (unquote . ",") (unquote-splicing . ",@")
    ))

(define (pp-let ls)
  (if (and (pair? (cdr ls)) (symbol? (cadr ls)))
      (pp-with-indent 2 ls)
      (pp-with-indent 1 ls)))

(define indent-rules
  `((lambda . 1) (define . 1)
    (let . ,pp-let) (loop . ,pp-let)
    (let* . 1) (letrec . 1) (letrec* . 1) (and-let* . 1) (let1 . 2)
    (let-values . 1) (let*-values . 1) (receive . 2) (parameterize . 1)
    (let-syntax . 1) (letrec-syntax . 1) (syntax-rules . 1) (syntax-case . 2)
    (match . 1) (match-let . 1) (match-let* . 1)
    (if . 3) (when . 1) (unless . 1) (case . 1) (while . 1) (until . 1)
    (do . 2) (dotimes . 1) (dolist . 1) (test . 1)
    (condition-case . 1) (guard . 1) (rec . 1)
    (call-with-current-continuation . 0)
    ))

(define indent-prefix-rules
  `(("with-" . -1) ("call-with-" . -1) ("define-" . 1))
  )

(define indent-suffix-rules
  `(("-case" . 1))
  )

(define (pp-indentation form)
  (let ((indent
         (cond
          ((assq (car form) indent-rules) => cdr)
          ((and (symbol? (car form))
                (let ((str (symbol->string (car form))))
                  (or (find (lambda (rx) (string-prefix? (car rx) str))
                            indent-prefix-rules)
                      (find (lambda (rx) (string-suffix? (car rx) str))
                            indent-suffix-rules))))
           => cdr)
          (else #f))))
    (if (and (number? indent) (negative? indent))
        (max 0 (- (+ (length+ form) indent) 1))
        indent)))

(define (pp-with-indent indent-rule ls)
  (lambda (st)
    (let* ((col1 (fmt-col st))
           (st ((cat "(" (pp-object (car ls))) st))
           (col2 (fmt-col st))
           (fixed (take* (cdr ls) (or indent-rule 1)))
           (tail (drop* (cdr ls) (or indent-rule 1)))
           (st2 (fmt-copy-shares st))
           (first-line
            ((fmt-to-string (cat " " (fmt-join/shares pp-flat fixed " "))) st2))
           (default
             (let ((sep (make-nl-space (+ col1 1))))
               (cat sep (fmt-join/shares pp-object (cdr ls) sep) ")"))))
      (cond
       ((< (+ col2 (string-length first-line)) (fmt-width st2))
        ;; fixed values on first line
        (let ((sep (make-nl-space
                    (if indent-rule (+ col1 2) (+ col2 1)))))
          ((cat first-line
                (cond
                 ((not (or (null? tail) (pair? tail)))
                  (cat ". " (pp-object tail)))
                 ((> (length+ (cdr ls)) (or indent-rule 1))
                  (cat sep (fmt-join/shares pp-object tail sep)))
                 (else
                  fmt-null))
                ")")
           st2)))
       (indent-rule ;;(and indent-rule (not (pair? (car ls))))
        ;; fixed values lined up, body indented two spaces
        ((fmt-try-fit
          (lambda (st)
            ((cat
              " "
              (fmt-join/shares pp-object fixed (make-nl-space (+ col2 1)))
              (if (pair? tail)
                  (let ((sep (make-nl-space (+ col1 2))))
                    (cat sep (fmt-join/shares pp-object tail sep)))
                  "")
              ")")
             (fmt-copy-shares st)))
          default)
         st))
       (else
        ;; all on separate lines
        (default st))))))

(define (pp-app ls)
  (let ((indent-rule (pp-indentation ls)))
    (if (procedure? indent-rule)
        (indent-rule ls)
        (pp-with-indent indent-rule ls))))

;; the elements may be shared, just checking the top level list
;; structure
(define (proper-non-shared-list? ls shares)
  (let ((tab (car shares)))
    (let lp ((ls ls))
      (or (null? ls)
          (and (pair? ls)
               (not (eq?-table-ref tab ls))
               (lp (cdr ls)))))))

(define (pp-flat x)
  (cond
    ((pair? x)
     (fmt-shared-write
      x
      (cond
        ((and (pair? (cdr x)) (null? (cddr x))
              (assq (car x) syntax-abbrevs))
         => (lambda (abbrev)
              (cat (cdr abbrev) (pp-flat (cadr x)))))
        (else
         (cat "(" (fmt-join/shares pp-flat x " ") ")")))))
    ((vector? x)
     (fmt-shared-write
      x
      (cat "#(" (fmt-join/shares pp-flat (vector->list x) " ") ")")))
    (else
     (lambda (st) ((write-with-shares x (fmt-shares st)) st)))))

(define (pp-pair ls)
  (fmt-shared-write
   ls
   (cond
    ;; one element list, no lines to break
    ((null? (cdr ls))
     (cat "(" (pp-object (car ls)) ")"))
    ;; quote or other abbrev
    ((and (pair? (cdr ls)) (null? (cddr ls))
          (assq (car ls) syntax-abbrevs))
     => (lambda (abbrev)
          (cat (cdr abbrev) (pp-object (cadr ls)))))
    (else
     (fmt-try-fit
      (lambda (st) ((pp-flat ls) (fmt-copy-shares st)))
      (lambda (st)
        (if (and (non-app? ls)
                 (proper-non-shared-list? ls (fmt-shares st)))
            ((pp-data-list ls) st)
            ((pp-app ls) st))))))))

(define (pp-data-list ls)
  (lambda (st)
    (let* ((output (fmt-writer st))
           (st (output "(" st))
           (col (fmt-col st))
           (width (- (fmt-width st) col))
           (st2 (fmt-copy-shares st)))
      (cond
        ((and (pair? (cdr ls)) (pair? (cddr ls)) (pair? (cdddr ls))
              ((fits-in-columns ls pp-flat width) st2))
         => (lambda (ls)
              ;; at least four elements which can be broken into columns
              (let* ((prefix (make-nl-space (+ col 1)))
                     (widest (+ 1 (car ls)))
                     (columns (quotient width widest))) ; always >= 2
                (let lp ((ls (cdr ls)) (st st2) (i 1))
                  (cond
                    ((null? ls)
                     (output ")" st))
                    ((null? (cdr ls))
                     (output ")" (output (car ls) st)))
                    (else
                     (let ((st (output (car ls) st)))
                       (if (>= i columns)
                           (lp (cdr ls) (output prefix st) 1)
                           (let* ((pad (- widest (string-length (car ls))))
                                  (st (output (make-space pad) st)))
                             (lp (cdr ls) st (+ i 1)))))))))))
        (else
         ;; no room, print one per line
         ((cat (fmt-join pp-object ls (make-nl-space col)) ")") st))))))

(define (pp-vector vec)
  (fmt-shared-write vec (cat "#" (pp-data-list (vector->list vec)))))

(define (pp-object obj)
  (cond
    ((pair? obj) (pp-pair obj))
    ((vector? obj) (pp-vector obj))
    (else (lambda (st) ((write-with-shares obj (fmt-shares st)) st)))))

(define (pretty obj)
  (fmt-bind 'shares (cons (make-shared-ref-table obj) 0)
            (cat (pp-object obj) fl)))

(define (pretty/unshared obj)
  (fmt-bind 'shares (cons (make-eq?-table) 0) (cat (pp-object obj) fl)))

;;;; fmt-unicode.scm -- Unicode character width and ANSI escape support
;;
;; Copyright (c) 2006-2007 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;; a condensed non-spacing mark range from UnicodeData.txt (chars with
;; the Mn property) - generated partially by hand, should automate
;; this better

(define low-non-spacing-chars
  (u8vector
#xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
#x78    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0 #xfe #xff #xff #xff #xff #xff #x1f    0    0    0    0    0    0    0
   0    0 #x3f    0    0    0    0    0    0 #xf8 #xff #x01    0    0 #x01    0
   0    0    0    0    0    0    0    0    0    0 #xc0 #xff #xff #x3f    0    0
   0    0 #x02    0    0    0 #xff #xff #xff #x07    0    0    0    0    0    0
   0    0    0    0 #xc0 #xff #x01    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
#x06    0    0    0    0    0    0 #x10 #xfe #x21 #x1e    0 #x0c    0    0    0
#x02    0    0    0    0    0    0 #x10 #x1e #x20    0    0 #x0c    0    0    0
#x06    0    0    0    0    0    0 #x10 #xfe #x3f    0    0    0    0 #x03    0
#x06    0    0    0    0    0    0 #x30 #xfe #x21    0    0 #x0c    0    0    0
#x02    0    0    0    0    0    0 #x90 #x0e #x20 #x40    0    0    0    0    0
#x04    0    0    0    0    0    0    0    0 #x20    0    0    0    0    0    0
   0    0    0    0    0    0    0 #xc0 #xc1 #xff #x7f    0    0    0    0    0
   0    0    0    0    0    0    0 #x10 #x40 #x30    0    0    0    0    0    0
   0    0    0    0    0    0    0    0 #x0e #x20    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0 #x04 #x7c    0    0    0    0    0
   0    0    0    0    0    0 #xf2 #x07 #x80 #x7f    0    0    0    0    0    0
   0    0    0    0    0    0 #xf2 #x1f    0 #x3f    0    0    0    0    0    0
   0    0    0 #x03    0    0 #xa0 #x02    0    0    0    0    0    0 #xfe #x7f
#xdf    0 #xff #xff #xff #xff #xff #x1f #x40    0    0    0    0    0    0    0
   0    0    0    0    0 #xe0 #xfd #x02    0    0    0 #x03    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0 #x1c    0    0    0 #x1c    0    0    0 #x0c    0    0    0 #x0c    0
   0    0    0    0    0    0 #x80 #x3f #x40 #xfe #x0f #x20    0    0    0    0
   0 #x38    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0 #x02    0    0    0    0    0    0    0    0    0    0
   0    0    0    0 #x87 #x01 #x04 #x0e    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0    0    0    0    0    0    0
   0    0    0    0    0    0    0    0    0    0 #xff #x1f #xe2 #x07
       ))

(define (unicode-char-width c)
  (let ((ci (char->integer c)))
    (cond
      ;; hand-checked ranges from EastAsianWidth.txt
      ((<= #x1100 ci #x115F) 2) ; Hangul
      ((<= #x2E80 ci #x4DB5) 2) ; CJK
      ((<= #x4E00 ci #xA4C6) 2)
      ((<= #xAC00 ci #xD7A3) 2) ; Hangul
      ((<= #xF900 ci #xFAD9) 2) ; CJK compat
      ((<= #xFE10 ci #xFE6B) 2)
      ((<= #xFF01 ci #xFF60) 2)
      ((<= #xFFE0 ci #xFFE6) 2)
      ((<= #x20000 ci #x30000) 2)
      ;; non-spacing mark (Mn) ranges from UnicodeData.txt
      ((<= #x0300 ci #x3029)
       ;; inlined bit-vector-ref for portability
       (let* ((i (- ci #x0300))
              (byte (quotient i 8))
              (off (remainder i 8)))
         (if (zero? (bitwise-and (u8vector-ref low-non-spacing-chars byte)
                                 (arithmetic-shift 1 off)))
             1
             0)))
      ((<= #x302A ci #x302F) 0)
      ((<= #x3099 ci #x309A) 0)
      ((= #xFB1E ci) 0)
      ((<= #xFE00 ci #xFE23) 0)
      ((<= #x1D167 ci #x1D169) 0)
      ((<= #x1D17B ci #x1D182) 0)
      ((<= #x1D185 ci #x1D18B) 0)
      ((<= #x1D1AA ci #x1D1AD) 0)
      ((<= #xE0100 ci #xE01EF) 0)
      (else 1))))

(define (unicode-string-width str . o)
  (let ((start (if (pair? o) (car o) 0))
        (end (if (and (pair? o) (pair? (cdr o)))
                 (cadr o)
                 (string-length str))))
    (let lp1 ((i start) (width 0))
      (if (>= i end)
          width
          (let ((c (string-ref str i)))
            (cond
              ;; ANSI escapes
              ((and (= 27 (char->integer c)) ; esc
                    (< (+ i 1) end)
                    (eqv? #\[ (string-ref str (+ i 1))))
               (let lp2 ((i (+ i 2)))
                 (cond ((>= i end) width)
                       ((memv (string-ref str i) '(#\m #\newline))
                        (lp1 (+ i 1) width))
                       (else (lp2 (+ i 1))))))
              ;; unicode characters
              ((>= (char->integer c) #x80)
               (lp1 (+ i 1) (+ width (unicode-char-width c))))
              ;; normal ASCII
              (else (lp1 (+ i 1) (+ width 1)))))))))

(define (fmt-unicode . args)
  (fmt-let 'string-width unicode-string-width (apply-cat args)))

body {
color: black;
background-color: white;
margin-top: 2em;
margin-left: 10%;
width: 400pt;
}

pre {
  background-color: beige;
}

pre.scheme {
  background-color: white;
}

.subject {
}

h1 {
margin-left: -5%;
margin-top: 2em;
font-size: large;
}

h2 {
margin-left: -4%;
margin-top: 1em;
font-size: large;
}

h3,h4,h5,h6 {
margin-left: -3%;
margin-top: .5em;
font-size: small;
}

.navigation {
color: red;
background-color: beige;
text-align: right;
font-style: italic;
}


.scheme {
color: brown;
}

.scheme .keyword {
color: #cc0000;
font-weight: bold;
}

.scheme .variable {
color: navy;
}

.scheme .global {
color: purple;
}

.scheme .constant,.number,.char,.string,.boolean {
color: green;
}

.scheme .comment {
color: teal;
}

\title{Combinator Formatting}

\eval
(begin
  (display "<style>\n")
  (display (with-input-from-file "fmt.css" read-string))
  (display "</style>\n"))

\flushright{\urlh{http://synthcode.com/}{Alex Shinn}}
\flushright{\urlh{http://synthcode.com/scheme/fmt/fmt-0.8.4.tar.gz}{Download Version 0.8.4}}

\eval(display "<br /><br />\n\n")

A library of procedures for formatting Scheme objects to text in
various ways, and for easily concatenating, composing and extending
these formatters efficiently without resorting to capturing and
manipulating intermediate strings.

\eval(display "<br /><br />\n\n")

\section{Table of Contents}

\eval(display "\n\n<!-- TOC -->\n\n")

\eval(display "<br /><br />\n\n")

\section{Installation}

Available for Chicken as the \p{fmt} egg, providing the \q{fmt},
\q{fmt-c}, \q{fmt-color} and \q{fmt-unicode} extensions.  To install
manually for Chicken just run \p{"chicken-setup"} in the fmt
directory.

For Gauche run \p{"make gauche && make install-gauche"}.  The modules
are installed as \q{text.fmt}, \q{text.fmt.c}, \q{text.fmt.color} and
\q{text.fmt.unicode}.

For MzScheme you can download and install the latest \p{fmt.plt} yourself
from:

  \urlh{http://synthcode.com/scheme/fmt/fmt.plt}{http://synthcode.com/scheme/fmt/fmt.plt}

To build the \p{fmt.plt} for yourself you can run \p{"make mzscheme"}.

For Scheme48 the package descriptions are in \p{fmt-scheme48.scm}:

\q{
> ,config ,load fmt-scheme48.scm
> ,open fmt
}

For other implementations you'll need to load SRFI's 1, 6, 13, 33
(sample provided) and 69 (also provided), and then load the following
files:

\q{
  (load "let-optionals.scm")  ; if you don't have LET-OPTIONALS*
  (load "read-line.scm")      ; if you don't have READ-LINE
  (load "string-ports.scm")   ; if you don't have CALL-WITH-OUTPUT-STRING
  (load "make-eq-table.scm")
  (load "mantissa.scm")
  (load "fmt.scm")
  (load "fmt-pretty.scm")     ; optional pretty printing
  (load "fmt-column.scm")     ; optional columnar output
  (load "fmt-c.scm")          ; optional C formatting utilities
  (load "fmt-color.scm")      ; optional color utilities
  (load "fmt-unicode.scm")    ; optional Unicode-aware formatting,
                              ;   also requires SRFI-4 or SRFI-66
}

\section{Background}

There are several approaches to text formatting.  Building strings to
\q{display} is not acceptable, since it doesn't scale to very large
output.  The simplest realistic idea, and what people resort to in
typical portable Scheme, is to interleave \q{display} and \q{write}
and manual loops, but this is both extremely verbose and doesn't
compose well.  A simple concept such as padding space can't be
achieved directly without somehow capturing intermediate output.

The traditional approach is to use templates - typically strings,
though in theory any object could be used and indeed Emacs' mode-line
format templates allow arbitrary sexps.  Templates can use either
escape sequences (as in C's \q{printf} and \urlh{#BIBITEM_2}{CL's}
\q{format}) or pattern matching (as in Visual Basic's \q{Format},
\urlh{#BIBITEM_6}{Perl6's} \q{form}, and SQL date formats).  The
primary disadvantage of templates is the relative difficulty (usually
impossibility) of extending them, their opaqueness, and the
unreadability that arises with complex formats.  Templates are not
without their advantages, but they are already addressed by other
libraries such as \urlh{#BIBITEM_3}{SRFI-28} and
\urlh{#BIBITEM_4}{SRFI-48}.

This library takes a combinator approach.  Formats are nested chains
of closures, which are called to produce their output as needed.
The primary goal of this library is to have, first and foremost, a
maximally expressive and extensible formatting library.  The next
most important goal is scalability - to be able to handle
arbitrarily large output and not build intermediate results except
where necessary.  The third goal is brevity and ease of use.

\section{Usage}

The primary interface is the \q{fmt} procedure:

  \q{(fmt <output-dest> <format> ...)}

where \q{<output-dest>} has the same semantics as with \q{format} -
specifically it can be an output-port, \q{#t} to indicate the current
output port, or \q{#f} to accumulate output into a string.

Each \q{<format>} should be a format closure as discussed below.  As a
convenience, non-procedure arguments are also allowed and are
formatted similar to \q{display}, so that

  \q{(fmt #f "Result: " res nl)}

would return the string \q{"Result: 42\n"}, assuming \q{RES} is bound
to \q{42}.

\q{nl} is the newline format combinator.

\section{Specification}

The procedure names have gone through several variations, and I'm
still open to new suggestions.  The current approach is to use
abbreviated forms of standard output procedures when defining an
equivalent format combinator (thus \q{display} becomes \q{dsp} and
\q{write} becomes \q{wrt}), and to use an \q{fmt-} prefix for
utilities and less common combinators.  Variants of the same formatter
get a \q{/<variant>} suffix.

\subsection{Formatting Objects}

\subsubsection*{(dsp <obj>)}

Outputs \q{<obj>} using \q{display} semantics.  Specifically, strings
are output without surrounding quotes or escaping and characters are
written as if by \q{write-char}.  Other objects are written as with
\q{write} (including nested strings and chars inside \q{<obj>}).  This
is the default behavior for top-level formats in \q{fmt}, \q{cat} and
most other higher-order combinators.

\subsubsection*{(wrt <obj>)}

Outputs \q{<obj>} using \q{write} semantics.  Handles shared
structures as in \urlh{#BIBITEM_5}{SRFI-38}.

\subsubsection*{(wrt/unshared <obj>)}

As above, but doesn't handle shared structures.  Infinite loops can
still be avoided if used inside a combinator that truncates data (see
\q{trim} and \q{fit} below).

\subsubsection*{(pretty <obj>)}

Pretty-prints \q{<obj>}.  Also handles shared structures.  Unlike many
other pretty printers, vectors and data lists (lists that don't begin
with a (nested) symbol), are printed in tabular format when there's
room, greatly saving vertical space.

\subsubsection*{(pretty/unshared <obj>)}

As above but without sharing.

\subsubsection*{(slashified <str> [<quote-ch> <esc-ch> <renamer>])}

Outputs the string \q{<str>}, escaping any quote or escape characters.
If \q{<esc-ch>} is \q{#f} escapes only the \q{<quote-ch>} by
doubling it, as in SQL strings and CSV values.  If \q{<renamer>} is
provided, it should be a procedure of one character which maps that
character to its escape value, e.g. \q{#\newline => #\n}, or \q{#f} if
there is no escape value.

  \q{(fmt #f (slashified "hi, \"bob!\""))}

  \q{=> "hi, \"bob!\""}

\subsubsection*{(maybe-slashified <str> <pred> [<quote-ch> <esc-ch> <renamer>])}

Like \q{slashified}, but first checks if any quoting is required (by
the existence of either any quote or escape characters, or any
character matching \q{<pred>}), and if so outputs the string in quotes
and with escapes.  Otherwise outputs the string as is.

  \q{(fmt #f (maybe-slashified "foo" char-whitespace? #\"))}

  \q{=> "foo"}

  \q{(fmt #f (maybe-slashified "foo bar" char-whitespace? #\"))}

  \q{=> "\"foo bar\""}

  \q{(fmt #f (maybe-slashified "foo\"bar\"baz" char-whitespace? #\"))}

  \q{=> "\"foo\"bar\"baz\""}

\subsection{Formatting Numbers}

\subsubsection*{(num <n> [<radix> <precision> <sign> <comma> <comma-sep> <decimal-sep>])}

Formats a single number \q{<n>}.  You can optionally specify any
\q{<radix>} from 2 to 36 (even if \q{<n>} isn't an integer).
\q{<precision>} forces a fixed-point format.

A \q{<sign>} of \q{#t} indicates to output a plus sign (+) for positive
integers.  However, if \q{<sign>} is a character, it means to wrap the
number with that character and its mirror opposite if the number is
negative.  For example, \q{#\(} prints negative numbers in parenthesis,
financial style: \q{-3.14 => (3.14)}

\q{<comma>} is an integer specifying the number of digits between
commas.  Variable length, as in subcontinental-style, is not yet
supported.

\q{<comma-sep>} is the character to use for commas, defaulting to \q{#\,}.

\q{<decimal-sep>} is the character to use for decimals, defaulting to
\q{#\.}, or to \q{#\,} (European style) if \q{<comma-sep>} is already
\q{#\.}.

These parameters may seem unwieldy, but they can also take their
defaults from state variables, described below.

\subsubsection*{(num/comma <n> [<base> <precision> <sign>])}

Shortcut for \q{num} to print with commas.

  \q{(fmt #f (num/comma 1234567))}

  \q{=> "1,234,567"}

\subsubsection*{(num/si <n> [<base> <suffix>])}

Abbreviates \q{<n>} with an SI suffix as in the -h or --si option to
many GNU commands.  The base defaults to 1024, using suffix names
like Ki, Mi, Gi, etc.  Other bases (e.g. the standard 1000) have the
suffixes k, M, G, etc.

The \q{<suffix>} argument is appended only if an abbreviation is used.

  \q{(fmt #f (num/si 608))}

  \q{=> "608"}

  \q{(fmt #f (num/si 3986))}

  \q{=> "3.9Ki"}

  \q{(fmt #f (num/si 3986 1000 "B"))}

  \q{=> "4kB"}

See \urlh{http://www.bipm.org/en/si/si_brochure/chapter3/prefixes.html}{http://www.bipm.org/en/si/si_brochure/chapter3/prefixes.html}.

\subsubsection*{(num/fit <width> <n> . <ARGS>)}

Like \q{num}, but if the result doesn't fit in \q{<width>}, output
instead a string of hashes (with the current \q{<precision>}) rather
than showing an incorrectly truncated number.  For example

  \q{(fmt #f (fix 2 (num/fit 4 12.345)))}
  \q{=> "#.##"}

\subsubsection*{(num/roman <n>)}

Formats the number as a Roman numeral:

  \q{(fmt #f (num/roman 1989))}
  \q{=> "MCMLXXXIX"}

\subsubsection*{(num/old-roman <n>)}

Formats the number as an old-style Roman numeral, without the
subtraction abbreviation rule:

  \q{(fmt #f (num/old-roman 1989))}
  \q{=> "MDCCCCLXXXVIIII"}


\subsection{Formatting Space}

\subsubsection*{nl}

Outputs a newline.

\subsubsection*{fl}

Short for "fresh line," outputs a newline only if we're not already
at the start of a line.

\subsubsection*{(space-to <column>)}

Outputs spaces up to the given \q{<column>}.  If the current column is
already >= \q{<column>}, does nothing.

\subsubsection*{(tab-to [<tab-width>])}

Outputs spaces up to the next tab stop, using tab stops of width
\q{<tab-width>}, which defaults to 8.  If already on a tab stop, does
nothing.  If you want to ensure you always tab at least one space, you
can use \q{(cat " " (tab-to width))}.

\subsubsection*{fmt-null}

Outputs nothing (useful in combinators and as a default noop in
conditionals).


\subsection{Concatenation}

\subsubsection*{(cat <format> ...)}

Concatenates the output of each \q{<format>}.

\subsubsection*{(apply-cat <list>)}

Equivalent to \q{(apply cat <list>)} but may be more efficient.

\subsubsection*{(fmt-join <formatter> <list> [<sep>])}

Formats each element \q{<elt>} of \q{<list>} with \q{(<formatter>
<elt>)}, inserting \q{<sep>} in between.  \q{<sep>} defaults to the
empty string, but can be any format.

  \q{(fmt #f (fmt-join dsp '(a b c) ", "))}

  \q{=> "a, b, c"}

\subsubsection*{(fmt-join/prefix <formatter> <list> [<sep>])}
\subsubsection*{(fmt-join/suffix <formatter> <list> [<sep>])}

  \q{(fmt #f (fmt-join/prefix dsp '(usr local bin) "/"))}

  \q{=> "/usr/local/bin"}

As \q{fmt-join}, but inserts \q{<sep>} before/after every element.

\subsubsection*{(fmt-join/last <formatter> <last-formatter> <list> [<sep>])}

As \q{fmt-join}, but the last element of the list is formatted with
\q{<last-formatter>} instead.

\subsubsection*{(fmt-join/dot <formatter> <dot-formatter> <list> [<sep>])}

As \q{fmt-join}, but if the list is a dotted list, then formats the dotted
value with \q{<dot-formatter>} instead.


\subsection{Padding and Trimming}

\subsubsection*{(pad <width> <format> ...)}
\subsubsection*{(pad/left <width> <format> ...)}
\subsubsection*{(pad/both <width> <format> ...)}

Analogs of SRFI-13 \q{string-pad}, these add extra space to the left,
right or both sides of the output generated by the \q{<format>}s to
pad it to \q{<width>}.  If \q{<width>} is exceeded has no effect.
\q{pad/both} will include an extra space on the right side of the
output if the difference is odd.

\q{pad} does not accumulate any intermediate data.

Note these are column-oriented padders, so won't necessarily work
with multi-line output (padding doesn't seem a likely operation for
multi-line output).

\subsubsection*{(trim <width> <format> ...)}
\subsubsection*{(trim/left <width> <format> ...)}
\subsubsection*{(trim/both <width> <format> ...)}

Analogs of SRFI-13 \q{string-trim}, truncates the output of the
\q{<format>}s to force it in under \q{<width>} columns.  As soon as
any of the \q{<format>}s exceed \q{<width>}, stop formatting and
truncate the result, returning control to whoever called \q{trim}.  If
\q{<width>} is not exceeded has no effect.

If a truncation ellipse is set (e.g. with the \q{ellipses} procedure
below), then when any truncation occurs \q{trim} and \q{trim/left}
will append and prepend the ellipse, respectively.  \q{trim/both} will
both prepend and append.  The length of the ellipse will be considered
when truncating the original string, so that the total width will
never be longer than \q{<width>}.

 \q{(fmt #f (ellipses "..." (trim 5 "abcde")))}

 \q{=>  "abcde"}

 \q{(fmt #f (ellipses "..." (trim 5 "abcdef")))}

 \q{=>  "ab..."}

\subsubsection*{(trim/length <width> <format> ...)}

A variant of \q{trim} which acts on the actual character count rather
than columns, useful for truncating potentially cyclic data.

\subsubsection*{(fit <width> <format> ...)}
\subsubsection*{(fit/left <width> <format> ...)}
\subsubsection*{(fit/both <width> <format> ...)}

A combination of \q{pad} and \q{trunc}, ensures the output width is
exactly \q{<width>}, truncating if it goes over and padding if it goes
under.


\subsection{Format Variables}

You may have noticed many of the formatters are aware of the current
column.  This is because each combinator is actually a procedure of
one argument, the current format state, which holds basic
information such as the row, column, and any other information that
a format combinator may want to keep track of.  The basic interface
is:

\subsubsection*{(fmt-let <name> <value> <format> ...)}
\subsubsection*{(fmt-bind <name> <value> <format> ...)}

\q{fmt-let} sets the name for the duration of the \q{<format>}s, and
restores it on return.  \q{fmt-bind} sets it without restoring it.

A convenience control structure can be useful in combination with
these states:

\subsubsection*{(fmt-if <pred> <pass> [<fail>])}

\q{<pred>} takes one argument (the format state) and returns a boolean
result.  If true, the \q{<pass>} format is applied to the state,
otherwise \q{<fail>} (defaulting to the identity) is applied.

Many of the previously mentioned combinators have behavior which can
be altered with state variables.  Although \q{fmt-let} and \q{fmt-bind}
could be used, these common variables have shortcuts:

\subsubsection*{(radix <k> <format> ...)}
\subsubsection*{(fix <k> <format> ...)}

These alter the radix and fixed point precision of numbers output with
\q{dsp}, \q{wrt}, \q{pretty} or \q{num}.  These settings apply
recursively to all output data structures, so that

  \q{(fmt #f (radix 16 '(70 80 90)))}

will return the string \q{"(#x46 #x50 #x5a)"}.  Note that read/write
invariance is essential, so for \q{dsp}, \q{wrt} and \q{pretty} the
radix prefix is always included when not decimal.  Use \q{num} if you
want to format numbers in alternate bases without this prefix.  For
example,

  \q{(fmt #f (radix 16 "(" (fmt-join num '(70 80 90) " ") ")"))}

would return \q{"(46 50 5a)"}, the same output as above without the
"#x" radix prefix.

Note that fixed point formatting supports arbitrary precision in
implementations with exact non-integral rationals.  When trying to
print inexact numbers more than the machine precision you will
typically get results like

  \q{(fmt #f (fix 30 #i2/3))}

  \q{=> "0.666666666666666600000000000000"}

but with an exact rational it will give you as many digits as you
request:

  \q{(fmt #f (fix 30 2/3))}

  \q{=> "0.666666666666666666666666666667"}

\subsubsection*{(decimal-align <k> <format> ...)}

Specifies an alignment for the decimal place when formatting numbers,
useful for outputting tables of numbers.

\q{
  (define (print-angles x)
     (fmt-join num (list x (sin x) (cos x) (tan x)) " "))

  (fmt #t (decimal-align 5 (fix 3 (fmt-join/suffix print-angles (iota 5) nl))))
}

would output

\p{
   0.000    0.000    1.000    0.000
   1.000    0.842    0.540    1.557
   2.000    0.909   -0.416   -2.185
   3.000    0.141   -0.990   -0.142
   4.000   -0.757   -0.654    1.158
}

\subsubsection*{(comma-char <k> <format> ...)}
\subsubsection*{(decimal-char <k> <format> ...)}

\q{comma-char} and \q{decimal-char} set the defaults for number
formatting.

\subsubsection*{(pad-char <k> <format> ...)}

The \q{pad-char} sets the character used by \q{space-to}, \q{tab-to},
\q{pad/*}, and \q{fit/*}, and defaults to \q{#\space}.

\q{
  (define (print-table-of-contents alist)
    (define (print-line x)
      (cat (car x) (space-to 72) (pad/left 3 (cdr x))))
    (fmt #t (pad-char #\. (fmt-join/suffix print-line alist nl))))

  (print-table-of-contents
   '(("An Unexpected Party" . 29)
     ("Roast Mutton" . 60)
     ("A Short Rest" . 87)
     ("Over Hill and Under Hill" . 100)
     ("Riddles in the Dark" . 115)))
}

would output

\p{
  An Unexpected Party.....................................................29
  Roast Mutton............................................................60
  A Short Rest............................................................87
  Over Hill and Under Hill...............................................100
  Riddles in the Dark....................................................115
}

\subsubsection*{(ellipse <ell> <format> ...)}

Sets the truncation ellipse to \q{<ell>}, would should be a string or
character.

\subsubsection*{(with-width <width> <format> ...)}

Sets the maximum column width used by some formatters.  The default
is 78.


\subsection{Columnar Formatting}

Although \q{tab-to}, \q{space-to} and padding can be used to manually
align columns to produce table-like output, these can be awkward to
use.  The optional extensions in this section make this easier.

\subsubsection*{(columnar <column> ...)}

Formats each \q{<column>} side-by-side, i.e. as though each were
formatted separately and then the individual lines concatenated
together.  The current column width is divided evenly among the
columns, and all but the last column are right-padded.  For example

  \q{(fmt #t (columnar (dsp "abc\\ndef\\n") (dsp "123\\n456\\n")))}

outputs

\p{
     abc     123
     def     456
}

assuming a 16-char width (the left side gets half the width, or 8
spaces, and is left aligned).  Note that we explicitly use DSP instead
of the strings directly.  This is because \q{columnar} treats raw
strings as literals inserted into the given location on every line, to
be used as borders, for example:

\q{
  (fmt #t (columnar "/* " (dsp "abc\\ndef\\n")
                    " | " (dsp "123\\n456\\n")
                    " */"))
}

would output

\p{
  /* abc | 123 */
  /* def | 456 */
}

You may also prefix any column with any of the symbols \q{'left},
\q{'right} or \q{'center} to control the justification.  The symbol
\q{'infinite} can be used to indicate the column generates an infinite
stream of output.

You can further prefix any column with a width modifier.  Any
positive integer is treated as a fixed width, ignoring the available
width.  Any real number between 0 and 1 indicates a fraction of the
available width (after subtracting out any fixed widths).  Columns
with unspecified width divide up the remaining width evenly.

Note that \q{columnar} builds its output incrementally, interleaving
calls to the generators until each has produced a line, then
concatenating that line together and outputting it.  This is important
because as noted above, some columns may produce an infinite stream of
output, and in general you may want to format data larger than can fit
into memory.  Thus columnar would be suitable for line numbering a
file of arbitrary size, or implementing the Unix \q{yes(1)} command,
etc.

As an implementation detail, \q{columnar} uses first-class
continuations to interleave the column output.  The core \q{fmt}
itself has no knowledge of or special support for \q{columnar}, which
could complicate and potentially slow down simpler \q{fmt} operations.
This is a testament to the power of \q{call/cc} - it can be used to
implement coroutines or arbitrary control structures even where they
were not planned for.

\subsubsection*{(tabular <column> ...)}

Equivalent to \q{columnar} except that each column is padded at least
to the minimum width required on any of its lines.  Thus

  \q{(fmt #t (tabular "|" (dsp "a\\nbc\\ndef\\n") "|" (dsp "123\\n45\\n6\\n") "|"))}

outputs

\p{
|a  |123|
|bc |45 |
|def|6  |
}

This makes it easier to generate tables without knowing widths in
advance.  However, because it requires generating the entire output in
advance to determine the correct column widths, \q{tabular} cannot
format a table larger than would fit in memory.

\subsubsection*{(fmt-columns <column> ...)}

The low-level formatter on which \q{columnar} is based.  Each \q{<column>}
must be a list of 2-3 elements:

  \q{(<line-formatter> <line-generator> [<infinite?>])}

where \q{<line-generator>} is the column generator as above, and the
\q{<line-formatter>} is how each line is formatted.  Raw concatenation
of each line is performed, without any spacing or width adjustment.
\q{<infinite?>}, if true, indicates this generator produces an
infinite number of lines and termination should be determined without
it.

\subsubsection*{(wrap-lines <format> ...)}

Behaves like \q{cat}, except text is accumulated and lines are optimally
wrapped to fit in the current width as in the Unix \p{fmt(1)} command.

\subsubsection*{(justify <format> ...)}

Like \q{wrap-lines} except the lines are full-justified.

\q{
  (define func
    '(define (fold kons knil ls)
       (let lp ((ls ls) (acc knil))
         (if (null? ls) acc (lp (cdr ls) (kons (car ls) acc))))))

  (define doc
    (string-append
      "The fundamental list iterator.  Applies KONS to each element "
      "of LS and the result of the previous application, beginning "
      "with KNIL.  With KONS as CONS and KNIL as '(), equivalent to REVERSE."))

  (fmt #t (columnar (pretty func) " ; " (justify doc)))
}

outputs

\p{
  (define (fold kons knil ls)          ; The   fundamental   list   iterator.
    (let lp ((ls ls) (acc knil))       ; Applies  KONS  to  each  element  of
      (if (null? ls)                   ; LS  and  the  result of the previous
          acc                          ; application,  beginning  with  KNIL.
          (lp (cdr ls)                 ; With  KONS  as CONS and KNIL as '(),
              (kons (car ls) acc)))))  ; equivalent to REVERSE.
}

\subsubsection*{(fmt-file <pathname>)}

Simply displayes the contents of the file \q{<pathname>} a line at a
time, so that in typical formatters such as \q{columnar} only constant
memory is consumed, making this suitable for formatting files of
arbitrary size.

\subsubsection*{(line-numbers [<start>])}

A convenience utility, just formats an infinite stream of numbers (in
the current radix) beginning with \q{<start>}, which defaults to \q{1}.

The Unix \q{nl(1)} utility could be implemented as:

\q{
  (fmt #t (columnar 6 'right 'infinite (line-numbers)
                    " " (fmt-file "read-line.scm")))
}

\p{
     1 
     2 (define (read-line . o)
     3   (let ((port (if (pair? o) (car o) (current-input-port))))
     4     (let lp ((res '()))
     5       (let ((c (read-char port)))
     6         (if (or (eof-object? c) (eqv? c #\newline))
     7             (list->string (reverse res))
     8             (lp (cons c res)))))))
}

\section{C Formatting}

\subsection{C Formatting Basics}

For purposes such as writing wrappers, code-generators, compilers or
other language tools, people often need to generate or emit C code.
Without a decent library framework it's difficult to maintain proper
indentation.  In addition, for the Scheme programmer it's tedious to
work with all the context sensitivities of C, such as the expression
vs. statement distinction, special rules for writing preprocessor
macros, and when precedence rules require parenthesis.  Fortunately,
context is one thing this formatting library is good at keeping
track of.  The C formatting interface tries to make it as easy as
possible to generate C code without getting in your way.

There are two approaches to using the C formatting extensions -
procedural and sexp-oriented (described in \ref{csexprs}).  In the
procedural interface, C operators are made available as formatters
with a "c-" prefix, literals are converted to their C equivalents and
symbols are output as-is (you're responsible for making sure they are
valid C identifiers).  Indentation is handled automatically.

  \q{(fmt #t (c-if 1 2 3))}

outputs

\p{
  if (1) {
      2;
  } else {
      3;
  }
}

In addition, the formatter knows when you're in an expression and
when you're in a statement, and behaves accordingly, so that

  \q{(fmt #t (c-if (c-if 1 2 3) 4 5))}

outputs

\p{
  if (1 ? 2 : 3) {
      4;
  } else {
      5;
  }
}

Similary, \q{c-begin}, used for sequencing, will separate with
semi-colons in a statement and commas in an expression.

Moreover, we also keep track of the final expression in a function
and insert returns for you:

  \q{(fmt #t (c-fun 'int 'foo '() (c-if (c-if 1 2 3) 4 5)))}

outputs

\p{
  int foo () {
      if (1 ? 2 : 3) {
          return 4;
      } else {
          return 5;
      }
  }
}

although it knows that void functions don't return.

Switch statements insert breaks by default if they don't return:

\q{
  (fmt #t (c-switch 'y
            (c-case 1 (c+= 'x 1))
            (c-default (c+= 'x 2))))
}

\p{
  switch (y) {
      case 1:
          x += 1;
          break;
      default:
          x += 2;
          break;
  }
}

though you can explicitly fallthrough if you want:

\q{
  (fmt #t (c-switch 'y
            (c-case/fallthrough 1 (c+= 'x 1))
            (c-default (c+= 'x 2))))
}

\p{
  switch (y) {
      case 1:
          x += 1;
      default:
          x += 2;
          break;
  }
}

Operators are available with just a "c" prefix, e.g. c+, c-, c*, c/,
etc.  \q{c++} is a prefix operator, \q{c++/post} is postfix.  ||, | and
|= are written as \q{c-or}, \q{c-bit-or} and \q{c-bit-or=} respectively.

Function applications are written with \q{c-apply}.  Other control
structures such as \q{c-for} and \q{c-while} work as expected.  The full
list is in the procedure index below.

When a C formatter encounters an object it doesn't know how to write
(including lists and records), it outputs them according to the
format state's current \q{'gen} variable.  This allows you to specify
generators for your own types, e.g. if you are using your own AST
records in a compiler.

If the \q{'gen} variable isn't set it defaults to the \q{c-expr/sexp}
procedure, which formats an s-expression as if it were C code.  Thus
instead of \q{c-apply} you can just use a list.  The full API is
available via normal s-expressions - formatters that aren't keywords
in C are prefixed with a % or otherwise made invalid C identifiers so
that they can't be confused with function application.


\subsection{C Preprocessor Formatting}

C preprocessor formatters also properly handle their surrounding
context, so you can safely intermix them in the normal flow of C
code.

\q{
  (fmt #t (c-switch 'y
            (c-case 1 (c= 'x 1))
            (cpp-ifdef 'H_TWO (c-case 2 (c= 'x 4)))
            (c-default (c= 'x 5))))
}

\p{
  switch (y) {
      case 1:
          x = 1;
          break;

  #ifdef H_TWO
      case 2:
          x = 4;
          break;
  #endif /* H_TWO */
      default:
          x = 5;
          break;
  }
}

Macros can be handled with \q{cpp-define}, which knows to wrap
individual variable references in parenthesis:

  \q{(fmt #t (cpp-define '(min x y) (c-if (c< 'x 'y) 'x 'y)))}

\p{
  #define min(x, y) (((x) < (y)) ? (x) : (y))
}

As with all C formatters, the CPP output is pretty printed as
needed, and if it wraps over several lines the lines are terminated
with a backslash.

To write a C header file that is included at most once, you can wrap
the entire body in \q{cpp-wrap-header}:

\q{
  (fmt #t (cpp-wrap-header "FOO_H"
            (c-extern (c-prototype 'int 'foo '()))))
}

\p{
  #ifndef FOO_H
  #define FOO_H

  extern int foo ();

  #endif /* ! FOO_H */
}


\subsection{Customizing C Style}

The output uses a simplified K&R style with 4 spaces for indentation
by default.  The following state variables let you override the
style:

\subsubsection*{'indent-space}

how many spaces to indent bodies, default \q{4}

\subsubsection*{'switch-indent-space}

how many spaces to indent switch clauses, also defaults to \q{4}

\subsubsection*{'newline-before-brace?}

insert a newline before an open brace (non-K&R), defaults  to \q{#f}

\subsubsection*{'braceless-bodies?}

omit braces when we can prove they aren't needed

\subsubsection*{'non-spaced-ops?}

omit spaces between operators and operands for groups of variables and
literals (e.g. "a+b+3" instead of "a + b + 3"}

\subsubsection*{'no-wrap?}

Don't wrap function calls and long operator groups over mulitple
lines.  Functions and control structures will still use multiple
lines.

The C formatters also respect the \q{'radix} and \q{'precision} settings.


\subsection{C Formatter Index}

\subsubsection*{(c-if <condition> <pass> [<fail> [<condition2> <pass2> ...]])}

Print a chain of if/else conditions.  Use a final condition of \q{'else}
for a final else clause.

\subsubsection*{(c-for <init> <condition> <update> <body> ...)}
\subsubsection*{(c-while <condition> <body> ...)}

Basic loop constructs.

\subsubsection*{(c-fun <type> <name> <params> <body> ...)}
\subsubsection*{(c-prototype <type> <name> <params>)}

Output a function or function prototype.  The parameters should be a
list 2-element lists of the form \q{(<param-type> <param-name>)},
which are output with DSP.  A parameter can be abbreviated as just the
symbol name, or \q{#f} can be passed as the type, in which case the
\q{'default-type} state variable is used.  The parameters may be a
dotted list, in which case ellipses for a C variadic are inserted -
the actual name of the dotted value is ignored.

Types are just typically just symbols, or lists of symbols such as
\q{'(const char)}.  A complete description is given below in section
\ref{ctypes}.

These can also accessed as %fun and %prototype at the head of a list.

\subsubsection*{(c-var <type> <name> [<init-value>])}

Declares and optionally initializes a variable.  Also accessed as %var
at the head of a list.

\subsubsection*{(c-begin <expr> ...)}

Outputs each of the <expr>s, separated by semi-colons if in a
statement or commas if in an expression.

\subsubsection*{(c-switch <clause> ...)}
\subsubsection*{(c-case <values> <body> ...)}
\subsubsection*{(c-case/fallthrough <values> <body> ...)}
\subsubsection*{(c-default <body> ...)}

Switch statements.  In addition to using the clause formatters,
clauses inside a switch may be handled with a Scheme CASE-like list,
with the car a list of case values and the cdr the body.

\subsubsection*{(c-label <name>)}
\subsubsection*{(c-goto <name>)}
\subsubsection*{(c-return [<result>])}
\subsubsection*{c-break}
\subsubsection*{c-continue}

Manual labels and jumps.  Labels can also be accessed as a list
beginning with a colon, e.g. \q{'(: label1)}.

\subsubsection*{(c-const <expr>)}
\subsubsection*{(c-static <expr>)}
\subsubsection*{(c-volatile <expr>)}
\subsubsection*{(c-restrict <expr>)}
\subsubsection*{(c-register <expr>)}
\subsubsection*{(c-auto <expr>)}
\subsubsection*{(c-inline <expr>)}
\subsubsection*{(c-extern <expr>)}

Declaration modifiers.  May be nested.

\subsubsection*{(c-extern/C <body> ...)}

Wraps body in an extern "C" { ... } for use with C++.

\subsubsection*{(c-cast <type> <expr>)}

Casts an expression to a type.  Also %cast at the head of a list.

\subsubsection*{(c-typedef <type> <new-name> ...)}

Creates a new type definition with one or more names.

\subsubsection*{(c-struct [<name>] <field-list> [<attributes>])}
\subsubsection*{(c-union [<name>] <field-list> [<attributes>])}
\subsubsection*{(c-class [<name>] <field-list> [<attributes>])}
\subsubsection*{(c-attribute <values> ...)}

Composite type constructors.  Attributes may be accessed as
%attribute at the head of a list.

\q{
  (fmt #f (c-struct 'employee
                      '((short age)
                        ((char *) name)
                        ((struct (year month day)) dob))
                      (c-attribute 'packed)))
}

\p{
  struct employee {
      short age;
      char* name;
      struct {
          int year;
          int month;
          int day;
      } dob;
  } __attribute__ ((packed));
}

\subsubsection*{(c-enum [<name>] <enum-list>)}

Enumerated types.  \q{<enum-list>} may be strings, symbols, or lists of
string or symbol followed by the enum's value.

\subsubsection*{(c-comment <formatter> ...)}

Outputs the \q{<formatter>}s wrapped in C's /* ... */ comment.  Properly
escapes nested comments inside in an Emacs-friendly style.

\subsection{C Preprocessor Formatter Index}

\subsubsection*{(cpp-include <file>)}

If file is a string, outputs in it "quotes", otherwise (as a symbol
or arbitrary formatter) it outputs it in brackets.

  \q{(fmt #f (cpp-include 'stdio.h))}

  \q{=> "#include <stdio.h>\n"}

  \q{(fmt #f (cpp-include "config.h"))}

  \q{=> "#include \"config.h\"\n"}

\subsubsection*{(cpp-define <macro> [<value>])}

Defines a preprocessor macro, which may be just a name or a list of
name and parameters.  Properly wraps the value in parenthesis and
escapes newlines.  A dotted parameter list will use the C99 variadic
macro syntax, and will also substitute any references to the dotted
name with \p{__VA_ARGS__}:

  \q{(fmt #t (cpp-define '(eprintf . args) '(fprintf stderr args)))}

\p{
  #define eprintf(...) (fprintf(stderr, __VA_ARGS__))
}

\subsubsection*{(cpp-if <condition> <pass> [<fail> ...])}
\subsubsection*{(cpp-ifdef <condition> <pass> [<fail> ...])}
\subsubsection*{(cpp-ifndef <condition> <pass> [<fail> ...])}
\subsubsection*{(cpp-elif <condition> <pass> [<fail> ...])}
\subsubsection*{(cpp-else <body> ...)}

Conditional compilation.

\subsubsection*{(cpp-line <num> [<file>])}

Line number information.

\subsubsection*{(cpp-pragma <args> ...)}
\subsubsection*{(cpp-error <args> ...)}
\subsubsection*{(cpp-warning <args> ...)}

Additional preprocessor directives.

\subsubsection*{(cpp-stringify <expr>)}

Stringifies \q{<expr>} by prefixing the # operator.

\subsubsection*{(cpp-sym-cat <args> ...)}

Joins the \q{<args>} into a single preprocessor token with the ##
operator.

\subsubsection*{(cpp-wrap-header <name> <body> ...)}

Wrap an entire header to only be included once.

\subsubsection*{Operators:}

\q{
c++ c-- c+ c- c* c/ c% c& c^ c~ c! c&& c<< c>> c== c!=
c< c> c<= c>= c= c+= c-= c*= c/= c%= c&= c^= c<<= c>>=
c++/post c--/post c-or c-bit-or c-bit-or=
}

\subsection{C Types}
\label{ctypes}

Typically a type is just a symbol such as \q{'char} or \q{'int}.  You
can wrap types with modifiers such as \q{c-const}, but as a
convenience you can just use a list such as in \q{'(const unsignedchar *)}.
You can also nest these lists, so the previous example is
equivalent to \q{'(* (const (unsigned char)))}.

Pointers may be written as \q{'(%pointer <type>)} for readability -
\q{%pointer} is exactly equivalent to \q{*} in types.

Unamed structs, classes, unions and enums may be used directly as
types, using their respective keywords at the head of a list.

Two special types are the %array type and function pointer type.  An
array is written:

  \q{(%array <type> [<size>])}

where \q{<type>} is any other type (including another array or
function pointer), and \q{<size>}, if given, will print the array
size.  For example:

  \q{(c-var '(%array (unsigned long) SIZE) 'table '#(1 2 3 4))}

\p{
unsigned long table[SIZE] = {1, 2, 3, 4};
}

A function pointer is written:

  \q{(%fun <return-type> (<param-types> ...))}

For example:

  \q{(c-typedef '(%fun double (double double int)) 'f)}

\p{
typedef double (*f)(double, double, int);
}

Wherever a type is expected but not given, the value of the
\q{'default-type} formatting state variable is used.  By default this
is just \q{'int}.

Type declarations work uniformly for variables and parameters, as well
for casts and typedefs.

\subsection{C as S-Expressions}
\label{csexprs}

Rather than building formatting closures by hand, it can be more
convenient to just build a normal s-expression and ask for it to be
formatted as C code.  This can be thought of as a simple Scheme->C
compiler without any runtime support.

In a s-expression, strings and characters are printed as C strings and
characters, booleans are printed as 0 or 1, symbols are displayed
as-is, and numbers are printed as C numbers (using the current
formatting radix if specified).  Vectors are printed as
comma-separated lists wrapped in braces, which can be used for
initializing arrays or structs.

A list indicates a C expression or statement.  Any of the existing C
keywords can be used to pretty-print the expression as described with
the c-keyword formatters above.  Thus, the example above

  \q{(fmt #t (c-if (c-if 1 2 3) 4 5))}

could also be written

  \q{(fmt #t (c-expr '(if (if 1 2 3) 4 5)))}

C constructs that are dependent on the underlying syntax and have no
keyword are written with a % prefix (\q{%fun}, \q{%var}, \q{%pointer},
\q{%array}, \q{%cast}), including C preprocessor constructs
(\q{%include}, \q{%define}, \q{%pragma}, \q{%error}, \q{%warning},
\q{%if}, \q{%ifdef}, \q{%ifndef}, \q{%elif}).  Labels are written as
\q{(: <label-name>)}.  You can write a sequence as \q{(%begin <expr>
...)}.

For example, the following definition of the fibonacci sequence, which
apart from the return type of \q{#f} looks like a Lisp definition:

  \q{(fmt #t (c-expr '(%fun #f fib (n)
                         (if (<= n 1)
                             1
                             (+ (fib (- n 1)) (fib (- n 2)))))))}

prints the working C definition:

\p{
int fib (int n) {
    if (n <= 1) {
        return 1;
    } else {
        return fib((n - 1)) + fib((n - 2));
    }
}
}

\section{JavaScript Formatting}

The experimental fmt-js library extends the fmt-c library with
functionality for formatting JavaScript code.

\subsubsection*{(js-expr x)}

Formats a JavaScript expression similarly to \q{c-expr}.  Inside a
\q{js-expr} formatter, you can use the normal \q{c-} prefixed
formatters described in the previous section, and they will format
appropriately for JavaScript.

Currently expressions will all be terminated with a semi-colon, but
that will be made optional in a later release.

\subsubsection*{(js-function [<name>] (<params>) <body> ...)}

Defines a function (anonymously if no name is provided).

\subsubsection*{(js-var <name> [<init-value>])}

Declares a JavaScript variable, optionally with an initial value.

\subsubsection*{(js-comment <formatter> ...)}

Formats a comment prefixing lines with \q{"// "}.

\section{Formatting with Color}

The fmt-color library provides the following utilities:

\q{
  (fmt-red <formatter> ...)
  (fmt-blue <formatter> ...)
  (fmt-green <formatter> ...)
  (fmt-cyan <formatter> ...)
  (fmt-yellow <formatter> ...)
  (fmt-magenta <formatter> ...)
  (fmt-white <formatter> ...)
  (fmt-black <formatter> ...)
  (fmt-bold <formatter> ...)
  (fmt-underline <formatter> ...)
}

and more generally

  \q{(fmt-color <color> <formatter> ...)}

where color can be a symbol name or \q{#xRRGGBB} numeric value.
Outputs the formatters colored with ANSI escapes.  In addition

  \q{(fmt-in-html <formatter> ...)}

can be used to mark the format state as being inside HTML, which the
above color formats will understand and output HTML \q{<span>} tags with
the appropriate style colors, instead of ANSI escapes.


\section{Unicode}

The fmt-unicode library provides the \q{fmt-unicode} formatter, which
just takes a list of formatters and overrides the string-length for
padding and trimming, such that Unicode double or full width
characters are considered 2 characters wide (as they typically are in
fixed-width terminals), while treating combining and non-spacing
characters as 0 characters wide.

It also recognizes and ignores ANSI escapes, in particular useful if
you want to combine this with the fmt-color utilities.


\section{Optimizing}

The library is designed for scalability and flexibility, not speed,
and I'm not going to think about any fine tuning until it's more
stabilised.  One aspect of the design, however, was influenced for the
sake of future optimizations, which is that none of the default format
variables are initialized by global parameters, which leaves room for
inlining and subsequent simplification of format calls.

If you don't have an aggressively optimizing compiler, you can easily
achieve large speedups on common cases with CL-style compiler macros.

\section{Common Lisp Format Cheat Sheet}

A quick reference for those of you switching over from Common Lisp's
format.

\table{
\b{format} | \b{fmt}
~a | \q{dsp}
~c | \q{dsp}
~s | \q{wrt/unshared}
~w | \q{wrt}
~y | \q{pretty}
~x | \q{(radix 16 ...)} or \q{(num <n> 16)}
~o | \q{(radix 8 ...)} or \q{(num <n> 8)}
~b | \q{(radix 2 ...)} or \q{(num <n> 2)}
~f | \q{(fix <digits> ...)} or \q{(num <n> <radix> <digits>)}
~% | \q{nl}
~& | \q{fl}
~[...~] | normal \q{if} or \q{fmt-if} (delayed test)
~{...~} | \q{(fmt-join ... <list> [<sep>])}
}

\section{References}

\bibitem{R5RS} R. Kelsey, W. Clinger, J. Rees (eds.)
\urlh{http://www.schemers.org/Documents/Standards/R5RS/}{Revised^5 Report on the Algorithmic Language Scheme}

\bibitem{CommonLisp} Guy L. Steele Jr. (editor)
\urlh{http://www.harlequin.com/education/books/HyperSpec/}{Common Lisp Hyperspec}

\bibitem{SRFI-28} Scott G. Miller
\urlh{http://srfi.schemers.org/srfi-28/}{SRFI-28 Basic Format Strings}

\bibitem{SRFI-48} Ken Dickey
\urlh{http://srfi.schemers.org/srfi-48/}{SRFI-48 Intermediate Format Strings}

\bibitem{SRFI-38} Ray Dillinger
\urlh{http://srfi.schemers.org/srfi-38/}{SRFI-38 External Representation for Data With Shared Structure}

\bibitem{Perl6} Damian Conway
\urlh{http://www.perl.com/lpt/a/819}{Perl6 Exegesis 7 - formatting}

\eval(display "<br /><br /><br /><br />\n")

<html><head><title>Combinator Formatting</title>
</head><body bgcolor=white>

<h1><span class=subject>Combinator Formatting</span></h1>

<style>
body {
color: black;
background-color: white;
margin-top: 2em;
margin-left: 10%;
width: 400pt;
}

pre {
  background-color: beige;
}

pre.scheme {
  background-color: white;
}

.subject {
}

h1 {
margin-left: -5%;
margin-top: 2em;
font-size: large;
}

h2 {
margin-left: -4%;
margin-top: 1em;
font-size: large;
}

h3,h4,h5,h6 {
margin-left: -3%;
margin-top: .5em;
font-size: small;
}

.navigation {
color: red;
background-color: beige;
text-align: right;
font-style: italic;
}


.scheme {
color: brown;
}

.scheme .keyword {
color: #cc0000;
font-weight: bold;
}

.scheme .variable {
color: navy;
}

.scheme .global {
color: purple;
}

.scheme .constant,.number,.char,.string,.boolean {
color: green;
}

.scheme .comment {
color: teal;
}
</style>
<div align=right><a href="http://synthcode.com/">Alex Shinn</a></div>
<div align=right><a href="http://synthcode.com/scheme/fmt/fmt-0.8.4.tar.gz">Download Version 0.8.4</a></div>
<p>

<br /><br />

A library of procedures for formatting Scheme objects to text in
various ways, and for easily concatenating, composing and extending
these formatters efficiently without resorting to capturing and
manipulating intermediate strings.
<p>

<br /><br />

<a name="SECTION_1"><h1>1&nbsp;&nbsp;Table of Contents</h1>



<ol>
<li><a href="#SECTION_1">Table of Contents</a>
<li><a href="#SECTION_2">Installation</a>
<li><a href="#SECTION_3">Background</a>
<li><a href="#SECTION_4">Usage</a>
<li><a href="#SECTION_5">Specification</a>
<ol>
<li><a href="#SECTION_5.1">Formatting Objects</a>
<li><a href="#SECTION_5.2">Formatting Numbers</a>
<li><a href="#SECTION_5.3">Formatting Space</a>
<li><a href="#SECTION_5.4">Concatenation</a>
<li><a href="#SECTION_5.5">Padding and Trimming</a>
<li><a href="#SECTION_5.6">Format Variables</a>
<li><a href="#SECTION_5.7">Columnar Formatting</a>
</ol>
<li><a href="#SECTION_6">C Formatting</a>
<ol>
<li><a href="#SECTION_6.1">C Formatting Basics</a>
<li><a href="#SECTION_6.2">C Preprocessor Formatting</a>
<li><a href="#SECTION_6.3">Customizing C Style</a>
<li><a href="#SECTION_6.4">C Formatter Index</a>
<li><a href="#SECTION_6.5">C Preprocessor Formatter Index</a>
<li><a href="#SECTION_6.6">C Types</a>
<li><a href="#SECTION_6.7">C as S-Expressions</a>
</ol>
<li><a href="#SECTION_7">JavaScript Formatting</a>
<li><a href="#SECTION_8">Formatting with Color</a>
<li><a href="#SECTION_9">Unicode</a>
<li><a href="#SECTION_10">Optimizing</a>
<li><a href="#SECTION_11">Common Lisp Format Cheat Sheet</a>
<li><a href="#SECTION_12">References</a>
</ol>

<br /><br />

<a name="SECTION_2"><h1>2&nbsp;&nbsp;Installation</h1>

Available for Chicken as the <code>fmt</code> egg, providing the <code class=scheme><span class=variable>fmt</span></code>,
<code class=scheme><span class=variable>fmt-c</span></code>, <code class=scheme><span class=variable>fmt-color</span></code> and <code class=scheme><span class=variable>fmt-unicode</span></code> extensions.  To install
manually for Chicken just run <code>&quot;chicken-setup&quot;</code> in the fmt
directory.
<p>

For Gauche run <code>&quot;make gauche &amp;&amp; make install-gauche&quot;</code>.  The modules
are installed as <code class=scheme><span class=variable>text.fmt</span></code>, <code class=scheme><span class=variable>text.fmt.c</span></code>, <code class=scheme><span class=variable>text.fmt.color</span></code> and
<code class=scheme><span class=variable>text.fmt.unicode</span></code>.
<p>

For MzScheme you can download and install the latest <code>fmt.plt</code> yourself
from:
<p>

<a href="http://synthcode.com/scheme/fmt/fmt.plt">http://synthcode.com/scheme/fmt/fmt.plt</a>
<p>

To build the <code>fmt.plt</code> for yourself you can run <code>&quot;make mzscheme&quot;</code>.
<p>

For Scheme48 the package descriptions are in <code>fmt-scheme48.scm</code>:
<p>

<pre class=scheme>
<span class=variable>&gt;</span> ,<span class=variable>config</span> ,<span class=variable>load</span> <span class=variable>fmt-scheme48.scm</span>
<span class=variable>&gt;</span> ,<span class=variable>open</span> <span class=variable>fmt</span>
</pre>
<p>

For other implementations you'll need to load SRFI's 1, 6, 13, 33
(sample provided) and 69 (also provided), and then load the following
files:
<p>

<pre class=scheme>
  (<span class=variable>load</span> <span class=string>&quot;let-optionals.scm&quot;</span>)  <span class=comment>; if you don't have LET-OPTIONALS*</span>
  (<span class=variable>load</span> <span class=string>&quot;read-line.scm&quot;</span>)      <span class=comment>; if you don't have READ-LINE</span>
  (<span class=variable>load</span> <span class=string>&quot;string-ports.scm&quot;</span>)   <span class=comment>; if you don't have CALL-WITH-OUTPUT-STRING</span>
  (<span class=variable>load</span> <span class=string>&quot;make-eq-table.scm&quot;</span>)
  (<span class=variable>load</span> <span class=string>&quot;mantissa.scm&quot;</span>)
  (<span class=variable>load</span> <span class=string>&quot;fmt.scm&quot;</span>)
  (<span class=variable>load</span> <span class=string>&quot;fmt-pretty.scm&quot;</span>)     <span class=comment>; optional pretty printing</span>
  (<span class=variable>load</span> <span class=string>&quot;fmt-column.scm&quot;</span>)     <span class=comment>; optional columnar output</span>
  (<span class=variable>load</span> <span class=string>&quot;fmt-c.scm&quot;</span>)          <span class=comment>; optional C formatting utilities</span>
  (<span class=variable>load</span> <span class=string>&quot;fmt-color.scm&quot;</span>)      <span class=comment>; optional color utilities</span>
  (<span class=variable>load</span> <span class=string>&quot;fmt-unicode.scm&quot;</span>)    <span class=comment>; optional Unicode-aware formatting,</span>
                              <span class=comment>;   also requires SRFI-4 or SRFI-66</span>
</pre>
<p>

<a name="SECTION_3"><h1>3&nbsp;&nbsp;Background</h1>

There are several approaches to text formatting.  Building strings to
<code class=scheme><span class=variable>display</span></code> is not acceptable, since it doesn't scale to very large
output.  The simplest realistic idea, and what people resort to in
typical portable Scheme, is to interleave <code class=scheme><span class=variable>display</span></code> and <code class=scheme><span class=variable>write</span></code>
and manual loops, but this is both extremely verbose and doesn't
compose well.  A simple concept such as padding space can't be
achieved directly without somehow capturing intermediate output.
<p>

The traditional approach is to use templates - typically strings,
though in theory any object could be used and indeed Emacs' mode-line
format templates allow arbitrary sexps.  Templates can use either
escape sequences (as in C's <code class=scheme><span class=variable>printf</span></code> and <a href="#BIBITEM_2">CL's</a>
<code class=scheme><span class=variable>format</span></code>) or pattern matching (as in Visual Basic's <code class=scheme><span class=variable>Format</span></code>,
<a href="#BIBITEM_6">Perl6's</a> <code class=scheme><span class=variable>form</span></code>, and SQL date formats).  The
primary disadvantage of templates is the relative difficulty (usually
impossibility) of extending them, their opaqueness, and the
unreadability that arises with complex formats.  Templates are not
without their advantages, but they are already addressed by other
libraries such as <a href="#BIBITEM_3">SRFI-28</a> and
<a href="#BIBITEM_4">SRFI-48</a>.
<p>

This library takes a combinator approach.  Formats are nested chains
of closures, which are called to produce their output as needed.
The primary goal of this library is to have, first and foremost, a
maximally expressive and extensible formatting library.  The next
most important goal is scalability - to be able to handle
arbitrarily large output and not build intermediate results except
where necessary.  The third goal is brevity and ease of use.
<p>

<a name="SECTION_4"><h1>4&nbsp;&nbsp;Usage</h1>

The primary interface is the <code class=scheme><span class=variable>fmt</span></code> procedure:
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=variable>&lt;output-dest&gt;</span> <span class=variable>&lt;format&gt;</span> ...)</code>
<p>

where <code class=scheme><span class=variable>&lt;output-dest&gt;</span></code> has the same semantics as with <code class=scheme><span class=variable>format</span></code> -
specifically it can be an output-port, <code class=scheme><span class=boolean>#t</span></code> to indicate the current
output port, or <code class=scheme><span class=boolean>#f</span></code> to accumulate output into a string.
<p>

Each <code class=scheme><span class=variable>&lt;format&gt;</span></code> should be a format closure as discussed below.  As a
convenience, non-procedure arguments are also allowed and are
formatted similar to <code class=scheme><span class=variable>display</span></code>, so that
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> <span class=string>&quot;Result: &quot;</span> <span class=variable>res</span> <span class=variable>nl</span>)</code>
<p>

would return the string <code class=scheme><span class=string>&quot;Result: 42n&quot;</span></code>, assuming <code class=scheme><span class=variable>RES</span></code> is bound
to <code class=scheme><span class=number>42</span></code>.
<p>

<code class=scheme><span class=variable>nl</span></code> is the newline format combinator.
<p>

<a name="SECTION_5"><h1>5&nbsp;&nbsp;Specification</h1>

The procedure names have gone through several variations, and I'm
still open to new suggestions.  The current approach is to use
abbreviated forms of standard output procedures when defining an
equivalent format combinator (thus <code class=scheme><span class=variable>display</span></code> becomes <code class=scheme><span class=variable>dsp</span></code> and
<code class=scheme><span class=variable>write</span></code> becomes <code class=scheme><span class=variable>wrt</span></code>), and to use an <code class=scheme><span class=variable>fmt-</span></code> prefix for
utilities and less common combinators.  Variants of the same formatter
get a <code class=scheme><span class=variable>/&lt;variant&gt;</span></code> suffix.
<p>

<a name="SECTION_5.1"><h2>5.1&nbsp;&nbsp;Formatting Objects</h2>

<h3>(dsp &lt;obj&gt;)</h3>

Outputs <code class=scheme><span class=variable>&lt;obj&gt;</span></code> using <code class=scheme><span class=variable>display</span></code> semantics.  Specifically, strings
are output without surrounding quotes or escaping and characters are
written as if by <code class=scheme><span class=variable>write-char</span></code>.  Other objects are written as with
<code class=scheme><span class=variable>write</span></code> (including nested strings and chars inside <code class=scheme><span class=variable>&lt;obj&gt;</span></code>).  This
is the default behavior for top-level formats in <code class=scheme><span class=variable>fmt</span></code>, <code class=scheme><span class=variable>cat</span></code> and
most other higher-order combinators.
<p>

<h3>(wrt &lt;obj&gt;)</h3>

Outputs <code class=scheme><span class=variable>&lt;obj&gt;</span></code> using <code class=scheme><span class=variable>write</span></code> semantics.  Handles shared
structures as in <a href="#BIBITEM_5">SRFI-38</a>.
<p>

<h3>(wrt/unshared &lt;obj&gt;)</h3>

As above, but doesn't handle shared structures.  Infinite loops can
still be avoided if used inside a combinator that truncates data (see
<code class=scheme><span class=variable>trim</span></code> and <code class=scheme><span class=variable>fit</span></code> below).
<p>

<h3>(pretty &lt;obj&gt;)</h3>

Pretty-prints <code class=scheme><span class=variable>&lt;obj&gt;</span></code>.  Also handles shared structures.  Unlike many
other pretty printers, vectors and data lists (lists that don't begin
with a (nested) symbol), are printed in tabular format when there's
room, greatly saving vertical space.
<p>

<h3>(pretty/unshared &lt;obj&gt;)</h3>

As above but without sharing.
<p>

<h3>(slashified &lt;str&gt; [&lt;quote-ch&gt; &lt;esc-ch&gt; &lt;renamer&gt;])</h3>

Outputs the string <code class=scheme><span class=variable>&lt;str&gt;</span></code>, escaping any quote or escape characters.
If <code class=scheme><span class=variable>&lt;esc-ch&gt;</span></code> is <code class=scheme><span class=boolean>#f</span></code> escapes only the <code class=scheme><span class=variable>&lt;quote-ch&gt;</span></code> by
doubling it, as in SQL strings and CSV values.  If <code class=scheme><span class=variable>&lt;renamer&gt;</span></code> is
provided, it should be a procedure of one character which maps that
character to its escape value, e.g. <code class=scheme><span class=char>#\newline</span> <span class=keyword>=&gt;</span> <span class=char>#\n</span></code>, or <code class=scheme><span class=boolean>#f</span></code> if
there is no escape value.
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>slashified</span> <span class=string>&quot;hi, &quot;bob!&quot;&quot;</span>))</code>
<p>

<code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;hi, &quot;bob!&quot;&quot;</span></code>
<p>

<h3>(maybe-slashified &lt;str&gt; &lt;pred&gt; [&lt;quote-ch&gt; &lt;esc-ch&gt; &lt;renamer&gt;])</h3>

Like <code class=scheme><span class=variable>slashified</span></code>, but first checks if any quoting is required (by
the existence of either any quote or escape characters, or any
character matching <code class=scheme><span class=variable>&lt;pred&gt;</span></code>), and if so outputs the string in quotes
and with escapes.  Otherwise outputs the string as is.
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>maybe-slashified</span> <span class=string>&quot;foo&quot;</span> <span class=variable>char-whitespace?</span> <span class=char>#\&quot;</span>))</code>
<p>

<code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;foo&quot;</span></code>
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>maybe-slashified</span> <span class=string>&quot;foo bar&quot;</span> <span class=variable>char-whitespace?</span> <span class=char>#\&quot;</span>))</code>
<p>

<code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;&quot;foo bar&quot;&quot;</span></code>
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>maybe-slashified</span> <span class=string>&quot;foo&quot;bar&quot;baz&quot;</span> <span class=variable>char-whitespace?</span> <span class=char>#\&quot;</span>))</code>
<p>

<code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;&quot;foo&quot;bar&quot;baz&quot;&quot;</span></code>
<p>

<a name="SECTION_5.2"><h2>5.2&nbsp;&nbsp;Formatting Numbers</h2>

<h3>(num &lt;n&gt; [&lt;radix&gt; &lt;precision&gt; &lt;sign&gt; &lt;comma&gt; &lt;comma-sep&gt; &lt;decimal-sep&gt;])</h3>

Formats a single number <code class=scheme><span class=variable>&lt;n&gt;</span></code>.  You can optionally specify any
<code class=scheme><span class=variable>&lt;radix&gt;</span></code> from 2 to 36 (even if <code class=scheme><span class=variable>&lt;n&gt;</span></code> isn't an integer).
<code class=scheme><span class=variable>&lt;precision&gt;</span></code> forces a fixed-point format.
<p>

A <code class=scheme><span class=variable>&lt;sign&gt;</span></code> of <code class=scheme><span class=boolean>#t</span></code> indicates to output a plus sign (+) for positive
integers.  However, if <code class=scheme><span class=variable>&lt;sign&gt;</span></code> is a character, it means to wrap the
number with that character and its mirror opposite if the number is
negative.  For example, <code class=scheme><span class=char>#\(</span></code> prints negative numbers in parenthesis,
financial style: <code class=scheme><span class=number>-3.14</span> <span class=keyword>=&gt;</span> (<span class=number>3.14</span>)</code>
<p>

<code class=scheme><span class=variable>&lt;comma&gt;</span></code> is an integer specifying the number of digits between
commas.  Variable length, as in subcontinental-style, is not yet
supported.
<p>

<code class=scheme><span class=variable>&lt;comma-sep&gt;</span></code> is the character to use for commas, defaulting to <code class=scheme><span class=char>#\,</span></code>.
<p>

<code class=scheme><span class=variable>&lt;decimal-sep&gt;</span></code> is the character to use for decimals, defaulting to
<code class=scheme><span class=char>#\.</span></code>, or to <code class=scheme><span class=char>#\,</span></code> (European style) if <code class=scheme><span class=variable>&lt;comma-sep&gt;</span></code> is already
<code class=scheme><span class=char>#\.</span></code>.
<p>

These parameters may seem unwieldy, but they can also take their
defaults from state variables, described below.
<p>

<h3>(num/comma &lt;n&gt; [&lt;base&gt; &lt;precision&gt; &lt;sign&gt;])</h3>

Shortcut for <code class=scheme><span class=variable>num</span></code> to print with commas.
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>num/comma</span> <span class=number>1234567</span>))</code>
<p>

<code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;1,234,567&quot;</span></code>
<p>

<h3>(num/si &lt;n&gt; [&lt;base&gt; &lt;suffix&gt;])</h3>

Abbreviates <code class=scheme><span class=variable>&lt;n&gt;</span></code> with an SI suffix as in the -h or --si option to
many GNU commands.  The base defaults to 1024, using suffix names
like Ki, Mi, Gi, etc.  Other bases (e.g. the standard 1000) have the
suffixes k, M, G, etc.
<p>

The <code class=scheme><span class=variable>&lt;suffix&gt;</span></code> argument is appended only if an abbreviation is used.
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>num/si</span> <span class=number>608</span>))</code>
<p>

<code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;608&quot;</span></code>
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>num/si</span> <span class=number>3986</span>))</code>
<p>

<code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;3.9Ki&quot;</span></code>
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>num/si</span> <span class=number>3986</span> <span class=number>1000</span> <span class=string>&quot;B&quot;</span>))</code>
<p>

<code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;4kB&quot;</span></code>
<p>

See <a href="http://www.bipm.org/en/si/si_brochure/chapter3/prefixes.html">http://www.bipm.org/en/si/si_brochure/chapter3/prefixes.html</a>.
<p>

<h3>(num/fit &lt;width&gt; &lt;n&gt; . &lt;ARGS&gt;)</h3>

Like <code class=scheme><span class=variable>num</span></code>, but if the result doesn't fit in <code class=scheme><span class=variable>&lt;width&gt;</span></code>, output
instead a string of hashes (with the current <code class=scheme><span class=variable>&lt;precision&gt;</span></code>) rather
than showing an incorrectly truncated number.  For example
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>fix</span> <span class=number>2</span> (<span class=variable>num/fit</span> <span class=number>4</span> <span class=number>12.345</span>)))</code>
  <code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;#.##&quot;</span></code>
<p>

<h3>(num/roman &lt;n&gt;)</h3>

Formats the number as a Roman numeral:
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>num/roman</span> <span class=number>1989</span>))</code>
  <code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;MCMLXXXIX&quot;</span></code>
<p>

<h3>(num/old-roman &lt;n&gt;)</h3>

Formats the number as an old-style Roman numeral, without the
subtraction abbreviation rule:
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>num/old-roman</span> <span class=number>1989</span>))</code>
  <code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;MDCCCCLXXXVIIII&quot;</span></code>
<p>

<a name="SECTION_5.3"><h2>5.3&nbsp;&nbsp;Formatting Space</h2>

<h3>nl</h3>

Outputs a newline.
<p>

<h3>fl</h3>

Short for &quot;fresh line,&quot; outputs a newline only if we're not already
at the start of a line.
<p>

<h3>(space-to &lt;column&gt;)</h3>

Outputs spaces up to the given <code class=scheme><span class=variable>&lt;column&gt;</span></code>.  If the current column is
already &gt;= <code class=scheme><span class=variable>&lt;column&gt;</span></code>, does nothing.
<p>

<h3>(tab-to [&lt;tab-width&gt;])</h3>

Outputs spaces up to the next tab stop, using tab stops of width
<code class=scheme><span class=variable>&lt;tab-width&gt;</span></code>, which defaults to 8.  If already on a tab stop, does
nothing.  If you want to ensure you always tab at least one space, you
can use <code class=scheme>(<span class=variable>cat</span> <span class=string>&quot; &quot;</span> (<span class=variable>tab-to</span> <span class=variable>width</span>))</code>.
<p>

<h3>fmt-null</h3>

Outputs nothing (useful in combinators and as a default noop in
conditionals).
<p>

<a name="SECTION_5.4"><h2>5.4&nbsp;&nbsp;Concatenation</h2>

<h3>(cat &lt;format&gt; ...)</h3>

Concatenates the output of each <code class=scheme><span class=variable>&lt;format&gt;</span></code>.
<p>

<h3>(apply-cat &lt;list&gt;)</h3>

Equivalent to <code class=scheme>(<span class=variable>apply</span> <span class=variable>cat</span> <span class=variable>&lt;list&gt;</span>)</code> but may be more efficient.
<p>

<h3>(fmt-join &lt;formatter&gt; &lt;list&gt; [&lt;sep&gt;])</h3>

Formats each element <code class=scheme><span class=variable>&lt;elt&gt;</span></code> of <code class=scheme><span class=variable>&lt;list&gt;</span></code> with <code class=scheme>(<span class=variable>&lt;formatter&gt;</span>
<span class=variable>&lt;elt&gt;</span>)</code>, inserting <code class=scheme><span class=variable>&lt;sep&gt;</span></code> in between.  <code class=scheme><span class=variable>&lt;sep&gt;</span></code> defaults to the
empty string, but can be any format.
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>fmt-join</span> <span class=variable>dsp</span> '(<span class=variable>a</span> <span class=variable>b</span> <span class=variable>c</span>) <span class=string>&quot;, &quot;</span>))</code>
<p>

<code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;a, b, c&quot;</span></code>
<p>

<h3>(fmt-join/prefix &lt;formatter&gt; &lt;list&gt; [&lt;sep&gt;])</h3>

<h3>(fmt-join/suffix &lt;formatter&gt; &lt;list&gt; [&lt;sep&gt;])</h3>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>fmt-join/prefix</span> <span class=variable>dsp</span> '(<span class=variable>usr</span> <span class=variable>local</span> <span class=variable>bin</span>) <span class=string>&quot;/&quot;</span>))</code>
<p>

<code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;/usr/local/bin&quot;</span></code>
<p>

As <code class=scheme><span class=variable>fmt-join</span></code>, but inserts <code class=scheme><span class=variable>&lt;sep&gt;</span></code> before/after every element.
<p>

<h3>(fmt-join/last &lt;formatter&gt; &lt;last-formatter&gt; &lt;list&gt; [&lt;sep&gt;])</h3>

As <code class=scheme><span class=variable>fmt-join</span></code>, but the last element of the list is formatted with
<code class=scheme><span class=variable>&lt;last-formatter&gt;</span></code> instead.
<p>

<h3>(fmt-join/dot &lt;formatter&gt; &lt;dot-formatter&gt; &lt;list&gt; [&lt;sep&gt;])</h3>

As <code class=scheme><span class=variable>fmt-join</span></code>, but if the list is a dotted list, then formats the dotted
value with <code class=scheme><span class=variable>&lt;dot-formatter&gt;</span></code> instead.
<p>

<a name="SECTION_5.5"><h2>5.5&nbsp;&nbsp;Padding and Trimming</h2>

<h3>(pad &lt;width&gt; &lt;format&gt; ...)</h3>

<h3>(pad/left &lt;width&gt; &lt;format&gt; ...)</h3>

<h3>(pad/both &lt;width&gt; &lt;format&gt; ...)</h3>

Analogs of SRFI-13 <code class=scheme><span class=variable>string-pad</span></code>, these add extra space to the left,
right or both sides of the output generated by the <code class=scheme><span class=variable>&lt;format&gt;</span></code>s to
pad it to <code class=scheme><span class=variable>&lt;width&gt;</span></code>.  If <code class=scheme><span class=variable>&lt;width&gt;</span></code> is exceeded has no effect.
<code class=scheme><span class=variable>pad/both</span></code> will include an extra space on the right side of the
output if the difference is odd.
<p>

<code class=scheme><span class=variable>pad</span></code> does not accumulate any intermediate data.
<p>

Note these are column-oriented padders, so won't necessarily work
with multi-line output (padding doesn't seem a likely operation for
multi-line output).
<p>

<h3>(trim &lt;width&gt; &lt;format&gt; ...)</h3>

<h3>(trim/left &lt;width&gt; &lt;format&gt; ...)</h3>

<h3>(trim/both &lt;width&gt; &lt;format&gt; ...)</h3>

Analogs of SRFI-13 <code class=scheme><span class=variable>string-trim</span></code>, truncates the output of the
<code class=scheme><span class=variable>&lt;format&gt;</span></code>s to force it in under <code class=scheme><span class=variable>&lt;width&gt;</span></code> columns.  As soon as
any of the <code class=scheme><span class=variable>&lt;format&gt;</span></code>s exceed <code class=scheme><span class=variable>&lt;width&gt;</span></code>, stop formatting and
truncate the result, returning control to whoever called <code class=scheme><span class=variable>trim</span></code>.  If
<code class=scheme><span class=variable>&lt;width&gt;</span></code> is not exceeded has no effect.
<p>

If a truncation ellipse is set (e.g. with the <code class=scheme><span class=variable>ellipses</span></code> procedure
below), then when any truncation occurs <code class=scheme><span class=variable>trim</span></code> and <code class=scheme><span class=variable>trim/left</span></code>
will append and prepend the ellipse, respectively.  <code class=scheme><span class=variable>trim/both</span></code> will
both prepend and append.  The length of the ellipse will be considered
when truncating the original string, so that the total width will
never be longer than <code class=scheme><span class=variable>&lt;width&gt;</span></code>.
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>ellipses</span> <span class=string>&quot;...&quot;</span> (<span class=variable>trim</span> <span class=number>5</span> <span class=string>&quot;abcde&quot;</span>)))</code>
<p>

<code class=scheme><span class=keyword>=&gt;</span>  <span class=string>&quot;abcde&quot;</span></code>
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>ellipses</span> <span class=string>&quot;...&quot;</span> (<span class=variable>trim</span> <span class=number>5</span> <span class=string>&quot;abcdef&quot;</span>)))</code>
<p>

<code class=scheme><span class=keyword>=&gt;</span>  <span class=string>&quot;ab...&quot;</span></code>
<p>

<h3>(trim/length &lt;width&gt; &lt;format&gt; ...)</h3>

A variant of <code class=scheme><span class=variable>trim</span></code> which acts on the actual character count rather
than columns, useful for truncating potentially cyclic data.
<p>

<h3>(fit &lt;width&gt; &lt;format&gt; ...)</h3>

<h3>(fit/left &lt;width&gt; &lt;format&gt; ...)</h3>

<h3>(fit/both &lt;width&gt; &lt;format&gt; ...)</h3>

A combination of <code class=scheme><span class=variable>pad</span></code> and <code class=scheme><span class=variable>trunc</span></code>, ensures the output width is
exactly <code class=scheme><span class=variable>&lt;width&gt;</span></code>, truncating if it goes over and padding if it goes
under.
<p>

<a name="SECTION_5.6"><h2>5.6&nbsp;&nbsp;Format Variables</h2>

You may have noticed many of the formatters are aware of the current
column.  This is because each combinator is actually a procedure of
one argument, the current format state, which holds basic
information such as the row, column, and any other information that
a format combinator may want to keep track of.  The basic interface
is:
<p>

<h3>(fmt-let &lt;name&gt; &lt;value&gt; &lt;format&gt; ...)</h3>

<h3>(fmt-bind &lt;name&gt; &lt;value&gt; &lt;format&gt; ...)</h3>

<code class=scheme><span class=variable>fmt-let</span></code> sets the name for the duration of the <code class=scheme><span class=variable>&lt;format&gt;</span></code>s, and
restores it on return.  <code class=scheme><span class=variable>fmt-bind</span></code> sets it without restoring it.
<p>

A convenience control structure can be useful in combination with
these states:
<p>

<h3>(fmt-if &lt;pred&gt; &lt;pass&gt; [&lt;fail&gt;])</h3>

<code class=scheme><span class=variable>&lt;pred&gt;</span></code> takes one argument (the format state) and returns a boolean
result.  If true, the <code class=scheme><span class=variable>&lt;pass&gt;</span></code> format is applied to the state,
otherwise <code class=scheme><span class=variable>&lt;fail&gt;</span></code> (defaulting to the identity) is applied.
<p>

Many of the previously mentioned combinators have behavior which can
be altered with state variables.  Although <code class=scheme><span class=variable>fmt-let</span></code> and <code class=scheme><span class=variable>fmt-bind</span></code>
could be used, these common variables have shortcuts:
<p>

<h3>(radix &lt;k&gt; &lt;format&gt; ...)</h3>

<h3>(fix &lt;k&gt; &lt;format&gt; ...)</h3>

These alter the radix and fixed point precision of numbers output with
<code class=scheme><span class=variable>dsp</span></code>, <code class=scheme><span class=variable>wrt</span></code>, <code class=scheme><span class=variable>pretty</span></code> or <code class=scheme><span class=variable>num</span></code>.  These settings apply
recursively to all output data structures, so that
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>radix</span> <span class=number>16</span> '(<span class=number>70</span> <span class=number>80</span> <span class=number>90</span>)))</code>
<p>

will return the string <code class=scheme><span class=string>&quot;(#x46 #x50 #x5a)&quot;</span></code>.  Note that read/write
invariance is essential, so for <code class=scheme><span class=variable>dsp</span></code>, <code class=scheme><span class=variable>wrt</span></code> and <code class=scheme><span class=variable>pretty</span></code> the
radix prefix is always included when not decimal.  Use <code class=scheme><span class=variable>num</span></code> if you
want to format numbers in alternate bases without this prefix.  For
example,
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>radix</span> <span class=number>16</span> <span class=string>&quot;(&quot;</span> (<span class=variable>fmt-join</span> <span class=variable>num</span> '(<span class=number>70</span> <span class=number>80</span> <span class=number>90</span>) <span class=string>&quot; &quot;</span>) <span class=string>&quot;)&quot;</span>))</code>
<p>

would return <code class=scheme><span class=string>&quot;(46 50 5a)&quot;</span></code>, the same output as above without the
&quot;#x&quot; radix prefix.
<p>

Note that fixed point formatting supports arbitrary precision in
implementations with exact non-integral rationals.  When trying to
print inexact numbers more than the machine precision you will
typically get results like
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>fix</span> <span class=number>30</span> <span class=constant>#i2/3</span>))</code>
<p>

<code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;0.666666666666666600000000000000&quot;</span></code>
<p>

but with an exact rational it will give you as many digits as you
request:
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>fix</span> <span class=number>30</span> <span class=number>2/3</span>))</code>
<p>

<code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;0.666666666666666666666666666667&quot;</span></code>
<p>

<h3>(decimal-align &lt;k&gt; &lt;format&gt; ...)</h3>

Specifies an alignment for the decimal place when formatting numbers,
useful for outputting tables of numbers.
<p>

<pre class=scheme>
  (<span class=keyword>define</span> (<span class=variable>print-angles</span> <span class=variable>x</span>)
     (<span class=variable>fmt-join</span> <span class=variable>num</span> (<span class=variable>list</span> <span class=variable>x</span> (<span class=variable>sin</span> <span class=variable>x</span>) (<span class=variable>cos</span> <span class=variable>x</span>) (<span class=variable>tan</span> <span class=variable>x</span>)) <span class=string>&quot; &quot;</span>))

  (<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>decimal-align</span> <span class=number>5</span> (<span class=variable>fix</span> <span class=number>3</span> (<span class=variable>fmt-join/suffix</span> <span class=variable>print-angles</span> (<span class=variable>iota</span> <span class=number>5</span>) <span class=variable>nl</span>))))
</pre>
<p>

would output
<p>

<pre>
   0.000    0.000    1.000    0.000
   1.000    0.842    0.540    1.557
   2.000    0.909   -0.416   -2.185
   3.000    0.141   -0.990   -0.142
   4.000   -0.757   -0.654    1.158
</pre>
<p>

<h3>(comma-char &lt;k&gt; &lt;format&gt; ...)</h3>

<h3>(decimal-char &lt;k&gt; &lt;format&gt; ...)</h3>

<code class=scheme><span class=variable>comma-char</span></code> and <code class=scheme><span class=variable>decimal-char</span></code> set the defaults for number
formatting.
<p>

<h3>(pad-char &lt;k&gt; &lt;format&gt; ...)</h3>

The <code class=scheme><span class=variable>pad-char</span></code> sets the character used by <code class=scheme><span class=variable>space-to</span></code>, <code class=scheme><span class=variable>tab-to</span></code>,
<code class=scheme><span class=variable>pad/*</span></code>, and <code class=scheme><span class=variable>fit/*</span></code>, and defaults to <code class=scheme><span class=char>#\space</span></code>.
<p>

<pre class=scheme>
  (<span class=keyword>define</span> (<span class=variable>print-table-of-contents</span> <span class=variable>alist</span>)
    (<span class=keyword>define</span> (<span class=variable>print-line</span> <span class=variable>x</span>)
      (<span class=variable>cat</span> (<span class=variable>car</span> <span class=variable>x</span>) (<span class=variable>space-to</span> <span class=number>72</span>) (<span class=variable>pad/left</span> <span class=number>3</span> (<span class=variable>cdr</span> <span class=variable>x</span>))))
    (<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>pad-char</span> <span class=char>#\.</span> (<span class=variable>fmt-join/suffix</span> <span class=variable>print-line</span> <span class=variable>alist</span> <span class=variable>nl</span>))))

  (<span class=variable>print-table-of-contents</span>
   '((<span class=string>&quot;An Unexpected Party&quot;</span> . <span class=number>29</span>)
     (<span class=string>&quot;Roast Mutton&quot;</span> . <span class=number>60</span>)
     (<span class=string>&quot;A Short Rest&quot;</span> . <span class=number>87</span>)
     (<span class=string>&quot;Over Hill and Under Hill&quot;</span> . <span class=number>100</span>)
     (<span class=string>&quot;Riddles in the Dark&quot;</span> . <span class=number>115</span>)))
</pre>
<p>

would output
<p>

<pre>
  An Unexpected Party.....................................................29
  Roast Mutton............................................................60
  A Short Rest............................................................87
  Over Hill and Under Hill...............................................100
  Riddles in the Dark....................................................115
</pre>
<p>

<h3>(ellipse &lt;ell&gt; &lt;format&gt; ...)</h3>

Sets the truncation ellipse to <code class=scheme><span class=variable>&lt;ell&gt;</span></code>, would should be a string or
character.
<p>

<h3>(with-width &lt;width&gt; &lt;format&gt; ...)</h3>

Sets the maximum column width used by some formatters.  The default
is 78.
<p>

<a name="SECTION_5.7"><h2>5.7&nbsp;&nbsp;Columnar Formatting</h2>

Although <code class=scheme><span class=variable>tab-to</span></code>, <code class=scheme><span class=variable>space-to</span></code> and padding can be used to manually
align columns to produce table-like output, these can be awkward to
use.  The optional extensions in this section make this easier.
<p>

<h3>(columnar &lt;column&gt; ...)</h3>

Formats each <code class=scheme><span class=variable>&lt;column&gt;</span></code> side-by-side, i.e. as though each were
formatted separately and then the individual lines concatenated
together.  The current column width is divided evenly among the
columns, and all but the last column are right-padded.  For example
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>columnar</span> (<span class=variable>dsp</span> <span class=string>&quot;abcndefn&quot;</span>) (<span class=variable>dsp</span> <span class=string>&quot;123n456n&quot;</span>)))</code>
<p>

outputs
<p>

<pre>
     abc     123
     def     456
</pre>
<p>

assuming a 16-char width (the left side gets half the width, or 8
spaces, and is left aligned).  Note that we explicitly use DSP instead
of the strings directly.  This is because <code class=scheme><span class=variable>columnar</span></code> treats raw
strings as literals inserted into the given location on every line, to
be used as borders, for example:
<p>

<pre class=scheme>
  (<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>columnar</span> <span class=string>&quot;/* &quot;</span> (<span class=variable>dsp</span> <span class=string>&quot;abcndefn&quot;</span>)
                    <span class=string>&quot; | &quot;</span> (<span class=variable>dsp</span> <span class=string>&quot;123n456n&quot;</span>)
                    <span class=string>&quot; */&quot;</span>))
</pre>
<p>

would output
<p>

<pre>
  /* abc | 123 */
  /* def | 456 */
</pre>
<p>

You may also prefix any column with any of the symbols <code class=scheme>'<span class=variable>left</span></code>,
<code class=scheme>'<span class=variable>right</span></code> or <code class=scheme>'<span class=variable>center</span></code> to control the justification.  The symbol
<code class=scheme>'<span class=variable>infinite</span></code> can be used to indicate the column generates an infinite
stream of output.
<p>

You can further prefix any column with a width modifier.  Any
positive integer is treated as a fixed width, ignoring the available
width.  Any real number between 0 and 1 indicates a fraction of the
available width (after subtracting out any fixed widths).  Columns
with unspecified width divide up the remaining width evenly.
<p>

Note that <code class=scheme><span class=variable>columnar</span></code> builds its output incrementally, interleaving
calls to the generators until each has produced a line, then
concatenating that line together and outputting it.  This is important
because as noted above, some columns may produce an infinite stream of
output, and in general you may want to format data larger than can fit
into memory.  Thus columnar would be suitable for line numbering a
file of arbitrary size, or implementing the Unix <code class=scheme><span class=variable>yes</span>(<span class=number>1</span>)</code> command,
etc.
<p>

As an implementation detail, <code class=scheme><span class=variable>columnar</span></code> uses first-class
continuations to interleave the column output.  The core <code class=scheme><span class=variable>fmt</span></code>
itself has no knowledge of or special support for <code class=scheme><span class=variable>columnar</span></code>, which
could complicate and potentially slow down simpler <code class=scheme><span class=variable>fmt</span></code> operations.
This is a testament to the power of <code class=scheme><span class=variable>call/cc</span></code> - it can be used to
implement coroutines or arbitrary control structures even where they
were not planned for.
<p>

<h3>(tabular &lt;column&gt; ...)</h3>

Equivalent to <code class=scheme><span class=variable>columnar</span></code> except that each column is padded at least
to the minimum width required on any of its lines.  Thus
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>tabular</span> <span class=string>&quot;|" (dsp &quot;</span><span class=variable>a\\nbc\\ndef\\n</span><span class=string>&quot;) &quot;</span>|" (<span class=variable>dsp</span> <span class=string>&quot;123n45n6n&quot;</span>) <span class=string>&quot;|"))</span></code>
<p>

outputs
<p>

<pre>
|a  |123|
|bc |45 |
|def|6  |
</pre>
<p>

This makes it easier to generate tables without knowing widths in
advance.  However, because it requires generating the entire output in
advance to determine the correct column widths, <code class=scheme><span class=variable>tabular</span></code> cannot
format a table larger than would fit in memory.
<p>

<h3>(fmt-columns &lt;column&gt; ...)</h3>

The low-level formatter on which <code class=scheme><span class=variable>columnar</span></code> is based.  Each <code class=scheme><span class=variable>&lt;column&gt;</span></code>
must be a list of 2-3 elements:
<p>

<code class=scheme>(<span class=variable>&lt;line-formatter&gt;</span> <span class=variable>&lt;line-generator&gt;</span> [<span class=variable>&lt;infinite?&gt;</span>])</code>
<p>

where <code class=scheme><span class=variable>&lt;line-generator&gt;</span></code> is the column generator as above, and the
<code class=scheme><span class=variable>&lt;line-formatter&gt;</span></code> is how each line is formatted.  Raw concatenation
of each line is performed, without any spacing or width adjustment.
<code class=scheme><span class=variable>&lt;infinite?&gt;</span></code>, if true, indicates this generator produces an
infinite number of lines and termination should be determined without
it.
<p>

<h3>(wrap-lines &lt;format&gt; ...)</h3>

Behaves like <code class=scheme><span class=variable>cat</span></code>, except text is accumulated and lines are optimally
wrapped to fit in the current width as in the Unix <code>fmt(1)</code> command.
<p>

<h3>(justify &lt;format&gt; ...)</h3>

Like <code class=scheme><span class=variable>wrap-lines</span></code> except the lines are full-justified.
<p>

<pre class=scheme>
  (<span class=keyword>define</span> <span class=variable>func</span>
    '(<span class=keyword>define</span> (<span class=variable>fold</span> <span class=variable>kons</span> <span class=variable>knil</span> <span class=variable>ls</span>)
       (<span class=keyword>let</span> <span class=variable>lp</span> ((<span class=variable>ls</span> <span class=variable>ls</span>) (<span class=variable>acc</span> <span class=variable>knil</span>))
         (<span class=keyword>if</span> (<span class=variable>null?</span> <span class=variable>ls</span>) <span class=variable>acc</span> (<span class=variable>lp</span> (<span class=variable>cdr</span> <span class=variable>ls</span>) (<span class=variable>kons</span> (<span class=variable>car</span> <span class=variable>ls</span>) <span class=variable>acc</span>))))))

  (<span class=keyword>define</span> <span class=variable>doc</span>
    (<span class=variable>string-append</span>
      <span class=string>&quot;The fundamental list iterator.  Applies KONS to each element &quot;</span>
      <span class=string>&quot;of LS and the result of the previous application, beginning &quot;</span>
      <span class=string>&quot;with KNIL.  With KONS as CONS and KNIL as '(), equivalent to REVERSE.&quot;</span>))

  (<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>columnar</span> (<span class=variable>pretty</span> <span class=variable>func</span>) <span class=string>&quot; ; &quot;</span> (<span class=variable>justify</span> <span class=variable>doc</span>)))
</pre>
<p>

outputs
<p>

<pre>
  (define (fold kons knil ls)          ; The   fundamental   list   iterator.
    (let lp ((ls ls) (acc knil))       ; Applies  KONS  to  each  element  of
      (if (null? ls)                   ; LS  and  the  result of the previous
          acc                          ; application,  beginning  with  KNIL.
          (lp (cdr ls)                 ; With  KONS  as CONS and KNIL as '(),
              (kons (car ls) acc)))))  ; equivalent to REVERSE.
</pre>
<p>

<h3>(fmt-file &lt;pathname&gt;)</h3>

Simply displayes the contents of the file <code class=scheme><span class=variable>&lt;pathname&gt;</span></code> a line at a
time, so that in typical formatters such as <code class=scheme><span class=variable>columnar</span></code> only constant
memory is consumed, making this suitable for formatting files of
arbitrary size.
<p>

<h3>(line-numbers [&lt;start&gt;])</h3>

A convenience utility, just formats an infinite stream of numbers (in
the current radix) beginning with <code class=scheme><span class=variable>&lt;start&gt;</span></code>, which defaults to <code class=scheme><span class=number>1</span></code>.
<p>

The Unix <code class=scheme><span class=variable>nl</span>(<span class=number>1</span>)</code> utility could be implemented as:
<p>

<pre class=scheme>
  (<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>columnar</span> <span class=number>6</span> '<span class=variable>right</span> '<span class=variable>infinite</span> (<span class=variable>line-numbers</span>)
                    <span class=string>&quot; &quot;</span> (<span class=variable>fmt-file</span> <span class=string>&quot;read-line.scm&quot;</span>)))
</pre>
<p>

<pre>
     1 
     2 (define (read-line . o)
     3   (let ((port (if (pair? o) (car o) (current-input-port))))
     4     (let lp ((res '()))
     5       (let ((c (read-char port)))
     6         (if (or (eof-object? c) (eqv? c #\newline))
     7             (list-&gt;string (reverse res))
     8             (lp (cons c res)))))))
</pre>
<p>

<a name="SECTION_6"><h1>6&nbsp;&nbsp;C Formatting</h1>

<a name="SECTION_6.1"><h2>6.1&nbsp;&nbsp;C Formatting Basics</h2>

For purposes such as writing wrappers, code-generators, compilers or
other language tools, people often need to generate or emit C code.
Without a decent library framework it's difficult to maintain proper
indentation.  In addition, for the Scheme programmer it's tedious to
work with all the context sensitivities of C, such as the expression
vs. statement distinction, special rules for writing preprocessor
macros, and when precedence rules require parenthesis.  Fortunately,
context is one thing this formatting library is good at keeping
track of.  The C formatting interface tries to make it as easy as
possible to generate C code without getting in your way.
<p>

There are two approaches to using the C formatting extensions -
procedural and sexp-oriented (described in <a href="#SECTION_6.7">6.7</a>).  In the
procedural interface, C operators are made available as formatters
with a &quot;c-&quot; prefix, literals are converted to their C equivalents and
symbols are output as-is (you're responsible for making sure they are
valid C identifiers).  Indentation is handled automatically.
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>c-if</span> <span class=number>1</span> <span class=number>2</span> <span class=number>3</span>))</code>
<p>

outputs
<p>

<pre>
  if (1) {
      2;
  } else {
      3;
  }
</pre>
<p>

In addition, the formatter knows when you're in an expression and
when you're in a statement, and behaves accordingly, so that
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>c-if</span> (<span class=variable>c-if</span> <span class=number>1</span> <span class=number>2</span> <span class=number>3</span>) <span class=number>4</span> <span class=number>5</span>))</code>
<p>

outputs
<p>

<pre>
  if (1 ? 2 : 3) {
      4;
  } else {
      5;
  }
</pre>
<p>

Similary, <code class=scheme><span class=variable>c-begin</span></code>, used for sequencing, will separate with
semi-colons in a statement and commas in an expression.
<p>

Moreover, we also keep track of the final expression in a function
and insert returns for you:
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>c-fun</span> '<span class=variable>int</span> '<span class=variable>foo</span> '() (<span class=variable>c-if</span> (<span class=variable>c-if</span> <span class=number>1</span> <span class=number>2</span> <span class=number>3</span>) <span class=number>4</span> <span class=number>5</span>)))</code>
<p>

outputs
<p>

<pre>
  int foo () {
      if (1 ? 2 : 3) {
          return 4;
      } else {
          return 5;
      }
  }
</pre>
<p>

although it knows that void functions don't return.
<p>

Switch statements insert breaks by default if they don't return:
<p>

<pre class=scheme>
  (<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>c-switch</span> '<span class=variable>y</span>
            (<span class=variable>c-case</span> <span class=number>1</span> (<span class=variable>c+=</span> '<span class=variable>x</span> <span class=number>1</span>))
            (<span class=variable>c-default</span> (<span class=variable>c+=</span> '<span class=variable>x</span> <span class=number>2</span>))))
</pre>
<p>

<pre>
  switch (y) {
      case 1:
          x += 1;
          break;
      default:
          x += 2;
          break;
  }
</pre>
<p>

though you can explicitly fallthrough if you want:
<p>

<pre class=scheme>
  (<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>c-switch</span> '<span class=variable>y</span>
            (<span class=variable>c-case/fallthrough</span> <span class=number>1</span> (<span class=variable>c+=</span> '<span class=variable>x</span> <span class=number>1</span>))
            (<span class=variable>c-default</span> (<span class=variable>c+=</span> '<span class=variable>x</span> <span class=number>2</span>))))
</pre>
<p>

<pre>
  switch (y) {
      case 1:
          x += 1;
      default:
          x += 2;
          break;
  }
</pre>
<p>

Operators are available with just a &quot;c&quot; prefix, e.g. c+, c-, c*, c/,
etc.  <code class=scheme><span class=variable>c++</span></code> is a prefix operator, <code class=scheme><span class=variable>c++/post</span></code> is postfix.  ||, | and
|= are written as <code class=scheme><span class=variable>c-or</span></code>, <code class=scheme><span class=variable>c-bit-or</span></code> and <code class=scheme><span class=variable>c-bit-or=</span></code> respectively.
<p>

Function applications are written with <code class=scheme><span class=variable>c-apply</span></code>.  Other control
structures such as <code class=scheme><span class=variable>c-for</span></code> and <code class=scheme><span class=variable>c-while</span></code> work as expected.  The full
list is in the procedure index below.
<p>

When a C formatter encounters an object it doesn't know how to write
(including lists and records), it outputs them according to the
format state's current <code class=scheme>'<span class=variable>gen</span></code> variable.  This allows you to specify
generators for your own types, e.g. if you are using your own AST
records in a compiler.
<p>

If the <code class=scheme>'<span class=variable>gen</span></code> variable isn't set it defaults to the <code class=scheme><span class=variable>c-expr/sexp</span></code>
procedure, which formats an s-expression as if it were C code.  Thus
instead of <code class=scheme><span class=variable>c-apply</span></code> you can just use a list.  The full API is
available via normal s-expressions - formatters that aren't keywords
in C are prefixed with a % or otherwise made invalid C identifiers so
that they can't be confused with function application.
<p>

<a name="SECTION_6.2"><h2>6.2&nbsp;&nbsp;C Preprocessor Formatting</h2>

C preprocessor formatters also properly handle their surrounding
context, so you can safely intermix them in the normal flow of C
code.
<p>

<pre class=scheme>
  (<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>c-switch</span> '<span class=variable>y</span>
            (<span class=variable>c-case</span> <span class=number>1</span> (<span class=variable>c=</span> '<span class=variable>x</span> <span class=number>1</span>))
            (<span class=variable>cpp-ifdef</span> '<span class=variable>H_TWO</span> (<span class=variable>c-case</span> <span class=number>2</span> (<span class=variable>c=</span> '<span class=variable>x</span> <span class=number>4</span>)))
            (<span class=variable>c-default</span> (<span class=variable>c=</span> '<span class=variable>x</span> <span class=number>5</span>))))
</pre>
<p>

<pre>
  switch (y) {
      case 1:
          x = 1;
          break;

  #ifdef H_TWO
      case 2:
          x = 4;
          break;
  #endif /* H_TWO */
      default:
          x = 5;
          break;
  }
</pre>
<p>

Macros can be handled with <code class=scheme><span class=variable>cpp-define</span></code>, which knows to wrap
individual variable references in parenthesis:
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>cpp-define</span> '(<span class=variable>min</span> <span class=variable>x</span> <span class=variable>y</span>) (<span class=variable>c-if</span> (<span class=variable>c&lt;</span> '<span class=variable>x</span> '<span class=variable>y</span>) '<span class=variable>x</span> '<span class=variable>y</span>)))</code>
<p>

<pre>
  #define min(x, y) (((x) &lt; (y)) ? (x) : (y))
</pre>
<p>

As with all C formatters, the CPP output is pretty printed as
needed, and if it wraps over several lines the lines are terminated
with a backslash.
<p>

To write a C header file that is included at most once, you can wrap
the entire body in <code class=scheme><span class=variable>cpp-wrap-header</span></code>:
<p>

<pre class=scheme>
  (<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>cpp-wrap-header</span> <span class=string>&quot;FOO_H&quot;</span>
            (<span class=variable>c-extern</span> (<span class=variable>c-prototype</span> '<span class=variable>int</span> '<span class=variable>foo</span> '()))))
</pre>
<p>

<pre>
  #ifndef FOO_H
  #define FOO_H

  extern int foo ();

  #endif /* ! FOO_H */
</pre>
<p>

<a name="SECTION_6.3"><h2>6.3&nbsp;&nbsp;Customizing C Style</h2>

The output uses a simplified K&amp;R style with 4 spaces for indentation
by default.  The following state variables let you override the
style:
<p>

<h3>'indent-space</h3>

how many spaces to indent bodies, default <code class=scheme><span class=number>4</span></code>
<p>

<h3>'switch-indent-space</h3>

how many spaces to indent switch clauses, also defaults to <code class=scheme><span class=number>4</span></code>
<p>

<h3>'newline-before-brace?</h3>

insert a newline before an open brace (non-K&amp;R), defaults  to <code class=scheme><span class=boolean>#f</span></code>
<p>

<h3>'braceless-bodies?</h3>

omit braces when we can prove they aren't needed
<p>

<h3>'non-spaced-ops?</h3>

omit spaces between operators and operands for groups of variables and
literals (e.g. &quot;a+b+3&quot; instead of &quot;a + b + 3&quot;}
<p>

<h3>'no-wrap?</h3>

Don't wrap function calls and long operator groups over mulitple
lines.  Functions and control structures will still use multiple
lines.
<p>

The C formatters also respect the <code class=scheme>'<span class=variable>radix</span></code> and <code class=scheme>'<span class=variable>precision</span></code> settings.
<p>

<a name="SECTION_6.4"><h2>6.4&nbsp;&nbsp;C Formatter Index</h2>

<h3>(c-if &lt;condition&gt; &lt;pass&gt; [&lt;fail&gt; [&lt;condition2&gt; &lt;pass2&gt; ...]])</h3>

Print a chain of if/else conditions.  Use a final condition of <code class=scheme>'<span class=keyword>else</span></code>
for a final else clause.
<p>

<h3>(c-for &lt;init&gt; &lt;condition&gt; &lt;update&gt; &lt;body&gt; ...)</h3>

<h3>(c-while &lt;condition&gt; &lt;body&gt; ...)</h3>

Basic loop constructs.
<p>

<h3>(c-fun &lt;type&gt; &lt;name&gt; &lt;params&gt; &lt;body&gt; ...)</h3>

<h3>(c-prototype &lt;type&gt; &lt;name&gt; &lt;params&gt;)</h3>

Output a function or function prototype.  The parameters should be a
list 2-element lists of the form <code class=scheme>(<span class=variable>&lt;param-type&gt;</span> <span class=variable>&lt;param-name&gt;</span>)</code>,
which are output with DSP.  A parameter can be abbreviated as just the
symbol name, or <code class=scheme><span class=boolean>#f</span></code> can be passed as the type, in which case the
<code class=scheme>'<span class=variable>default-type</span></code> state variable is used.  The parameters may be a
dotted list, in which case ellipses for a C variadic are inserted -
the actual name of the dotted value is ignored.
<p>

Types are just typically just symbols, or lists of symbols such as
<code class=scheme>'(<span class=variable>const</span> <span class=variable>char</span>)</code>.  A complete description is given below in section
<a href="#SECTION_6.6">6.6</a>.
<p>

These can also accessed as %fun and %prototype at the head of a list.
<p>

<h3>(c-var &lt;type&gt; &lt;name&gt; [&lt;init-value&gt;])</h3>

Declares and optionally initializes a variable.  Also accessed as %var
at the head of a list.
<p>

<h3>(c-begin &lt;expr&gt; ...)</h3>

Outputs each of the &lt;expr&gt;s, separated by semi-colons if in a
statement or commas if in an expression.
<p>

<h3>(c-switch &lt;clause&gt; ...)</h3>

<h3>(c-case &lt;values&gt; &lt;body&gt; ...)</h3>

<h3>(c-case/fallthrough &lt;values&gt; &lt;body&gt; ...)</h3>

<h3>(c-default &lt;body&gt; ...)</h3>

Switch statements.  In addition to using the clause formatters,
clauses inside a switch may be handled with a Scheme CASE-like list,
with the car a list of case values and the cdr the body.
<p>

<h3>(c-label &lt;name&gt;)</h3>

<h3>(c-goto &lt;name&gt;)</h3>

<h3>(c-return [&lt;result&gt;])</h3>

<h3>c-break</h3>

<h3>c-continue</h3>

Manual labels and jumps.  Labels can also be accessed as a list
beginning with a colon, e.g. <code class=scheme>'(<span class=constant>:</span> <span class=variable>label1</span>)</code>.
<p>

<h3>(c-const &lt;expr&gt;)</h3>

<h3>(c-static &lt;expr&gt;)</h3>

<h3>(c-volatile &lt;expr&gt;)</h3>

<h3>(c-restrict &lt;expr&gt;)</h3>

<h3>(c-register &lt;expr&gt;)</h3>

<h3>(c-auto &lt;expr&gt;)</h3>

<h3>(c-inline &lt;expr&gt;)</h3>

<h3>(c-extern &lt;expr&gt;)</h3>

Declaration modifiers.  May be nested.
<p>

<h3>(c-extern/C &lt;body&gt; ...)</h3>

Wraps body in an extern &quot;C&quot; { ... } for use with C++.
<p>

<h3>(c-cast &lt;type&gt; &lt;expr&gt;)</h3>

Casts an expression to a type.  Also %cast at the head of a list.
<p>

<h3>(c-typedef &lt;type&gt; &lt;new-name&gt; ...)</h3>

Creates a new type definition with one or more names.
<p>

<h3>(c-struct [&lt;name&gt;] &lt;field-list&gt; [&lt;attributes&gt;])</h3>

<h3>(c-union [&lt;name&gt;] &lt;field-list&gt; [&lt;attributes&gt;])</h3>

<h3>(c-class [&lt;name&gt;] &lt;field-list&gt; [&lt;attributes&gt;])</h3>

<h3>(c-attribute &lt;values&gt; ...)</h3>

Composite type constructors.  Attributes may be accessed as
%attribute at the head of a list.
<p>

<pre class=scheme>
  (<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>c-struct</span> '<span class=variable>employee</span>
                      '((<span class=variable>short</span> <span class=variable>age</span>)
                        ((<span class=variable>char</span> <span class=global>*</span>) <span class=variable>name</span>)
                        ((<span class=variable>struct</span> (<span class=variable>year</span> <span class=variable>month</span> <span class=variable>day</span>)) <span class=variable>dob</span>))
                      (<span class=variable>c-attribute</span> '<span class=variable>packed</span>)))
</pre>
<p>

<pre>
  struct employee {
      short age;
      char* name;
      struct {
          int year;
          int month;
          int day;
      } dob;
  } __attribute__ ((packed));
</pre>
<p>

<h3>(c-enum [&lt;name&gt;] &lt;enum-list&gt;)</h3>

Enumerated types.  <code class=scheme><span class=variable>&lt;enum-list&gt;</span></code> may be strings, symbols, or lists of
string or symbol followed by the enum's value.
<p>

<h3>(c-comment &lt;formatter&gt; ...)</h3>

Outputs the <code class=scheme><span class=variable>&lt;formatter&gt;</span></code>s wrapped in C's /* ... */ comment.  Properly
escapes nested comments inside in an Emacs-friendly style.
<p>

<a name="SECTION_6.5"><h2>6.5&nbsp;&nbsp;C Preprocessor Formatter Index</h2>

<h3>(cpp-include &lt;file&gt;)</h3>

If file is a string, outputs in it &quot;quotes&quot;, otherwise (as a symbol
or arbitrary formatter) it outputs it in brackets.
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>cpp-include</span> '<span class=variable>stdio.h</span>))</code>
<p>

<code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;#include &lt;stdio.h&gt;n&quot;</span></code>
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#f</span> (<span class=variable>cpp-include</span> <span class=string>&quot;config.h&quot;</span>))</code>
<p>

<code class=scheme><span class=keyword>=&gt;</span> <span class=string>&quot;#include &quot;config.h&quot;n&quot;</span></code>
<p>

<h3>(cpp-define &lt;macro&gt; [&lt;value&gt;])</h3>

Defines a preprocessor macro, which may be just a name or a list of
name and parameters.  Properly wraps the value in parenthesis and
escapes newlines.  A dotted parameter list will use the C99 variadic
macro syntax, and will also substitute any references to the dotted
name with <code>__VA_ARGS__</code>:
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>cpp-define</span> '(<span class=variable>eprintf</span> . <span class=variable>args</span>) '(<span class=variable>fprintf</span> <span class=variable>stderr</span> <span class=variable>args</span>)))</code>
<p>

<pre>
  #define eprintf(...) (fprintf(stderr, __VA_ARGS__))
</pre>
<p>

<h3>(cpp-if &lt;condition&gt; &lt;pass&gt; [&lt;fail&gt; ...])</h3>

<h3>(cpp-ifdef &lt;condition&gt; &lt;pass&gt; [&lt;fail&gt; ...])</h3>

<h3>(cpp-ifndef &lt;condition&gt; &lt;pass&gt; [&lt;fail&gt; ...])</h3>

<h3>(cpp-elif &lt;condition&gt; &lt;pass&gt; [&lt;fail&gt; ...])</h3>

<h3>(cpp-else &lt;body&gt; ...)</h3>

Conditional compilation.
<p>

<h3>(cpp-line &lt;num&gt; [&lt;file&gt;])</h3>

Line number information.
<p>

<h3>(cpp-pragma &lt;args&gt; ...)</h3>

<h3>(cpp-error &lt;args&gt; ...)</h3>

<h3>(cpp-warning &lt;args&gt; ...)</h3>

Additional preprocessor directives.
<p>

<h3>(cpp-stringify &lt;expr&gt;)</h3>

Stringifies <code class=scheme><span class=variable>&lt;expr&gt;</span></code> by prefixing the # operator.
<p>

<h3>(cpp-sym-cat &lt;args&gt; ...)</h3>

Joins the <code class=scheme><span class=variable>&lt;args&gt;</span></code> into a single preprocessor token with the ##
operator.
<p>

<h3>(cpp-wrap-header &lt;name&gt; &lt;body&gt; ...)</h3>

Wrap an entire header to only be included once.
<p>

<h3>Operators:</h3>

<pre class=scheme>
<span class=variable>c++</span> <span class=variable>c--</span> <span class=variable>c+</span> <span class=variable>c-</span> <span class=variable>c*</span> <span class=variable>c/</span> <span class=variable>c%</span> <span class=variable>c&amp;</span> <span class=variable>c^</span> <span class=variable>c~</span> <span class=variable>c!</span> <span class=variable>c&amp;&amp;</span> <span class=variable>c&lt;&lt;</span> <span class=variable>c&gt;&gt;</span> <span class=variable>c==</span> <span class=variable>c!=</span>
<span class=variable>c&lt;</span> <span class=variable>c&gt;</span> <span class=variable>c&lt;=</span> <span class=variable>c&gt;=</span> <span class=variable>c=</span> <span class=variable>c+=</span> <span class=variable>c-=</span> <span class=variable>c*=</span> <span class=variable>c/=</span> <span class=variable>c%=</span> <span class=variable>c&amp;=</span> <span class=variable>c^=</span> <span class=variable>c&lt;&lt;=</span> <span class=variable>c&gt;&gt;=</span>
<span class=variable>c++/post</span> <span class=variable>c--/post</span> <span class=variable>c-or</span> <span class=variable>c-bit-or</span> <span class=variable>c-bit-or=</span>
</pre>
<p>

<a name="SECTION_6.6"><h2>6.6&nbsp;&nbsp;C Types</h2>


<p>

Typically a type is just a symbol such as <code class=scheme>'<span class=variable>char</span></code> or <code class=scheme>'<span class=variable>int</span></code>.  You
can wrap types with modifiers such as <code class=scheme><span class=variable>c-const</span></code>, but as a
convenience you can just use a list such as in <code class=scheme>'(<span class=variable>const</span> <span class=variable>unsignedchar</span> <span class=global>*</span>)</code>.
You can also nest these lists, so the previous example is
equivalent to <code class=scheme>'(<span class=global>*</span> (<span class=variable>const</span> (<span class=variable>unsigned</span> <span class=variable>char</span>)))</code>.
<p>

Pointers may be written as <code class=scheme>'(<span class=variable>%pointer</span> <span class=variable>&lt;type&gt;</span>)</code> for readability -
<code class=scheme><span class=variable>%pointer</span></code> is exactly equivalent to <code class=scheme><span class=global>*</span></code> in types.
<p>

Unamed structs, classes, unions and enums may be used directly as
types, using their respective keywords at the head of a list.
<p>

Two special types are the %array type and function pointer type.  An
array is written:
<p>

<code class=scheme>(<span class=variable>%array</span> <span class=variable>&lt;type&gt;</span> [<span class=variable>&lt;size&gt;</span>])</code>
<p>

where <code class=scheme><span class=variable>&lt;type&gt;</span></code> is any other type (including another array or
function pointer), and <code class=scheme><span class=variable>&lt;size&gt;</span></code>, if given, will print the array
size.  For example:
<p>

<code class=scheme>(<span class=variable>c-var</span> '(<span class=variable>%array</span> (<span class=variable>unsigned</span> <span class=variable>long</span>) <span class=variable>SIZE</span>) '<span class=variable>table</span> '<span class=constant>#</span>(<span class=number>1</span> <span class=number>2</span> <span class=number>3</span> <span class=number>4</span>))</code>
<p>

<pre>
unsigned long table[SIZE] = {1, 2, 3, 4};
</pre>
<p>

A function pointer is written:
<p>

<code class=scheme>(<span class=variable>%fun</span> <span class=variable>&lt;return-type&gt;</span> (<span class=variable>&lt;param-types&gt;</span> ...))</code>
<p>

For example:
<p>

<code class=scheme>(<span class=variable>c-typedef</span> '(<span class=variable>%fun</span> <span class=variable>double</span> (<span class=variable>double</span> <span class=variable>double</span> <span class=variable>int</span>)) '<span class=variable>f</span>)</code>
<p>

<pre>
typedef double (*f)(double, double, int);
</pre>
<p>

Wherever a type is expected but not given, the value of the
<code class=scheme>'<span class=variable>default-type</span></code> formatting state variable is used.  By default this
is just <code class=scheme>'<span class=variable>int</span></code>.
<p>

Type declarations work uniformly for variables and parameters, as well
for casts and typedefs.
<p>

<a name="SECTION_6.7"><h2>6.7&nbsp;&nbsp;C as S-Expressions</h2>


<p>

Rather than building formatting closures by hand, it can be more
convenient to just build a normal s-expression and ask for it to be
formatted as C code.  This can be thought of as a simple Scheme-&gt;C
compiler without any runtime support.
<p>

In a s-expression, strings and characters are printed as C strings and
characters, booleans are printed as 0 or 1, symbols are displayed
as-is, and numbers are printed as C numbers (using the current
formatting radix if specified).  Vectors are printed as
comma-separated lists wrapped in braces, which can be used for
initializing arrays or structs.
<p>

A list indicates a C expression or statement.  Any of the existing C
keywords can be used to pretty-print the expression as described with
the c-keyword formatters above.  Thus, the example above
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>c-if</span> (<span class=variable>c-if</span> <span class=number>1</span> <span class=number>2</span> <span class=number>3</span>) <span class=number>4</span> <span class=number>5</span>))</code>
<p>

could also be written
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>c-expr</span> '(<span class=keyword>if</span> (<span class=keyword>if</span> <span class=number>1</span> <span class=number>2</span> <span class=number>3</span>) <span class=number>4</span> <span class=number>5</span>)))</code>
<p>

C constructs that are dependent on the underlying syntax and have no
keyword are written with a % prefix (<code class=scheme><span class=variable>%fun</span></code>, <code class=scheme><span class=variable>%var</span></code>, <code class=scheme><span class=variable>%pointer</span></code>,
<code class=scheme><span class=variable>%array</span></code>, <code class=scheme><span class=variable>%cast</span></code>), including C preprocessor constructs
(<code class=scheme><span class=variable>%include</span></code>, <code class=scheme><span class=variable>%define</span></code>, <code class=scheme><span class=variable>%pragma</span></code>, <code class=scheme><span class=variable>%error</span></code>, <code class=scheme><span class=variable>%warning</span></code>,
<code class=scheme><span class=variable>%if</span></code>, <code class=scheme><span class=variable>%ifdef</span></code>, <code class=scheme><span class=variable>%ifndef</span></code>, <code class=scheme><span class=variable>%elif</span></code>).  Labels are written as
<code class=scheme>(<span class=constant>:</span> <span class=variable>&lt;label-name&gt;</span>)</code>.  You can write a sequence as <code class=scheme>(<span class=variable>%begin</span> <span class=variable>&lt;expr&gt;</span>
...)</code>.
<p>

For example, the following definition of the fibonacci sequence, which
apart from the return type of <code class=scheme><span class=boolean>#f</span></code> looks like a Lisp definition:
<p>

<code class=scheme>(<span class=variable>fmt</span> <span class=boolean>#t</span> (<span class=variable>c-expr</span> '(<span class=variable>%fun</span> <span class=boolean>#f</span> <span class=variable>fib</span> (<span class=variable>n</span>)
                         (<span class=keyword>if</span> (<span class=variable>&lt;=</span> <span class=variable>n</span> <span class=number>1</span>)
                             <span class=number>1</span>
                             (<span class=variable>+</span> (<span class=variable>fib</span> (<span class=variable>-</span> <span class=variable>n</span> <span class=number>1</span>)) (<span class=variable>fib</span> (<span class=variable>-</span> <span class=variable>n</span> <span class=number>2</span>)))))))</code>
<p>

prints the working C definition:
<p>

<pre>
int fib (int n) {
    if (n &lt;= 1) {
        return 1;
    } else {
        return fib((n - 1)) + fib((n - 2));
    }
}
</pre>
<p>

<a name="SECTION_7"><h1>7&nbsp;&nbsp;JavaScript Formatting</h1>

The experimental fmt-js library extends the fmt-c library with
functionality for formatting JavaScript code.
<p>

<h3>(js-expr x)</h3>

Formats a JavaScript expression similarly to <code class=scheme><span class=variable>c-expr</span></code>.  Inside a
<code class=scheme><span class=variable>js-expr</span></code> formatter, you can use the normal <code class=scheme><span class=variable>c-</span></code> prefixed
formatters described in the previous section, and they will format
appropriately for JavaScript.
<p>

Currently expressions will all be terminated with a semi-colon, but
that will be made optional in a later release.
<p>

<h3>(js-function [&lt;name&gt;] (&lt;params&gt;) &lt;body&gt; ...)</h3>

Defines a function (anonymously if no name is provided).
<p>

<h3>(js-var &lt;name&gt; [&lt;init-value&gt;])</h3>

Declares a JavaScript variable, optionally with an initial value.
<p>

<h3>(js-comment &lt;formatter&gt; ...)</h3>

Formats a comment prefixing lines with <code class=scheme><span class=string>&quot;// &quot;</span></code>.
<p>

<a name="SECTION_8"><h1>8&nbsp;&nbsp;Formatting with Color</h1>

The fmt-color library provides the following utilities:
<p>

<pre class=scheme>
  (<span class=variable>fmt-red</span> <span class=variable>&lt;formatter&gt;</span> ...)
  (<span class=variable>fmt-blue</span> <span class=variable>&lt;formatter&gt;</span> ...)
  (<span class=variable>fmt-green</span> <span class=variable>&lt;formatter&gt;</span> ...)
  (<span class=variable>fmt-cyan</span> <span class=variable>&lt;formatter&gt;</span> ...)
  (<span class=variable>fmt-yellow</span> <span class=variable>&lt;formatter&gt;</span> ...)
  (<span class=variable>fmt-magenta</span> <span class=variable>&lt;formatter&gt;</span> ...)
  (<span class=variable>fmt-white</span> <span class=variable>&lt;formatter&gt;</span> ...)
  (<span class=variable>fmt-black</span> <span class=variable>&lt;formatter&gt;</span> ...)
  (<span class=variable>fmt-bold</span> <span class=variable>&lt;formatter&gt;</span> ...)
  (<span class=variable>fmt-underline</span> <span class=variable>&lt;formatter&gt;</span> ...)
</pre>
<p>

and more generally
<p>

<code class=scheme>(<span class=variable>fmt-color</span> <span class=variable>&lt;color&gt;</span> <span class=variable>&lt;formatter&gt;</span> ...)</code>
<p>

where color can be a symbol name or <code class=scheme><span class=constant>#xRRGGBB</span></code> numeric value.
Outputs the formatters colored with ANSI escapes.  In addition
<p>

<code class=scheme>(<span class=variable>fmt-in-html</span> <span class=variable>&lt;formatter&gt;</span> ...)</code>
<p>

can be used to mark the format state as being inside HTML, which the
above color formats will understand and output HTML <code class=scheme><span class=variable>&lt;span&gt;</span></code> tags with
the appropriate style colors, instead of ANSI escapes.
<p>

<a name="SECTION_9"><h1>9&nbsp;&nbsp;Unicode</h1>

The fmt-unicode library provides the <code class=scheme><span class=variable>fmt-unicode</span></code> formatter, which
just takes a list of formatters and overrides the string-length for
padding and trimming, such that Unicode double or full width
characters are considered 2 characters wide (as they typically are in
fixed-width terminals), while treating combining and non-spacing
characters as 0 characters wide.
<p>

It also recognizes and ignores ANSI escapes, in particular useful if
you want to combine this with the fmt-color utilities.
<p>

<a name="SECTION_10"><h1>10&nbsp;&nbsp;Optimizing</h1>

The library is designed for scalability and flexibility, not speed,
and I'm not going to think about any fine tuning until it's more
stabilised.  One aspect of the design, however, was influenced for the
sake of future optimizations, which is that none of the default format
variables are initialized by global parameters, which leaves room for
inlining and subsequent simplification of format calls.
<p>

If you don't have an aggressively optimizing compiler, you can easily
achieve large speedups on common cases with CL-style compiler macros.
<p>

<a name="SECTION_11"><h1>11&nbsp;&nbsp;Common Lisp Format Cheat Sheet</h1>

A quick reference for those of you switching over from Common Lisp's
format.
<p>

<table>
<tr><td><strong>format</strong> </td><td> <strong>fmt</strong></td></tr>
<tr><td>~a </td><td> <code class=scheme><span class=variable>dsp</span></code></td></tr>
<tr><td>~c </td><td> <code class=scheme><span class=variable>dsp</span></code></td></tr>
<tr><td>~s </td><td> <code class=scheme><span class=variable>wrt/unshared</span></code></td></tr>
<tr><td>~w </td><td> <code class=scheme><span class=variable>wrt</span></code></td></tr>
<tr><td>~y </td><td> <code class=scheme><span class=variable>pretty</span></code></td></tr>
<tr><td>~x </td><td> <code class=scheme>(<span class=variable>radix</span> <span class=number>16</span> ...)</code> or <code class=scheme>(<span class=variable>num</span> <span class=variable>&lt;n&gt;</span> <span class=number>16</span>)</code></td></tr>
<tr><td>~o </td><td> <code class=scheme>(<span class=variable>radix</span> <span class=number>8</span> ...)</code> or <code class=scheme>(<span class=variable>num</span> <span class=variable>&lt;n&gt;</span> <span class=number>8</span>)</code></td></tr>
<tr><td>~b </td><td> <code class=scheme>(<span class=variable>radix</span> <span class=number>2</span> ...)</code> or <code class=scheme>(<span class=variable>num</span> <span class=variable>&lt;n&gt;</span> <span class=number>2</span>)</code></td></tr>
<tr><td>~f </td><td> <code class=scheme>(<span class=variable>fix</span> <span class=variable>&lt;digits&gt;</span> ...)</code> or <code class=scheme>(<span class=variable>num</span> <span class=variable>&lt;n&gt;</span> <span class=variable>&lt;radix&gt;</span> <span class=variable>&lt;digits&gt;</span>)</code></td></tr>
<tr><td>~% </td><td> <code class=scheme><span class=variable>nl</span></code></td></tr>
<tr><td>~&amp; </td><td> <code class=scheme><span class=variable>fl</span></code></td></tr>
<tr><td>~[...~] </td><td> normal <code class=scheme><span class=keyword>if</span></code> or <code class=scheme><span class=variable>fmt-if</span></code> (delayed test)</td></tr>
<tr><td>~{...~} </td><td> <code class=scheme>(<span class=variable>fmt-join</span> ... <span class=variable>&lt;list&gt;</span> [<span class=variable>&lt;sep&gt;</span>])</code></td></tr>
</table>
<p>

<a name="SECTION_12"><h1>12&nbsp;&nbsp;References</h1>

<a name="BIBITEM_1">[1]&nbsp; R. Kelsey, W. Clinger, J. Rees (eds.)
<a href="http://www.schemers.org/Documents/Standards/R5RS/">Revised^5 Report on the Algorithmic Language Scheme</a>
<p>

<a name="BIBITEM_2">[2]&nbsp; Guy L. Steele Jr. (editor)
<a href="http://www.harlequin.com/education/books/HyperSpec/">Common Lisp Hyperspec</a>
<p>

<a name="BIBITEM_3">[3]&nbsp; Scott G. Miller
<a href="http://srfi.schemers.org/srfi-28/">SRFI-28 Basic Format Strings</a>
<p>

<a name="BIBITEM_4">[4]&nbsp; Ken Dickey
<a href="http://srfi.schemers.org/srfi-48/">SRFI-48 Intermediate Format Strings</a>
<p>

<a name="BIBITEM_5">[5]&nbsp; Ray Dillinger
<a href="http://srfi.schemers.org/srfi-38/">SRFI-38 External Representation for Data With Shared Structure</a>
<p>

<a name="BIBITEM_6">[6]&nbsp; Damian Conway
<a href="http://www.perl.com/lpt/a/819">Perl6 Exegesis 7 - formatting</a>
<p>

<br /><br /><br /><br />
<!-- page created by Mistie, http://www.cs.rice.edu/~dorai/mistie/ -->
</body></html>

;;;; fmt.scm -- extensible formatting library
;;
;; Copyright (c) 2006-2009 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;; (require-extension (srfi 1 6 13 23 69))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; string utilities

(define (write-to-string x)
  (call-with-output-string (lambda (p) (write x p))))

(define (display-to-string x)
  (if (string? x)
      x
      (call-with-output-string (lambda (p) (display x p)))))

(define nl-str
  (call-with-output-string newline))

(define (make-space n) (make-string n #\space))
(define (make-nl-space n) (string-append nl-str (make-string n #\space)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; list utilities

(define (take* ls n)   ; handles dotted lists and n > length
  (cond ((zero? n) '())
        ((pair? ls) (cons (car ls) (take* (cdr ls) (- n 1))))
        (else '())))

(define (drop* ls n)   ; may return the dot
  (cond ((zero? n) ls)
        ((pair? ls) (drop* (cdr ls) (- n 1)))
        (else ls)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; format state representation

;; Use a flexible representation optimized for common cases -
;; frequently accessed values are in fixed vector slots, with a
;; `properties' slot holding an alist for all other values.

(define *default-fmt-state*
  (vector 0 0 10 '() #\space #f 78 #f #f #f #f #f #f))

(define fmt-state? vector?)

(define (new-fmt-state . o)
  (let ((st (if (pair? o) (car o) (current-output-port))))
    (if (vector? st)
        st
        (fmt-set-writer!
         (fmt-set-port! (copy-fmt-state *default-fmt-state*) st)
         fmt-write))))

(define (copy-fmt-state st)
  (let* ((len (vector-length st))
         (res (make-vector len)))
    (do ((i 0 (+ i 1)))
        ((= i len))
      (vector-set! res i (vector-ref st i)))
    (fmt-set-properties! res (map (lambda (x) (cons (car x) (cdr x)))
                                  (fmt-properties res)))
    res))

(define (fmt-row st) (vector-ref st 0))
(define (fmt-col st) (vector-ref st 1))
(define (fmt-radix st) (vector-ref st 2))
(define (fmt-properties st) (vector-ref st 3))
(define (fmt-pad-char st) (vector-ref st 4))
(define (fmt-precision st) (vector-ref st 5))
(define (fmt-width st) (vector-ref st 6))
(define (fmt-writer st) (vector-ref st 7))
(define (fmt-port st) (vector-ref st 8))
(define (fmt-decimal-sep st) (vector-ref st 9))
(define (fmt-decimal-align st) (vector-ref st 10))
(define (fmt-string-width st) (vector-ref st 11))
(define (fmt-ellipses st) (vector-ref st 12))

(define (fmt-set-row! st x) (vector-set! st 0 x) st)
(define (fmt-set-col! st x) (vector-set! st 1 x) st)
(define (fmt-set-radix! st x) (vector-set! st 2 x) st)
(define (fmt-set-properties! st x) (vector-set! st 3 x) st)
(define (fmt-set-pad-char! st x) (vector-set! st 4 x) st)
(define (fmt-set-precision! st x) (vector-set! st 5 x) st)
(define (fmt-set-width! st x) (vector-set! st 6 x) st)
(define (fmt-set-writer! st x) (vector-set! st 7 x) st)
(define (fmt-set-port! st x) (vector-set! st 8 x) st)
(define (fmt-set-decimal-sep! st x) (vector-set! st 9 x) st)
(define (fmt-set-decimal-align! st x) (vector-set! st 10 x) st)
(define (fmt-set-string-width! st x) (vector-set! st 11 x) st)
(define (fmt-set-ellipses! st x) (vector-set! st 12 x) st)

(define (fmt-ref st key . o)
  (case key
    ((row) (fmt-row st))
    ((col) (fmt-col st))
    ((radix) (fmt-radix st))
    ((properties) (fmt-properties st))
    ((writer) (fmt-writer st))
    ((port) (fmt-port st))
    ((precision) (fmt-precision st))
    ((pad-char) (fmt-pad-char st))
    ((width) (fmt-width st))
    ((decimal-sep) (fmt-decimal-sep st))
    ((decimal-align) (fmt-decimal-align st))
    ((string-width) (fmt-string-width st))
    ((ellipses) (fmt-ellipses st))
    (else (cond ((assq key (fmt-properties st)) => cdr)
                ((pair? o) (car o))
                (else #f)))))

(define (fmt-set-property! st key val)
  (cond ((assq key (fmt-properties st))
         => (lambda (cell) (set-cdr! cell val) st))
        (else (fmt-set-properties!
               st
               (cons (cons key val) (fmt-properties st))))))

(define (fmt-set! st key val)
  (case key
    ((row) (fmt-set-row! st val))
    ((col) (fmt-set-col! st val))
    ((radix) (fmt-set-radix! st val))
    ((properties) (fmt-set-properties! st val))
    ((pad-char) (fmt-set-pad-char! st val))
    ((precision) (fmt-set-precision! st val))
    ((writer) (fmt-set-writer! st val))
    ((port) (fmt-set-port! st val))
    ((width) (fmt-set-width! st val))
    ((decimal-sep) (fmt-set-decimal-sep! st val))
    ((decimal-align) (fmt-set-decimal-align! st val))
    ((string-width) (fmt-set-string-width! st val))
    ((ellipses) (fmt-set-ellipses! st val))
    (else (fmt-set-property! st key val))))

(define (fmt-add-properties! st alist)
  (for-each (lambda (x) (fmt-set! st (car x) (cdr x))) alist)
  st)

(define (fmt-let key val . ls)
  (lambda (st)
    (let ((orig-val (fmt-ref st key)))
      (fmt-set! ((apply-cat ls) (fmt-set! st key val)) key orig-val))))

(define (fmt-bind key val . ls)
  (lambda (st) ((apply-cat ls) (fmt-set! st key val))))

(define (fix prec . ls) (fmt-let 'precision prec (apply-cat ls)))
(define (radix rad . ls) (fmt-let 'radix rad (apply-cat ls)))
(define (pad-char ch . ls) (fmt-let 'pad-char ch (apply-cat ls)))
(define (comma-char ch . ls) (fmt-let 'comma-char ch (apply-cat ls)))
(define (decimal-char ch . ls) (fmt-let 'decimal-sep ch (apply-cat ls)))
(define (decimal-align n . ls) (fmt-let 'decimal-align n (apply-cat ls)))
(define (with-width w . ls) (fmt-let 'width w (apply-cat ls)))
(define (ellipses ell . ls) (fmt-let 'ellipses ell (apply-cat ls)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; the basic interface

(define (fmt-start st initializer proc)
  (cond
    ((or (output-port? st) (fmt-state? st))
     (proc (initializer st))
     (if #f #f))
    ((eq? #t st)
     (proc (initializer (current-output-port)))
     (if #f #f))
    ((eq? #f st)
     (get-output-string
      (fmt-port (proc (initializer (open-output-string))))))
    (else (error "unknown format output" st))))

(define (fmt st . args)
  (fmt-start st new-fmt-state (apply-cat args)))

(define (fmt-update str st)
  (let ((len (string-length str))
        (nli (string-index-right str #\newline))
        (str-width (fmt-string-width st)))
    (if nli
        (let ((row (+ (fmt-row st) 1 (string-count str #\newline 0 nli))))
          (fmt-set-row!
           (fmt-set-col! st (if str-width
                                (str-width str (+ nli 1) len)
                                (- len (+ nli 1))))
           row))
        (fmt-set-col! st (+ (fmt-col st)
                            (if str-width
                                (str-width str 0 len)
                                len))))))

(define (fmt-write str st)
  (display str (fmt-port st))
  (fmt-update str st))

(define (apply-cat procs)
  (lambda (st)
    (let loop ((ls procs) (st st))
      (if (null? ls)
          st
          (loop (cdr ls) ((dsp (car ls)) st))))))

(define (cat . ls) (apply-cat ls))

(define (fmt-null st) st)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; control structures

(define (fmt-if check pass . o)
  (let ((fail (if (pair? o) (car o) (lambda (x) x))))
    (lambda (st) (if (check st) ((dsp pass) st) ((dsp fail) st)))))

(define (fmt-try-fit proc . fail)
  (if (null? fail)
      proc
      (lambda (orig-st)
        (let ((width (fmt-width orig-st))
              (buffer '()))
          (call-with-current-continuation
            (lambda (return)
              (define (output* str st)
                (let lp ((i 0) (col (fmt-col st)))
                  (let ((nli (string-index str #\newline i)))
                    (if nli
                        (if (> (+ (- nli i) col) width)
                            (return ((apply fmt-try-fit fail) orig-st))
                            (lp (+ nli 1) 0))
                        (let* ((len ((or (fmt-string-width st) string-length)
                                     str))
                               (col (+ (- len i) col)))
                          (if (> col width)
                              (return ((apply fmt-try-fit fail) orig-st))
                              (begin
                                (set! buffer (cons str buffer))
                                (fmt-update str st))))))))
              (proc (fmt-set-port! (fmt-set-writer! (copy-fmt-state orig-st)
                                                    output*)
                                   (open-output-string)))
              ((fmt-writer orig-st)
               (string-concatenate-reverse buffer)
               orig-st)))))))

(define (fits-in-width gen width)
  (lambda (st)
    (let ((output (fmt-writer st))
          (port (open-output-string)))
      (call-with-current-continuation
        (lambda (return)
          (define (output* str st)
            (let ((st (fmt-update str st)))
              (if (> (fmt-col st) width)
                  (return #f)
                  (begin
                    (display str port)
                    st))))
          (gen (fmt-set-port! (fmt-set-writer! (copy-fmt-state st) output*)
                              port))
          (get-output-string port))))))

(define (fits-in-columns ls write width)
  (lambda (st)
    (let ((max-w (quotient width 2)))
      (let lp ((ls ls) (res '()) (widest 0))
        (cond
          ((pair? ls)
           (let ((str ((fits-in-width (write (car ls)) max-w) st)))
             (and str
                  (lp (cdr ls)
                      (cons str res)
                      (max ((or (fmt-string-width st) string-length) str)
                           widest)))))
          ((null? ls) (cons widest (reverse res)))
          (else #f))))))

(define (fmt-capture producer consumer)
  (lambda (st)
    (let ((port (open-output-string)))
      (producer (fmt-set-writer! (fmt-set-port! (copy-fmt-state st) port)
                                 fmt-write))
      ((consumer (get-output-string port)) st))))

(define (fmt-to-string producer)
  (fmt-capture producer (lambda (str) (lambda (st) str))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; standard formatters

(define (nl st)
  ((fmt-writer st) nl-str st))

;; output a newline iff we're not at the start of a fresh line
(define (fl st)
  (if (zero? (fmt-col st)) st (nl st)))

;; tab to a given tab-stop
(define (tab-to . o)
  (lambda (st)
    (let* ((tab-width (if (pair? o) (car o) 8))
           (rem (modulo (fmt-col st) tab-width)))
      (if (positive? rem)
          ((fmt-writer st)
           (make-string (- tab-width rem) (fmt-pad-char st))
           st)
          st))))

;; move to an explicit column
(define (space-to col)
  (lambda (st)
    (let ((width (- col (fmt-col st))))
      (if (positive? width)
          ((fmt-writer st) (make-string width (fmt-pad-char st)) st)
          st))))

(define (fmt-join fmt ls . o)
  (let ((sep (dsp (if (pair? o) (car o) ""))))
    (lambda (st)
      (if (null? ls)
          st
          (let lp ((ls (cdr ls))
                   (st ((fmt (car ls)) st)))
            (if (null? ls)
                st
                (lp (cdr ls) ((fmt (car ls)) (sep st)))))))))

(define (fmt-join/prefix fmt ls . o)
  (if (null? ls)
      fmt-null
      (let ((sep (dsp (if (pair? o) (car o) ""))))
        (cat sep (fmt-join fmt ls sep)))))
(define (fmt-join/suffix fmt ls . o)
  (if (null? ls)
      fmt-null
      (let ((sep (dsp (if (pair? o) (car o) ""))))
        (cat (fmt-join fmt ls sep) sep))))

(define (fmt-join/last fmt fmt/last ls . o)
  (let ((sep (dsp (if (pair? o) (car o) ""))))
    (lambda (st)
      (cond
        ((null? ls)
         st)
        ((null? (cdr ls))
         ((fmt/last (car ls)) (sep st)))
        (else
         (let lp ((ls (cdr ls))
                  (st ((fmt (car ls)) st)))
           (if (null? (cdr ls))
               ((fmt/last (car ls)) (sep st))
               (lp (cdr ls) ((fmt (car ls)) (sep st))))))))))

(define (fmt-join/dot fmt fmt/dot ls . o)
  (let ((sep (dsp (if (pair? o) (car o) ""))))
    (lambda (st)
      (cond
        ((pair? ls)
         (let lp ((ls (cdr ls))
                  (st ((fmt (car ls)) st)))
           (cond
             ((null? ls) st)
             ((pair? ls) (lp (cdr ls) ((fmt (car ls)) (sep st))))
             (else ((fmt/dot ls) (sep st))))))
        ((null? ls) st)
        (else ((fmt/dot ls) st))))))

(define (fmt-join/range fmt start . o)
  (let-optionals* o ((end #f) (sep ""))
    (lambda (st)
      (let lp ((i (+ start 1)) (st ((fmt start) st)))
        (if (and end (>= i end))
            st
            (lp (+ i 1) ((fmt i) ((dsp sep) st))))))))

(define (pad/both width . ls)
  (fmt-capture
   (apply-cat ls)
   (lambda (str)
     (lambda (st)
       (let ((diff (- width ((or (fmt-string-width st) string-length) str)))
             (output (fmt-writer st)))
         (if (positive? diff)
             (let* ((diff/2 (quotient diff 2))
                    (left (make-string diff/2 (fmt-pad-char st)))
                    (right (if (even? diff)
                               left
                               (make-string (+ 1 diff/2) (fmt-pad-char st)))))
               (output right (output str (output left st))))
             (output str st)))))))

(define (pad width . ls)
  (lambda (st)
    (let* ((col (fmt-col st))
           (padder
            (lambda (st)
              (let ((diff (- width (- (fmt-col st) col))))
                (if (positive? diff)
                    ((fmt-writer st) (make-string diff (fmt-pad-char st)) st)
                    st)))))
      ((cat (apply-cat ls) padder) st))))

(define pad/right pad)

(define (pad/left width . ls)
  (fmt-capture
   (apply-cat ls)
   (lambda (str)
     (lambda (st)
       (let* ((str-width ((or (fmt-string-width st) string-length) str))
              (diff (- width str-width)))
         ((fmt-writer st)
          str
          (if (positive? diff)
              ((fmt-writer st) (make-string diff (fmt-pad-char st)) st)
              st)))))))

(define (trim/buffered width fmt proc)
  (fmt-capture
   fmt
   (lambda (str)
     (lambda (st)
       (let* ((str-width ((or (fmt-string-width st) string-length) str))
              (diff (- str-width width)))
         ((fmt-writer st)
          (if (positive? diff)
              (proc str str-width diff st)
              str)
          st))))))

(define (trim width . ls)
  (lambda (st)
    (let ((ell (fmt-ellipses st)))
      (if ell
          ((trim/buffered
            width
            (apply-cat ls)
            (lambda (str str-width diff st)
              (let* ((ell (if (char? ell) (string ell) ell))
                     (ell-len (string-length ell))
                     (diff (- (+ str-width ell-len) width)))
                (if (negative? diff)
                    ell
                    (string-append
                     (substring/shared str 0 (- (string-length str) diff))
                     ell)))))
           st)
          (let ((output (fmt-writer st))
                (start-col (fmt-col st)))
            (call-with-current-continuation
              (lambda (return)
                (define (output* str st)
                  (let* ((len ((or (fmt-string-width st) string-length) str))
                         (diff (- (+ (- (fmt-col st) start-col) len) width)))
                    (if (positive? diff)
                        (return
                         (fmt-set-writer!
                          (output (substring/shared str 0 (- len diff)) st)
                          output))
                        (output str st))))
                ((fmt-let 'writer output* (apply-cat ls)) st))))))))

(define (trim/length width . ls)
  (lambda (st)
    (call-with-current-continuation
      (lambda (return)
        (let ((output (fmt-writer st))
              (sum 0))
          (define (output* str st)
            (let ((len (string-length str)))
              (set! sum (+ sum len))
              (if (> sum width)
                  (return
                   (fmt-set-writer!
                    (output (substring/shared str 0 (- len (- sum width))) st)
                    output))
                  (output str st))))
          ((fmt-let 'writer output* (apply-cat ls)) st))))))

(define (trim/left width . ls)
  (trim/buffered
   width
   (apply-cat ls)
   (lambda (str str-width diff st)
     (let ((ell (fmt-ellipses st)))
       (if ell
           (let* ((ell (if (char? ell) (string ell) ell))
                  (ell-len (string-length ell))
                  (diff (- (+ str-width ell-len) width)))
             (if (negative? diff)
                 ell
                 (string-append ell (substring/shared str diff))))
           (substring/shared str diff))))))

(define (trim/both width . ls)
  (trim/buffered
   width
   (apply-cat ls)
   (lambda (str str-width diff st)
     (let ((ell (fmt-ellipses st)))
       (if ell
           (let* ((ell (if (char? ell) (string ell) ell))
                  (ell-len (string-length ell))
                  (diff (- (+ str-width ell-len ell-len) width))
                  (left (quotient diff 2))
                  (right (- (string-length str) (quotient (+ diff 1) 2))))
             (if (negative? diff)
                 ell
                 (string-append ell (substring/shared str left right) ell)))
           (substring/shared str
                             (quotient (+ diff 1) 2)
                             (- (string-length str) (quotient diff 2))))))))

(define (fit width . ls)
  (pad width (trim width (apply-cat ls))))
(define (fit/left width . ls)
  (pad/left width (trim/left width (apply-cat ls))))
(define (fit/both width . ls)
  (pad/both width (trim/both width (apply-cat ls))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; String-map formatters

(define (make-string-fmt-transformer proc)
  (lambda ls
    (lambda (st)
      (let ((base-writer (fmt-writer st)))
        ((fmt-let
          'writer (lambda (str st) (base-writer (proc str) st))
          (apply-cat ls))
         st)))))

(define upcase (make-string-fmt-transformer string-upcase))
(define downcase (make-string-fmt-transformer string-downcase))
(define titlecase (make-string-fmt-transformer string-titlecase))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Numeric formatting

(define *min-e* -1024)
(define *bot-f* (expt 2 52))
;;(define *top-f* (* 2 *bot-f*))

(define (integer-log a base)
  (if (zero? a)
      0
      (inexact->exact (ceiling (/ (log (+ a 1)) (log base))))))
(define (integer-length* a)
  (if (negative? a)
      (integer-log (- 1 a) 2)
      (integer-log a 2)))

(define invlog2of
  (let ((table (make-vector 37))
        (log2 (log 2)))
    (do ((b 2 (+ b 1)))
        ((= b 37))
      (vector-set! table b (/ log2 (log b))))
    (lambda (b)
      (if (<= 2 b 36)
          (vector-ref table b)
          (/ log2 (log b))))))

(define fast-expt
  (let ((table (make-vector 326)))
    (do ((k 0 (+ k 1)) (v 1 (* v 10)))
        ((= k 326))
      (vector-set! table k v))
    (lambda (b k)
      (if (and (= b 10) (<= 0 k 326))
          (vector-ref table (inexact->exact (truncate k)))
          (expt b k)))))

(define (mirror-of c)
  (case c ((#\() #\)) ((#\[) #\]) ((#\{) #\}) ((#\<) #\>) (else c)))

(define default-digits
  (list->vector (string->list "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")))

;; kanji (10 included for base 11 ;)
;; (vector "�" "一" "二" "三" "四" "五" "六" "七" "八" "�" "�")

;; old style kanji:
;; (vector "零" "壱" "�" "�" "肆" "�" "陸" "柒" "�" "玖" "拾")

;; General algorithm based on "Printing Floating-Point Numbers Quickly
;; and Accurately" by Burger and Dybvig (FP-Printing-PLDI96.pdf).  The
;; code below will be hard to read out of that context until it's
;; cleaned up.

(define (num->string n st . opt)
  (call-with-output-string
    (lambda (port)
      (let-optionals* opt
          ((base (fmt-radix st))
           (digits (fmt-precision st))
           (sign? #f)
           (commify? #f)
           (comma-sep (and commify? (fmt-ref st 'comma-char #\,)))
           (decimal-sep (or (fmt-decimal-sep st)
                            (if (eqv? comma-sep #\.) #\, #\.)))
           (comma-rule (if (eq? commify? #t) 3 commify?))
           (align (fmt-decimal-align st))
           (digit-vec default-digits)
           (stack '()))

        (define (write-digit d)
          (display (vector-ref digit-vec (inexact->exact (truncate d))) port))

        ;; This is ugly because we need to keep a list of all output
        ;; of the form x9999... in case we get to the end of the
        ;; precision and need to round up.  Alas, if it weren't for
        ;; decimals and commas, we could just keep track of the last
        ;; non-9 digit and the number of nines seen, without any need
        ;; for a heap-allocated stack.
        (define (write-digit-list ls)
          (for-each
           (lambda (x) (if (number? x) (write-digit x) (display x port)))
           ls))

        (define (flush)
          (write-digit-list (reverse stack))
          (set! stack '()))

        (define (flush/rounded)
          (let lp ((ls stack) (res '()))
            (cond
             ((null? ls)
              (write-digit-list (cons #\1 res)))
             ((not (number? (car ls)))
              (lp (cdr ls) (cons (car ls) res)))
             ((= (car ls) (- base 1))
              (lp (cdr ls) (cons #\0 res)))
             (else
              (write-digit-list
               (append (reverse (cdr ls)) (cons (+ 1 (car ls)) res))))))
          (set! stack '()))

        (define (output digit)
          (if (and (number? digit) (< digit (- base 1)))
              (flush))
          (set! stack (cons digit stack)))

        (define (write-prefix prefix align k)
          (if align
              (let* ((prefix (cond ((string? prefix) prefix)
                                   ((char? prefix) (string prefix))
                                   (else "")))
                     (diff (- align
                              (+ (if (<= k 0) 1 k) (string-length prefix))
                              1)))
                (if (positive? diff)
                    (display (make-string diff (fmt-pad-char st)) port))
                (display prefix port))
              (if prefix (display prefix port)))) 

        (define (write-real n prefix align)

          (let* ((m+e (mantissa+exponent (exact->inexact n)))
                 (f (car m+e))
                 (e (cadr m+e))
                 (inv-base (invlog2of base))
                 (round? (even? f))
                 (smaller (if round? <= <))
                 (bigger (if round? >= >)))

            (define (pad d i) ;; just pad 0's, not #'s
              (write-digit d)
              (let lp ((i (- i 1)))
                (cond
                 ((>= i 0)
                  (if (and commify?
                           (if digits
                               (and (> i digits)
                                    (zero? (modulo (- i (- digits 1))
                                                   comma-rule)))
                               (and (positive? i)
                                    (zero? (modulo i comma-rule)))))
                      (display comma-sep port))
                  (if (= i (- digits 1))
                      (display decimal-sep port))
                  (write-digit 0)
                  (lp (- i 1))))))

            (define (pad-all d i)
              (cond
               ((>= d base)
                (flush/rounded))
               (else
                (flush)
                (write-digit d)))
              (let lp ((i (- i 1)))
                (cond
                 ((> i 0)
                  (if (and commify? (zero? (modulo i comma-rule)))
                      (display comma-sep port))
                  (write-digit 0)
                  (lp (- i 1)))
                 ((and (= i 0) (inexact? n))
                  (display decimal-sep port)
                  (write-digit 0)))))

            ;;(define (pad-sci d i k)
            ;;  (cond
            ;;   ((>= d base)
            ;;    (flush/rounded))
            ;;   (else
            ;;    (flush)
            ;;    (write-digit d)))
            ;;  (write-char #\e port)
            ;;  (cond
            ;;   ((positive? k)
            ;;    (write-char #\+ port)
            ;;    (write (- k 1) port))
            ;;   (else
            ;;    (write k port))))

            (define (scale r s m+ m- k f e)
              (let ((est (inexact->exact
                          (ceiling (- (* (+ e (integer-length* f) -1)
                                         (invlog2of base))
                                      1.0e-10)))))
                (if (not (negative? est))
                    (fixup r (* s (fast-expt base est)) m+ m- est)
                    (let ((skale (fast-expt base (- est))))
                      (fixup (* r skale) s (* m+ skale) (* m- skale) est)))))

            (define (fixup r s m+ m- k)
              (if (and (bigger (+ r m+) s)) ;; (or digits (>= k -4))
                  (lead r s m+ m- (+ k 1))
                  (lead (* r base) s (* m+ base) (* m- base) k)))

            (define (lead r s m+ m- k)
              (write-prefix prefix align k)
              (cond
               ((and (not digits) (or (> k 14) (< k -4)))
                (write n port))      ; XXXX native write for sci
               ;;((and (not digits) (> k 14))
               ;; (generate-sci r s m+ m- k))
               ;;((and (not digits) (< k -4))
               ;; (if (>= (/ r s) base)
               ;;     (generate-sci (/ r base) s (/ m+ base) (/ m- base) k)
               ;;     (generate-sci r s m+ m- k)))
               (else
                (cond
                 ((and (not digits)
                       (or (negative? k)
                           (and (zero? k) (not (integer? n)))))
                  (write-digit 0)
                  (display decimal-sep port)
                  (let lp ((i 0))
                    (cond ((> i k)
                           (write-digit 0)
                           (lp (- i 1)))))))
                (if digits
                    (generate-fixed r s m+ m- k)
                    (generate-all r s m+ m- k)))))

            (define (generate-all r s m+ m- k)
              (let gen ((r r) (m+ m+) (m- m-) (i k))
                (cond ((= i k))
                      ((zero? i)
                       (output decimal-sep))
                      ((and commify?
                            (positive? i)
                            (zero? (modulo i comma-rule)))
                       (output comma-sep)))
                (let ((d (quotient r s))
                      (r (remainder r s)))
                  (if (not (smaller r m-))
                      (cond
                       ((not (bigger (+ r m+) s))
                        (output d)
                        (gen (* r base) (* m+ base) (* m- base) (- i 1)))
                       (else
                        (pad-all (+ d 1) i)))
                      (if (not (bigger (+ r m+) s))
                          (pad-all d i)
                          (pad-all (if (< (* r 2) s) d (+ d 1)) i))))))

            (define (generate-fixed r s m+ m- k)
              (if (<= k 0) 
                  (set! stack (append (make-list (min (- k) digits) 0)
                                      (list decimal-sep 0))))
              (let ((i0 (- (+ k digits) 1)))
                (let gen ((r r) (m+ m+) (m- m-) (i i0))
                  (cond ((= i i0))
                        ((= i (- digits 1))
                         (output decimal-sep))
                        ((and commify?
                              (> i digits)
                              (zero? (modulo (- i (- digits 1))
                                             comma-rule)))
                         (output comma-sep)))
                  (let ((d (quotient r s))
                        (r (remainder r s)))
                    (cond
                     ((< i 0)
                      (let ((d2 (* 2 (if (>= (* r 2) s) (+ d 1) d))))
                        (if (and (not (> (- k) digits))
                                 (or (> d2 base)
                                     (and (= d2 base)
                                          (pair? stack)
                                          (number? (car stack))
                                          (odd? (car stack)))))
                            (flush/rounded)
                            (flush))))
                     ((smaller r m-)
                      (cond
                       ((>= d base)
                        (flush/rounded)
                        (pad 0 i))
                       (else
                        (flush)
                        (if (bigger (+ r m+) s)
                            (pad (if (< (* r 2) s) d (+ d 1)) i)
                            (pad d i)))))
                     ((bigger (+ r m+) s)
                      (cond
                       ((>= d (- base 1))
                        (flush/rounded)
                        (pad 0 i))
                       (else
                        (flush)
                        (pad (+ d 1) i))))
                     (else
                      (output d)
                      (gen (* r base) (* m+ base) (* m- base) (- i 1))))))))

            ;;(define (generate-sci r s m+ m- k)
            ;;  (let gen ((r r) (m+ m+) (m- m-) (i k))
            ;;    (cond ((= i (- k 1)) (display decimal-sep port)))
            ;;    (let ((d (quotient r s))
            ;;          (r (remainder r s)))
            ;;      (if (not (smaller r m-))
            ;;          (cond
            ;;           ((not (bigger (+ r m+) s))
            ;;            (output d)
            ;;            (gen (* r base) (* m+ base) (* m- base) (- i 1)))
            ;;           (else (pad-sci (+ d 1) i k)))
            ;;          (if (not (bigger (+ r m+) s))
            ;;              (pad-sci d i k)
            ;;              (pad-sci (if (< (* r 2) s) d (+ d 1)) i k))))))

            (cond
             ((negative? e)
              (if (or (= e *min-e*) (not (= f *bot-f*)))
                  (scale (* f 2) (* (expt 2.0 (- e)) 2) 1 1 0 f e)
                  (scale (* f 2 2) (* (expt 2.0 (- 1 e)) 2) 2 1 0 f e)))
             (else
              (if (= f *bot-f*)
                  (let ((be (expt 2 e)))
                    (scale (* f be 2) 2.0 be be 0 f e))
                  (let* ((be (expt 2 e)) (be1 (* be 2)))
                    (scale (* f be1 2) (* 2.0 2) be1 be 0 f e)))))))

        (define (write-fixed-rational p prefix align)
          (define (get-scale q) (expt base (- (integer-log q base) 1)))
          (let ((n (numerator p))
                (d (denominator p))
                (k (integer-log p base)))
            (write-prefix prefix align k)
            (let lp ((n n)
                     (i (- k)))
              (cond
               ((< i digits)
                (if (zero? i) (output decimal-sep))
                (let ((q (quotient n d)))
                  (cond
                   ((>= q base)
                    (let* ((scale (get-scale q))
                           (digit (quotient q scale))
                           (n2 (- n (* d digit scale))))
                      (output digit)
                      (lp n2 (+ i 1))))
                   (else
                    (output q)
                    (lp (* (remainder n d) base) (+ i 1))))))
               (else
                (let* ((q (quotient n d))
                       (digit
                        (* 2 (if (>= q base) (quotient q (get-scale q)) q))))
                  (if (or (> digit base)
                          (and (= digit base)
                               (let ((prev (find integer? stack)))
                                 (and prev (odd? prev)))))
                      (flush/rounded)
                      (flush))))))))

        (define (wrap-sign n sign? align writer)
          (cond
           ((negative? n)
            (cond
             ((char? sign?)
              (writer (abs n) sign? align)
              (display (mirror-of sign?) port))
             (else
              (writer (abs n) #\- align))))
           (else
            (cond
             ((and sign? (not (char? sign?)))
              (writer n #\+ align))
             (else
              (writer n #f align))))))

        (let ((imag (imag-part n)))
          (cond
           ((and base (not (and (integer? base) (<= 2 base 36))))
            (error "invalid base for numeric formatting" base))
           ((zero? imag)
            (cond
             ((and (exact? n) (not (integer? n)))
              (cond
               (digits
                (wrap-sign n sign? align write-fixed-rational))
               (else
                (wrap-sign (numerator n) sign? #f write-real)
                (write-char #\/ port)
                (wrap-sign (denominator n) #f #f write-real))))
             (else
              (wrap-sign n sign? align write-real))))
           (else (wrap-sign (real-part n) sign? #f write-real)
                 (wrap-sign imag #t #f write-real)
                 (write-char #\i port))))))))

(define (num n . opt)
  (lambda (st) ((fmt-writer st) (apply num->string n st opt) st)))

(define (num/comma n . o)
  (lambda (st)
    (let-optionals* o
        ((base (fmt-radix st))
         (digits (fmt-precision st))
         (sign? #f)
         (comma-rule 3)
         (comma-sep (fmt-ref st 'comma-char #\,))
         (decimal-sep (or (fmt-decimal-sep st)
                          (if (eqv? comma-sep #\.) #\, #\.))))
      ((num n base digits sign? comma-rule comma-sep decimal-sep) st))))

;; SI suffix formatting, as used in --human-readable options to some
;; GNU commands (such as ls).  See
;;
;;   http://www.bipm.org/en/si/si_brochure/chapter3/prefixes.html
;;   http://physics.nist.gov/cuu/Units/binary.html
;;
;; Note: lowercase "k" for base 10, uppercase "K" for base 2

(define num/si
  (let* ((names10 '#("" "k" "M" "G" "T" "E" "P" "Z" "Y"))
         (names2 (list->vector
                  (cons ""
                        (cons "Ki" (map (lambda (s) (string-append s "i"))
                                        (cddr (vector->list names10))))))))
    (lambda (n . o)
      (let-optionals* o ((base 1024)
                         (suffix "")
                         (names (if (= base 1024) names2 names10)))
        (let* ((k (min (inexact->exact (floor (/ (log n) (log base))))
                       (vector-length names)))
               (n2 (/ (round (* (/ n (expt base k)) 10)) 10)))
          (cat (if (integer? n2)
                   (number->string (inexact->exact n2))
                   (exact->inexact n2))
               (vector-ref names k)
               (if (zero? k) "" suffix)))))))

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

(define (num/old-roman num)
  (lambda (st)
    (let lp ((num num) (res '()))
      (if (positive? num)
          (let ((ch (find (lambda (x) (>= num (car x))) roman-numerals)))
            (lp (- num (car ch)) (cons (cdr ch) res)))
          (fmt-write (reverse-list->string res) st)))))

(define (num/roman num)
  (lambda (st)
    (let lp1 ((num num) (res '()))
      (if (positive? num)
          (let lp2 ((ls roman-numerals))
               (let* ((big (car ls))
                      (big-n (car big)))
                 (cond
                  ((>= num big-n)
                   (lp1 (- num big-n) (cons (cdr big) res)))
                  ((and (> (* 2 num) big-n)
                        (find (lambda (c)
                                (let ((x (car c)))
                                  (<= (+ x 1) (- big-n x) num)))
                              ls))
                   => (lambda (c)
                        (lp1 (- num (- big-n (car c)))
                             (cons (cdr big) (cons (cdr c) res)))))
                  (else
                   (lp2 (cdr ls))))))
          (fmt-write (reverse-list->string res) st)))))

;; Force a number into a fixed width, print as #'s if doesn't fit.
;; Needs to be wrapped in a PAD if you want to expand to the width.

(define (num/fit width n . args)
  (fmt-capture
   (apply num n args)
   (lambda (str)
     (lambda (st)
       (if (> (string-length str) width)
           (let ((prec (if (and (pair? args) (pair? (cdr args)))
                           (cadr args)
                           (fmt-precision st))))
             (if prec
                 (let* ((decimal-sep
                         (or (fmt-ref st 'decimal-sep)
                             (if (eqv? #\. (fmt-ref st 'comma-sep)) #\, #\.)))
                        (diff (- width (+ prec
                                          (if (char? decimal-sep)
                                              1
                                              (string-length decimal-sep))))))
                   ((cat (if (positive? diff) (make-string diff #\#) "")
                         decimal-sep (make-string prec #\#))
                    st))
                 ((fmt-writer st) (make-string width #\#) st)))
           ((fmt-writer st) str st))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; shared structure utilities

(define (eq?-table-ref tab x) (hash-table-ref/default tab x #f))
(define (eq?-table-set! tab x v) (hash-table-set! tab x v))

;; XXXX extend for records and other container data types
(define (make-shared-ref-table obj)
  (let ((tab (make-eq?-table))
        (res (make-eq?-table))
        (index 0))
    (let walk ((obj obj))
      (cond
        ((eq?-table-ref tab obj)
         => (lambda (i) (eq?-table-set! tab obj (+ i 1))))
        ((not (or (symbol? obj) (number? obj) (char? obj)
                  (boolean? obj) (null? obj) (eof-object? obj)))
         (eq?-table-set! tab obj 1)
         (cond
           ((pair? obj)
            (walk (car obj))
            (walk (cdr obj)))
           ((vector? obj)
            (let ((len (vector-length obj)))
              (do ((i 0 (+ i 1))) ((>= i len))
                (walk (vector-ref obj i)))))))))
    (hash-table-walk
     tab
     (lambda (obj count)
       (if (> count 1)
           (begin
             (eq?-table-set! res obj (cons index #f))
             (set! index (+ index 1))))))
    res))

(define (gen-shared-ref i suffix)
  (string-append "#" (number->string i) suffix))

(define (maybe-gen-shared-ref st cell shares)
  (cond
    ((pair? cell)
     (set-car! cell (cdr shares))
     (set-cdr! cell #t)
     (set-cdr! shares (+ (cdr shares) 1))
     ((fmt-writer st) (gen-shared-ref (car cell) "=") st))
    (else st)))

(define (call-with-shared-ref obj st shares proc)
  (let ((cell (eq?-table-ref (car shares) obj)))
    (if (and (pair? cell) (cdr cell))
        ((fmt-writer st) (gen-shared-ref (car cell) "#") st)
        (proc (maybe-gen-shared-ref st cell shares)))))

(define (call-with-shared-ref/cdr obj st shares proc sep)
  (let ((cell (eq?-table-ref (car shares) obj))
        (output (fmt-writer st)))
    (cond
      ((and (pair? cell) (cdr cell))
       (output (gen-shared-ref (car cell) "#") (output ". " (sep st))))
      ((pair? cell)
       (let ((st (maybe-gen-shared-ref (output ". " (sep st)) cell shares)))
         (output ")" (proc (output "(" st)))))
      (else
       (proc (sep st))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; sexp formatters

(define (slashified str . o)
  (let-optionals* o ((quot #\") (esc #\\) (rename (lambda (x) #f)))
    (lambda (st)
      (let* ((len (string-length str))
             (output (fmt-writer st))
             (quot-str (string quot))
             (esc-str (if (char? esc) (string esc) (or esc quot-str))))
        (let lp ((i 0) (j 0) (st st))
          (define (collect)
            (if (= i j) st (output (substring/shared str i j) st)))
          (if (>= j len)
              (collect)
              (let ((c (string-ref str j)))
                (cond
                  ((or (eqv? c quot) (eqv? c esc))
                   (lp j (+ j 1) (output esc-str (collect))))
                  ((rename c)
                   => (lambda (c2)
                        (lp (+ j 1)
                            (+ j 1)
                            (output c2 (output esc-str (collect))))))
                  (else
                   (lp i (+ j 1) st))))))))))

;; Only slashify if there are special characters, in which case also
;; wrap in quotes.  For writing symbols in |...| escapes, or CSV
;; fields, etc.  The predicate indicates which characters cause
;; slashification - this is in addition to automatic slashifying when
;; either the quote or escape char is present.

(define (maybe-slashified str pred . o)
  (let-optionals* o ((quot #\") (esc #\\) (rename (lambda (x) #f)))
    (define (esc? c) (or (eqv? c quot) (eqv? c esc) (rename c) (pred c)))
    (if (string-index str esc?)
        (cat quot (slashified str quot esc rename) quot)
        (dsp str))))

(define (fmt-write-string str)
  (define (rename c)
    (case c
      ((#\newline) "n")
      (else #f)))
  (slashified str #\" #\\ rename))

(define (dsp obj)
  (cond
    ((procedure? obj) obj)
    ((string? obj) (lambda (st) ((fmt-writer st) obj st)))
    ((char? obj) (dsp (string obj)))
    (else (wrt obj))))

(define (write-with-shares obj shares)
  (lambda (st)
    (let* ((output (fmt-writer st))
           (wr-num
            (cond ((and (= 10 (fmt-radix st))
                        (not (fmt-precision st))
                        (not (fmt-decimal-align st)))
                   (lambda (n st) (output (number->string n) st)))
                  ((assv (fmt-radix st)
                         '((16 . "#x") (10 . "") (8 . "#o") (2 . "#b")))
                   => (lambda (cell)
                        (let ((prefix (cdr cell)))
                          (lambda (n st) ((num n) (output prefix st))))))
                  (else (lambda (n st) (output (number->string n) st))))))
      (let wr ((obj obj) (st st))
        (call-with-shared-ref obj st shares
          (lambda (st)
            (cond
              ((pair? obj)
               (output
                ")"
                (let lp ((ls obj)
                         (st (output "(" st)))
                  (let ((st (wr (car ls) st))
                        (rest (cdr ls)))
                    (cond
                      ((null? rest) st)
                      ((pair? rest)
                       (call-with-shared-ref/cdr rest st shares
                         (lambda (st) (lp rest st))
                         (dsp " ")))
                      (else (wr rest (output " . " st))))))))
              ((vector? obj)
               (let ((len (vector-length obj)))
                 (if (zero? len)
                     (output "#()" st)
                     (let lp ((i 1)
                              (st
                               (wr (vector-ref obj 0)
                                   (output "#(" st))))
                       (if (>= i len)
                           (output ")" st)
                           (lp (+ i 1)
                               (wr (vector-ref obj i)
                                   (output " " st))))))))
              ((string? obj)
               (output "\"" ((fmt-write-string obj) (output "\"" st))))
              ((number? obj)
               (wr-num obj st))
              ((boolean? obj)
               (output (if obj "#t" "#f") st))
              (else
               (output (write-to-string obj) st)))))))))

(define (wrt obj)
  (write-with-shares obj (cons (make-shared-ref-table obj) 0)))

;; the only expensive part, in both time and memory, of handling
;; shared structures when writing is building the initial table, so
;; for the efficient version we just skip that

(define (wrt/unshared obj)
  (write-with-shares obj (cons (make-eq?-table) 0)))

;;;; fmt.scm -- extensible formatting library
;;
;; Copyright (c) 2006-2009 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

#!r6rs
(library (fmt fmt)
	 (export
	  new-fmt-state
	  fmt fmt-start fmt-if fmt-capture fmt-let fmt-bind fmt-null
	  fmt-ref fmt-set! fmt-add-properties! fmt-set-property!
	  fmt-col fmt-set-col! fmt-row fmt-set-row!
	  fmt-radix fmt-set-radix! fmt-precision fmt-set-precision!
	  fmt-properties fmt-set-properties! fmt-width fmt-set-width!
	  fmt-writer fmt-set-writer! fmt-port fmt-set-port!
	  fmt-decimal-sep fmt-set-decimal-sep!
	  fmt-file fmt-try-fit cat apply-cat nl fl nl-str
	  fmt-join fmt-join/last fmt-join/dot
	  fmt-join/prefix fmt-join/suffix fmt-join/range
	  pad pad/right pad/left pad/both trim trim/left trim/both trim/length
	  fit fit/left fit/both tab-to space-to wrt wrt/unshared dsp
	  pretty pretty/unshared slashified maybe-slashified
	  num num/si num/fit num/comma radix fix decimal-align ellipses
	  upcase downcase titlecase pad-char comma-char decimal-char
	  with-width wrap-lines fold-lines justify
	  make-string-fmt-transformer
	  make-space make-nl-space display-to-string write-to-string
	  fmt-columns columnar tabular line-numbers)
	 (import (chezscheme) 
		 (only (srfi s13 strings) string-count string-index
		       string-index-right 
		       string-concatenate string-concatenate-reverse  
		       substring/shared reverse-list->string string-tokenize
		       string-suffix? string-prefix?)
		 (srfi private let-opt)
		 (only (srfi s1 lists) fold length+))

	 (include "hash-compat.scm")
	 (include "mantissa.scm")
	 (include "read-line.scm")
	 (include "string-ports.scm")
	 (include "fmt.scm")
	 (include "fmt-column.scm")
	 (include "fmt-pretty.scm")
	 )

(define (make-eq?-table) (make-eq-hashtable))
(define hash-table-ref/default hashtable-ref)
(define hash-table-set! hashtable-set!)
(define hash-table-walk hash-table-for-each)

;;;; fmt-js.scm -- javascript formatting utilities
;;
;; Copyright (c) 2011-2012 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

#!r6rs
(library 
 (fmt js)
 (export
  js-expr js-function js-var js-comment js-array js-object js=== js>>>)
 
 (import (chezscheme)
	 (fmt fmt) (fmt c))
 
 (include "fmt-js.scm")
 
 )

;; Break a positive real number down to a normalized mantissa and
;; exponent. Default base=2, mant-size=52, exp-size=11 for IEEE doubles.


(define mantissa+exponent
  (case-lambda 
    [(num) (mantissa+exponent num 2)]
    [(num base) (mantissa+exponent num base 52)]
    [(num base mant-size) (mantissa+exponent num base mant-size 11)]
    [(num base mant-size exp-size)
     (if (zero? num)
	 (list 0 0)
	 (let* ((bot (expt base mant-size))
		(top (* base bot)))
	   (let lp ((n num) (e 0))
	     (cond
	      ((>= n top) (lp (quotient n base) (+ e 1)))
	      ((< n bot) (lp (* n base) (- e 1)))
	      (else (list n e))))))]))

(define (read-line . o)
  (let ((port (if (pair? o) (car o) (current-input-port))))
    (let lp ((res '()))
      (let ((c (read-char port)))
        (if (or (eof-object? c) (eqv? c #\newline))
            (list->string (reverse res))
            (lp (cons c res)))))))

(define (call-with-output-string f)
  (let ((port (open-output-string)))
    (let () (f port))
    (get-output-string port)))

(cond-expand
 (chicken (use test) (load "fmt-c-chicken.scm"))
 (gauche
  (use gauche.test)
  (use text.fmt)
  (use text.fmt.c)
  (define test-begin test-start)
  (define orig-test (with-module gauche.test test))
  (define-syntax test
    (syntax-rules ()
      ((test name expected expr)
       (orig-test name expected (lambda () expr)))
      ((test expected expr)
       (orig-test (let ((s (with-output-to-string (lambda () (write 'expr)))))
                    (substring s 0 (min 60 (string-length s))))
                  expected
                  (lambda () expr)))
      )))
 (else))

(cond-expand
 (chicken
  (import fmt fmt-c))
 (else))

(test-begin "fmt-c")

(test "if (1) {
    2;
} else {
    3;
}
"
    (fmt #f (c-if 1 2 3)))

(test "if (x ? y : z) {
    2;
} else {
    3;
}
"
    (fmt #f (c-if (c-if 'x 'y 'z) 2 3)))

(test "if (x ? y : z) {
    2;
} else {
    3;
}
"
    (fmt #f (c-expr '(if (if x y z) 2 3))))

(test "if (x ? y : z) {
    2;
} else {
    3;
}
"
    (fmt #f (c-expr '(%begin (if (if x y z) 2 3)))))

(test "int square (int x) {
    return x * x;
}
"
    (fmt #f (c-fun 'int 'square '((int x)) (c* 'x 'x))))

(test "int foo (int x, int y, int z) {
    if (x ? y : z) {
        return 2;
    } else {
        return 3;
    }
}
"
    (fmt #f (c-fun 'int 'foo '((int x) (int y) (int z))
                   (c-if (c-if 'x 'y 'z) 2 3))))

(test "void bar (int mode, const char *msg, unsigned int arg) {
    if (mode == 1) {
        printf(msg);
    } else {
        printf(msg, arg);
    }
}
"
    (fmt #f (c-fun 'void 'bar
                   '((int mode)
                     ((%pointer (const char)) msg)
                     ((unsigned int) arg))
                   (c-if (c== 'mode 1) '(printf msg) '(printf msg arg)))))

(test "while ((line = readline()) != EOF) {
    printf(\"%s\", line);
}
"
    (fmt #f (c-while (c!= (c= 'line '(readline)) 'EOF)
                     '(printf "%s" line))))

(test "switch (y) {
    case 1:
        x = 1;
        break;
    case 2:
        x = 4;
        break;
    default:
        x = 5;
        break;
}
"
    (fmt #f (c-switch 'y
                      (c-case 1 (c= 'x 1))
                      (c-case 2 (c= 'x 4))
                      (c-default (c= 'x 5)))))

(test "switch (y) {
    case 1:
        x = 1;
        break;
    case 2:
        x = 4;
    default:
        x = 5;
        break;
}
"
    (fmt #f (c-switch 'y
                      (c-case 1 (c= 'x 1))
                      (c-case/fallthrough 2 (c= 'x 4))
                      (c-default (c= 'x 5)))))

(test "switch (y) {
    case 1:
        x = 1;
        break;
    case 2:
        x = 4;
        break;
    default:
        x = 5;
        break;
}
"
    (fmt #f (c-switch 'y '((1) (= x 1)) '((2) (= x 4)) '(else (= x 5)))))

(test "switch (y) {
    case 1:
        x = 1;
        break;
    case 2:
        x = 4;
        break;
    default:
        x = 5;
        break;
}
"
    (fmt #f (c-expr '(switch y ((1) (= x 1)) ((2) (= x 4)) (else (= x 5))))))

(test "int q (int x) {
    switch (x) {
        case 1:
            return 1;
        case 2:
            return 4;
        default:
            return 5;
    }
}
"
    (fmt #f (c-fun 'int 'q '(x) (c-switch 'x '((1) 1) '((2) 4) '(else 5)))))

(test "switch (x) {
    case 1:
    case 2:
        foo();
        break;
    default:
        bar();
        break;
}
"
    (fmt #f (c-expr '(switch x ((1 2) (foo)) (else (bar))))))

(test "switch (x) {
    case 1:
        foo();
        break;
    case 2:
    case 3:
        bar();
        break;
    default:
        baz();
        break;
}
"
    (fmt #f (c-expr
             '(switch x (case 1 (foo)) (case (2 3) (bar)) (else (baz))))))

(test "switch (x) {
    case 1:
    case 2:
        foo();
    default:
        bar();
        break;
}
"
    (fmt #f (c-expr '(switch x (case/fallthrough (1 2) (foo)) (else (bar))))))

(test "switch (x) {
    case 1:
    case 2:
        foo();
        break;
    default:
        bar();
        break;
}
"
    (fmt #f (c-expr '(switch x ((1 2) (foo)) (default (bar))))))

(test "switch (x) {
    default:
        bar();
    case 1:
    case 2:
        foo();
        break;
}
"
    (fmt #f (c-expr '(switch x (else/fallthrough (bar)) ((1 2) (foo))))))

(test "for (i = 0; i < n; i++) {
    printf(\"i: %d\");
}
"
    (fmt #f (c-for (c= 'i 0) (c< 'i 'n) (c++/post 'i) '(printf "i: %d"))))

(test "a * x + b * y == c;\n"
    (fmt #f (c== (c+ (c* 'a 'x) (c* 'b 'y)) 'c)))
(test "a * x + b * y == c;\n"
    (fmt #f (c-expr '(== (+ (* a x) (* b y)) c))))

(test "(a + x) * (b + y) == c;\n"
    (fmt #f (c-expr '(== (* (+ a x) (+ b y)) c))))

(test
"(abracadabra!!!! + xylophone????)
  * (bananarama____ + yellowstonepark~~~~)
  * (cryptoanalysis + zebramania);\n"
    (fmt #f (c-expr '(* (+ abracadabra!!!! xylophone????)
                        (+ bananarama____ yellowstonepark~~~~)
                        (+ cryptoanalysis zebramania)))))

(test
"abracadabra(xylophone,
            bananarama,
            yellowstonepark,
            cryptoanalysis,
            zebramania,
            delightful,
            wubbleflubbery);\n"
    (fmt #f (c-expr '(abracadabra xylophone
                                  bananarama
                                  yellowstonepark
                                  cryptoanalysis
                                  zebramania
                                  delightful
                                  wubbleflubbery))))

(test "#define foo(x, y) (((x) + (y)))\n"
    (fmt #f (cpp-define '(foo (int x) (int y)) (c+ 'x 'y))))

(test "#define min(x, y) (((x) < (y)) ? (x) : (y))\n"
    (fmt #f (cpp-define '(min x y) (c-if (c< 'x 'y) 'x 'y))))

(test
"#define foo(x, y) (abracadabra(((x) + (y)), \\
                               xylophone, \\
                               bananarama, \\
                               yellowstonepark, \\
                               cryptoanalysis, \\
                               zebramania, \\
                               delightful, \\
                               wubbleflubbery))\n"
    (fmt #f (cpp-define '(foo x y)
                        '(abracadabra (+ x y)
                                      xylophone
                                      bananarama
                                      yellowstonepark
                                      cryptoanalysis
                                      zebramania
                                      delightful
                                      wubbleflubbery))))

(test "#ifndef FOO_H
#define FOO_H

extern int foo ();

#endif  /* ! FOO_H */
"
    (fmt #f (cpp-wrap-header
             'FOO_H
             (c-extern (c-prototype 'int 'foo '())))))

(test "#if foo
1
#elif bar
2
#elif baz
3
#else 
4
#endif
"
    (fmt #f (cpp-if 'foo 1 'bar 2 'baz 3 4)))

(test "/* this is a /\\* nested *\\/ comment */"
    (fmt #f (c-comment " this is a " (c-comment " nested ") " comment ")))

;; the initial leading space is annoying but hard to remove at the
;; moment - the important thing is we preserve indentation in the body
(test "switch (y) {
    case 1:
        x = 1;
        break;
    
#ifdef H_TWO
    case 2:
        x = 4;
        break;
#endif  /* H_TWO */
    default:
        x = 5;
        break;
}
"
    (fmt #f (c-expr
             `(switch y
                      ((1) (= x 1))
                      ,(cpp-ifdef 'H_TWO (c-case '(2) '(= x 4)))
                      (else (= x 5))))))

(test "#define eprintf(...) (fprintf(stderr, __VA_ARGS__))\n"
    (fmt #f (c-expr '(%define (eprintf . args) (fprintf stderr args)))))

(test "struct point {
    int x;
    int y;
};
"
    (fmt #f (c-expr `(struct point (x y)))))

(test "struct employee {
    short age;
    char *name;
    struct {
        int year;
        int month;
        int day;
    } dob;
} __attribute__ ((packed));
"
    (fmt #f (c-expr `(struct employee
                             ((short age)
                              ((%pointer char) name)
                              ((struct (year month day)) dob))
                             (%attribute packed)
                             ))))

(test "class employee {
    short age;
    char *name;
    struct {
        int year;
        int month;
        int day;
    } dob;
} __attribute__ ((packed));
"
    (fmt #f (c-class 'employee
                      '((short age)
                        ((%pointer char) name)
                        ((struct (year month day)) dob))
                      (c-attribute 'packed)
                      )))

(test "union object {
    char tag;
    struct {
        char tag;
        char *data;
    } string;
    struct {
        char tag;
        void *car;
        void *cdr;
    } pair;
    struct {
        char tag;
        unsigned int length;
        void *data;
    } vector;
};
"
    (fmt #f (c-expr
             '(union object
                     ((char tag)
                      ((struct ((char tag) ((* char) data))) string)
                      ((struct ((char tag)
                                ((* void) car)
                                ((* void) cdr)))
                       pair)
                      ((struct ((char tag)
                                ((unsigned int) length)
                                ((* void) data)))
                       vector)
                      )))))

(test "enum type_tags {
    TYPE_CHAR = 1,
    TYPE_FIXNUM,
    TYPE_BOOLEAN,
    TYPE_NULL,
    TYPE_EOF,
    TYPE_STRING,
    TYPE_PAIR,
    TYPE_VECTOR
};
"
    (fmt #f (c-expr '(enum type_tags ((TYPE_CHAR 1) TYPE_FIXNUM TYPE_BOOLEAN TYPE_NULL TYPE_EOF TYPE_STRING TYPE_PAIR TYPE_VECTOR)))))

(test "#define OP_EVAL 0xFE\n" (fmt #f (radix 16 (cpp-define 'OP_EVAL 254))))

(test "unsigned long table[SIZE] = {1, 2, 3, 4};\n"
    (fmt #f (c-var '(%array (unsigned long) SIZE) 'table '#(1 2 3 4))))

(test "int *array_of_ptr[];\n"
    (fmt #f (c-var '(%array (* int)) 'array_of_ptr)))

(test "int (*ptr_to_array)[];\n"
    (fmt #f (c-var '(* (%array int)) 'ptr_to_array)))

(test "foo **table = {{1, \"foo\"}, {2, \"bar\"}, {3, \"baz\"}, {4, \"qux\"}};\n"
    (fmt #f (c-var '(* (* foo)) 'table
                   '#(#(1 "foo") #(2 "bar") #(3 "baz") #(4 "qux")))))

(test "sexp (*f)(sexp, sexp) = NULL;\n"
    (fmt #f (c-var '(%fun sexp (sexp sexp)) 'f 'NULL)))

(test "sexp (*)(sexp) (*f)(sexp, sexp) = NULL;\n"
    (fmt #f (c-var '(%fun (%fun sexp (sexp)) (sexp sexp)) 'f 'NULL)))

(test "typedef double (*f)(double *, double, int);\n"
    (fmt #f (c-typedef '(%fun double ((* double) double int)) 'f)))

(test "\"foo\\tbar\";\n"
    (fmt #f (c-expr "foo\tbar")))

(test-end)

(cond-expand
 (chicken
  (load "fmt-js-chicken.scm"))
 (else))

(cond-expand
 (chicken
  (use test)
  (import fmt)
  (import fmt-js))
 (gauche
  (use gauche.test)
  (use text.fmt)
  (use text.fmt.js)
  (define test-begin test-start)
  (define orig-test (with-module gauche.test test))
  (define-syntax test
    (syntax-rules ()
      ((test name expected expr)
       (orig-test name expected (lambda () expr)))
      ((test expected expr)
       (orig-test (let ((s (with-output-to-string (lambda () (write 'expr)))))
                    (substring s 0 (min 60 (string-length s))))
                  expected
                  (lambda () expr)))
      )))
 (else))

(test-begin "fmt-js")

(test "var foo = 1 + 2;\n"
    (fmt #f (js-expr '(%var foo (+ 1 2)))))

(test "var foo = 1 + 2;\n"
    (fmt #f (js-expr '(%begin (%var foo (+ 1 2))))))

(test "function square(x) {
    return x * x;
}"
    (fmt #f (js-function 'square '(x) '(* x x))))

(test "{\"foo\": [1, 2, 3], \"bar\": \"baz\"}"
    (fmt #f (js-expr '(%object ("foo" . #(1 2 3)) ("bar" . "baz")))))

(test-end)

(cond-expand
 (chicken
  (load "fmt-chicken.scm"))
 (else))

(cond-expand
 (chicken
  (use test)
  (import fmt))
 (gauche
  (use gauche.test)
  (use text.fmt)
  (define test-begin test-start)
  (define orig-test (with-module gauche.test test))
  (define-syntax test
    (syntax-rules ()
      ((test name expected expr)
       (guard (e (else #f))
              (orig-test name expected (lambda () expr))))
      ((test expected expr)
       (test (let ((s (with-output-to-string (lambda () (write 'expr)))))
               (substring s 0 (min 60 (string-length s))))
             expected expr)))))
 (else))

(test-begin "fmt")

;; basic data types

(test "hi" (fmt #f "hi"))
(test "\"hi\"" (fmt #f (wrt "hi")))
(test "\"hi \\\"bob\\\"\"" (fmt #f (wrt "hi \"bob\"")))
(test "\"hello\\nworld\"" (fmt #f (wrt "hello\nworld")))
(test "ABC" (fmt #f (upcase "abc")))
(test "abc" (fmt #f (downcase "ABC")))
(test "Abc" (fmt #f (titlecase "abc")))

(test "abc     def" (fmt #f "abc" (tab-to) "def"))
(test "abc  def" (fmt #f "abc" (tab-to 5) "def"))
(test "abcdef" (fmt #f "abc" (tab-to 3) "def"))

(test "-1" (fmt #f -1))
(test "0" (fmt #f 0))
(test "1" (fmt #f 1))
(test "10" (fmt #f 10))
(test "100" (fmt #f 100))
(test "-1" (fmt #f (num -1)))
(test "0" (fmt #f (num 0)))
(test "1" (fmt #f (num 1)))
(test "10" (fmt #f (num 10)))
(test "100" (fmt #f (num 100)))
;; (test "1e+15" (fmt #f (num 1e+15)))
;; (test "1e+23" (fmt #f (num 1e+23)))
;; (test "1.2e+23" (fmt #f (num 1.2e+23)))
;; (test "1e-5" (fmt #f (num 1e-5)))
;; (test "1e-6" (fmt #f (num 1e-6)))
;; (test "1e-7" (fmt #f (num 1e-7)))
;; (test "2e-6" (fmt #f (num 2e-6)))
(test "57005" (fmt #f #xDEAD))
(test "#xDEAD" (fmt #f (radix 16 #xDEAD)))
(test "#xDEAD1234" (fmt #f (radix 16 #xDEAD) 1234))
(test "#xDE.AD" (fmt #f (radix 16 (exact->inexact (/ #xDEAD #x100)))))
(test "#xD.EAD" (fmt #f (radix 16 (exact->inexact (/ #xDEAD #x1000)))))
(test "#x0.DEAD" (fmt #f (radix 16 (exact->inexact (/ #xDEAD #x10000)))))
(test "1G" (fmt #f (radix 17 (num 33))))
(test "1G" (fmt #f (num 33 17)))

(test "3.14159" (fmt #f 3.14159))
(test "3.14" (fmt #f (fix 2 3.14159)))
(test "3.14" (fmt #f (fix 2 3.14)))
(test "3.00" (fmt #f (fix 2 3.)))
(test "1.10" (fmt #f (num 1.099 10 2)))
(test "0.00" (fmt #f (fix 2 1e-17)))
(test "0.0000000000" (fmt #f (fix 10 1e-17)))
(test "0.00000000000000001000" (fmt #f (fix 20 1e-17)))
;; (test-error (fmt #f (num 1e-17 0)))
(test "0.000004" (fmt #f (num 0.000004 10 6)))
(test "0.0000040" (fmt #f (num 0.000004 10 7)))
(test "0.00000400" (fmt #f (num 0.000004 10 8)))
;; (test "0.000004" (fmt #f (num 0.000004)))

(test "   3.14159" (fmt #f (decimal-align 5 (num 3.14159))))
(test "  31.4159" (fmt #f (decimal-align 5 (num 31.4159))))
(test " 314.159" (fmt #f (decimal-align 5 (num 314.159))))
(test "3141.59" (fmt #f (decimal-align 5 (num 3141.59))))
(test "31415.9" (fmt #f (decimal-align 5 (num 31415.9))))
(test "  -3.14159" (fmt #f (decimal-align 5 (num -3.14159))))
(test " -31.4159" (fmt #f (decimal-align 5 (num -31.4159))))
(test "-314.159" (fmt #f (decimal-align 5 (num -314.159))))
(test "-3141.59" (fmt #f (decimal-align 5 (num -3141.59))))
(test "-31415.9" (fmt #f (decimal-align 5 (num -31415.9))))

(cond
 ((exact? (/ 1 3)) ;; exact rationals
  (test "333.333333333333333333333333333333" (fmt #f (fix 30 1000/3)))
  (test  "33.333333333333333333333333333333" (fmt #f (fix 30 100/3)))
  (test   "3.333333333333333333333333333333" (fmt #f (fix 30 10/3)))
  (test   "0.333333333333333333333333333333" (fmt #f (fix 30 1/3)))
  (test   "0.033333333333333333333333333333" (fmt #f (fix 30 1/30)))
  (test   "0.003333333333333333333333333333" (fmt #f (fix 30 1/300)))
  (test   "0.000333333333333333333333333333" (fmt #f (fix 30 1/3000)))
  (test   "0.666666666666666666666666666667" (fmt #f (fix 30 2/3)))
  (test   "0.090909090909090909090909090909" (fmt #f (fix 30 1/11)))
  (test   "1.428571428571428571428571428571" (fmt #f (fix 30 10/7)))
  (test "0.123456789012345678901234567890"
      (fmt #f (fix 30 (/  123456789012345678901234567890
                         1000000000000000000000000000000))))
  (test  " 333.333333333333333333333333333333" (fmt #f (decimal-align 5 (fix 30 1000/3))))
  (test  "  33.333333333333333333333333333333" (fmt #f (decimal-align 5 (fix 30 100/3))))
  (test  "   3.333333333333333333333333333333" (fmt #f (decimal-align 5 (fix 30 10/3))))
  (test  "   0.333333333333333333333333333333" (fmt #f (decimal-align 5 (fix 30 1/3))))
  ))

(test "11.75" (fmt #f (num (/ 47 4) 10 2)))
(test "-11.75" (fmt #f (num (/ -47 4) 10 2)))

(test "(#x11 #x22 #x33)" (fmt #f (radix 16 '(#x11 #x22 #x33))))

(test "299,792,458" (fmt #f (num 299792458 10 #f #f #t)))
(test "299,792,458" (fmt #f (num/comma 299792458)))
(test "299.792.458" (fmt #f (comma-char #\. (num/comma 299792458))))
(test "299.792.458,0" (fmt #f (comma-char #\. (num/comma 299792458.0))))

(test "100,000" (fmt #f (num 100000 10 0 #f 3)))
(test "100,000.0" (fmt #f (num 100000 10 1 #f 3)))
(test "100,000.00" (fmt #f (num 100000 10 2 #f 3)))

(test "1.23" (fmt #f (fix 2 (num/fit 4 1.2345))))
(test "1.00" (fmt #f (fix 2 (num/fit 4 1))))
(test "#.##" (fmt #f (fix 2 (num/fit 4 12.345))))

;; (cond
;;  ((feature? 'full-numeric-tower)
;;   (test "1+2i" (fmt #f (string->number "1+2i")))
;;   (test "1+2i" (fmt #f (num (string->number "1+2i"))))
;;   (test "1.00+2.00i" (fmt #f (fix 2 (num (string->number "1+2i")))))
;;   (test "3.14+2.00i" (fmt #f (fix 2 (num (string->number "3.14159+2i")))))))

(test "3.9Ki" (fmt #f (num/si 3986)))
(test "4k" (fmt #f (num/si 3986 1000)))
(test "608" (fmt #f (num/si 608)))
(test "3G" (fmt #f (num/si 12345.12355 16)))

;; padding/trimming

(test "abc  " (fmt #f (pad 5 "abc")))
(test "  abc" (fmt #f (pad/left 5 "abc")))
(test " abc " (fmt #f (pad/both 5 "abc")))
(test "abcde" (fmt #f (pad 5 "abcde")))
(test "abcdef" (fmt #f (pad 5 "abcdef")))

(test "abc" (fmt #f (trim 3 "abcde")))
(test "abc" (fmt #f (trim/length 3 "abcde")))
(test "abc" (fmt #f (trim/length 3 "abc\nde")))
(test "cde" (fmt #f (trim/left 3 "abcde")))
(test "bcd" (fmt #f (trim/both 3 "abcde")))

(test "prefix: abc" (fmt #f "prefix: " (trim 3 "abcde")))
(test "prefix: abc" (fmt #f "prefix: " (trim/length 3 "abcde")))
(test "prefix: abc" (fmt #f "prefix: " (trim/length 3 "abc\nde")))
(test "prefix: cde" (fmt #f "prefix: " (trim/left 3 "abcde")))
(test "prefix: bcd" (fmt #f "prefix: " (trim/both 3 "abcde")))

(test "abcde" (fmt #f (ellipses "..." (trim 5 "abcde"))))
(test "ab..." (fmt #f (ellipses "..." (trim 5 "abcdef"))))
(test "abc..." (fmt #f (ellipses "..." (trim 6 "abcdefg"))))
(test "abcde" (fmt #f (ellipses "..." (trim/left 5 "abcde"))))
(test "...ef" (fmt #f (ellipses "..." (trim/left 5 "abcdef"))))
(test "...efg" (fmt #f (ellipses "..." (trim/left 6 "abcdefg"))))
(test "abcdefg" (fmt #f (ellipses "..." (trim/both 7 "abcdefg"))))
(test "...d..." (fmt #f (ellipses "..." (trim/both 7 "abcdefgh"))))
(test "...e..." (fmt #f (ellipses "..." (trim/both 7 "abcdefghi"))))

(test "abc  " (fmt #f (fit 5 "abc")))
(test "  abc" (fmt #f (fit/left 5 "abc")))
(test " abc " (fmt #f (fit/both 5 "abc")))
(test "abcde" (fmt #f (fit 5 "abcde")))
(test "abcde" (fmt #f (fit/left 5 "abcde")))
(test "abcde" (fmt #f (fit/both 5 "abcde")))
(test "abcde" (fmt #f (fit 5 "abcdefgh")))
(test "defgh" (fmt #f (fit/left 5 "abcdefgh")))
(test "cdefg" (fmt #f (fit/both 5 "abcdefgh")))

(test "prefix: abc  " (fmt #f "prefix: " (fit 5 "abc")))
(test "prefix:   abc" (fmt #f "prefix: " (fit/left 5 "abc")))
(test "prefix:  abc " (fmt #f "prefix: " (fit/both 5 "abc")))
(test "prefix: abcde" (fmt #f "prefix: " (fit 5 "abcde")))
(test "prefix: abcde" (fmt #f "prefix: " (fit/left 5 "abcde")))
(test "prefix: abcde" (fmt #f "prefix: " (fit/both 5 "abcde")))
(test "prefix: abcde" (fmt #f "prefix: " (fit 5 "abcdefgh")))
(test "prefix: defgh" (fmt #f "prefix: " (fit/left 5 "abcdefgh")))
(test "prefix: cdefg" (fmt #f "prefix: " (fit/both 5 "abcdefgh")))

(test "abc\n123\n" (fmt #f (fmt-join/suffix (cut trim 3 <>) (string-split "abcdef\n123456\n" "\n") nl)))

;; utilities

(test "1 2 3" (fmt #f (fmt-join dsp '(1 2 3) " ")))

;; shared structures

(test "#0=(1 . #0#)"
    (fmt #f (wrt (let ((ones (list 1))) (set-cdr! ones ones) ones))))
(test "(0 . #0=(1 . #0#))"
    (fmt #f (wrt (let ((ones (list 1)))
                   (set-cdr! ones ones)
                   (cons 0 ones)))))
(test "(sym . #0=(sym . #0#))"
    (fmt #f (wrt (let ((syms (list 'sym)))
                   (set-cdr! syms syms)
                   (cons 'sym syms)))))
(test "(#0=(1 . #0#) #1=(2 . #1#))"
    (fmt #f (wrt (let ((ones (list 1))
                       (twos (list 2)))
                   (set-cdr! ones ones)
                   (set-cdr! twos twos)
                   (list ones twos)))))

;; without shared detection

(test "(1 1 1 1 1"
    (fmt #f (trim/length
             10
             (wrt/unshared
              (let ((ones (list 1))) (set-cdr! ones ones) ones)))))

(test "(1 1 1 1 1 "
    (fmt #f (trim/length
             11
             (wrt/unshared
              (let ((ones (list 1))) (set-cdr! ones ones) ones)))))

;; pretty printing

;; (define-macro (test-pretty str)
;;   (let ((sexp (with-input-from-string str read)))
;;     `(test ,str (fmt #f (pretty ',sexp)))))

(define-syntax test-pretty
  (syntax-rules ()
    ((test-pretty str)
     (let ((sexp (with-input-from-string str read)))
       (test str (fmt #f (pretty sexp)))))))

(test-pretty "(foo bar)\n")

(test-pretty
"((self . aquanet-paper-1991)
 (type . paper)
 (title . \"Aquanet: a hypertext tool to hold your\"))
")

(test-pretty
"(abracadabra xylophone
             bananarama
             yellowstonepark
             cryptoanalysis
             zebramania
             delightful
             wubbleflubbery)\n")

(test-pretty
 "#(0  1  2  3  4  5  6  7  8  9  10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
   25 26 27 28 29 30 31 32 33 34 35 36 37)\n")

(test-pretty
 "(0  1  2  3  4  5  6  7  8  9  10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
  25 26 27 28 29 30 31 32 33 34 35 36 37)\n")

(test-pretty
 "(define (fold kons knil ls)
  (define (loop ls acc)
    (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc))))
  (loop ls knil))\n")

(test-pretty
"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i))\n")

(test-pretty
"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec)
  (vector-set! vec i 'supercalifrajalisticexpialidocious))\n")

(test-pretty
"(do ((my-vector (make-vector 5)) (index 0 (+ index 1)))
    ((= index 5) my-vector)
  (vector-set! my-vector index index))\n")

(test-pretty
 "(define (fold kons knil ls)
  (let loop ((ls ls) (acc knil))
    (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc)))))\n")

(test-pretty
 "(define (file->sexp-list pathname)
  (call-with-input-file pathname
    (lambda (port)
      (let loop ((res '()))
        (let ((line (read port)))
          (if (eof-object? line) (reverse res) (loop (cons line res))))))))\n")

(test "(let ((ones '#0=(1 . #0#))) ones)\n"
    (fmt #f (pretty (let ((ones (list 1))) (set-cdr! ones ones) `(let ((ones ',ones)) ones)))))

'(test
"(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
      (ones '#0=(1 . #0#)))
  (append zeros ones))\n"
    (fmt #f (pretty
             (let ((ones (list 1)))
               (set-cdr! ones ones)
               `(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
                      (ones ',ones))
                  (append zeros ones))))))

;; slashify

(test "\"note\",\"very simple\",\"csv\",\"writer\",\"\"\"yay!\"\"\""
    (fmt #f (fmt-join (lambda (x) (cat "\"" (slashified x #\" #f) "\""))
                  '("note" "very simple" "csv" "writer" "\"yay!\"")
                  ",")))

(test "note,\"very simple\",csv,writer,\"\"\"yay!\"\"\""
    (fmt #f (fmt-join (cut maybe-slashified <> char-whitespace? #\" #f)
                  '("note" "very simple" "csv" "writer" "\"yay!\"")
                  ",")))

;; columnar formatting

(test "abc\ndef\n" (fmt #f (fmt-columns (list dsp "abc\ndef\n"))))
(test "abc123\ndef456\n" (fmt #f (fmt-columns (list dsp "abc\ndef\n") (list dsp "123\n456\n"))))
(test "abc123\ndef456\n" (fmt #f (fmt-columns (list dsp "abc\ndef\n") (list dsp "123\n456"))))
(test "abc123\ndef456\n" (fmt #f (fmt-columns (list dsp "abc\ndef") (list dsp "123\n456\n"))))
(test "abc123\ndef456\nghi789\n"
    (fmt #f (fmt-columns (list dsp "abc\ndef\nghi\n") (list dsp "123\n456\n789\n"))))
(test "abc123wuv\ndef456xyz\n"
    (fmt #f (fmt-columns (list dsp "abc\ndef\n") (list dsp "123\n456\n") (list dsp "wuv\nxyz\n"))))
(test "abc  123\ndef  456\n"
    (fmt #f (fmt-columns (list (cut pad/right 5 <>) "abc\ndef\n") (list dsp "123\n456\n"))))
(test "ABC  123\nDEF  456\n"
    (fmt #f (fmt-columns (list (compose upcase (cut pad/right 5 <>)) "abc\ndef\n")
                         (list dsp "123\n456\n"))))
(test "ABC  123\nDEF  456\n"
    (fmt #f (fmt-columns (list (compose (cut pad/right 5 <>) upcase) "abc\ndef\n")
                         (list dsp "123\n456\n"))))

(test "hello\nworld\n" (fmt #f (with-width 8 (wrap-lines "hello world"))))
(test "\n" (fmt #f (wrap-lines "    ")))

(test          ;; test divide by zero error
 "The  quick
brown  fox
jumped
over   the
lazy dog
"
 (fmt #f (with-width 10 (justify "The quick brown fox jumped over the lazy dog"))))

(test "his message
(http://lists.nongnu.org/archive/html/chicken-users/2010-10/msg00171.html)
to the chicken-users
(http://lists.nongnu.org/mailman/listinfo/chicken-users)\n"
      (fmt #f (with-width 67 (wrap-lines "his message (http://lists.nongnu.org/archive/html/chicken-users/2010-10/msg00171.html) to the chicken-users (http://lists.nongnu.org/mailman/listinfo/chicken-users)"))))

(test "The fundamental list iterator.
Applies KONS to each element of
LS and the result of the previous
application, beginning with KNIL.
With KONS as CONS and KNIL as '(),
equivalent to REVERSE.
"
    (fmt #f (with-width 36 (wrap-lines "The fundamental list iterator.  Applies KONS to each element of LS and the result of the previous application, beginning with KNIL.  With KONS as CONS and KNIL as '(), equivalent to REVERSE."))))

(test
"The   fundamental   list   iterator.
Applies  KONS  to  each  element  of
LS  and  the  result of the previous
application,  beginning  with  KNIL.
With  KONS  as CONS and KNIL as '(),
equivalent to REVERSE.
"
    (fmt #f (with-width 36 (justify "The fundamental list iterator.  Applies KONS to each element of LS and the result of the previous application, beginning with KNIL.  With KONS as CONS and KNIL as '(), equivalent to REVERSE."))))

(test
"(define (fold kons knil ls)          ; The fundamental list iterator.
  (let lp ((ls ls) (acc knil))       ; Applies KONS to each element of
    (if (null? ls)                   ; LS and the result of the previous
        acc                          ; application, beginning with KNIL.
        (lp (cdr ls)                 ; With KONS as CONS and KNIL as '(),
            (kons (car ls) acc)))))  ; equivalent to REVERSE.
"
    (fmt #f (fmt-columns
             (list
              (cut pad/right 36 <>)
              (with-width 36
                (pretty '(define (fold kons knil ls)
                           (let lp ((ls ls) (acc knil))
                             (if (null? ls)
                                 acc
                                 (lp (cdr ls)
                                     (kons (car ls) acc))))))))
             (list
              (cut cat " ; " <>)
              (with-width 36
                (wrap-lines "The fundamental list iterator.  Applies KONS to each element of LS and the result of the previous application, beginning with KNIL.  With KONS as CONS and KNIL as '(), equivalent to REVERSE."))))))

(test
"(define (fold kons knil ls)          ; The fundamental list iterator.
  (let lp ((ls ls) (acc knil))       ; Applies KONS to each element of
    (if (null? ls)                   ; LS and the result of the previous
        acc                          ; application, beginning with KNIL.
        (lp (cdr ls)                 ; With KONS as CONS and KNIL as '(),
            (kons (car ls) acc)))))  ; equivalent to REVERSE.
"
    (fmt #f (with-width 76
              (columnar
               (pretty '(define (fold kons knil ls)
                          (let lp ((ls ls) (acc knil))
                            (if (null? ls)
                                acc
                                (lp (cdr ls)
                                    (kons (car ls) acc))))))
               " ; "
               (wrap-lines "The fundamental list iterator.  Applies KONS to each element of LS and the result of the previous application, beginning with KNIL.  With KONS as CONS and KNIL as '(), equivalent to REVERSE.")))))

(test
"- Item 1: The text here is
          indented according
          to the space \"Item
          1\" takes, and one
          does not known what
          goes here.
"
    (fmt #f (columnar 9 (dsp "- Item 1:") " " (with-width 20 (wrap-lines "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here.")))))

(test
"- Item 1: The text here is
          indented according
          to the space \"Item
          1\" takes, and one
          does not known what
          goes here.
"
    (fmt #f (columnar 9 (dsp "- Item 1:\n") " " (with-width 20 (wrap-lines "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here.")))))

(test
"- Item 1: The text here is----------------------------------------------------
--------- indented according--------------------------------------------------
--------- to the space \"Item--------------------------------------------------
--------- 1\" takes, and one---------------------------------------------------
--------- does not known what-------------------------------------------------
--------- goes here.----------------------------------------------------------
"
    (fmt #f (pad-char #\- (columnar 9 (dsp "- Item 1:\n") " " (with-width 20 (wrap-lines "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here."))))))

(test
"a   | 123
bc  | 45
def | 6
"
    (fmt #f (with-width
             20
             (tabular (dsp "a\nbc\ndef\n") " | " (dsp "123\n45\n6\n")))))

;; misc extras

(define (string-hide-passwords str)
  (string-substitute (regexp "(pass(?:w(?:or)?d)?\\s?[:=>]\\s+)\\S+" #t)
                     "\\1******"
                     str
                     #t))

(define hide-passwords
  (make-string-fmt-transformer string-hide-passwords))

(define (string-mangle-email str)
  (string-substitute
   (regexp "\\b([-+.\\w]+)@((?:[-+\\w]+\\.)+[a-z]{2,4})\\b" #t)
   "\\1 _at_ \\2"
   str
   #t))

(define mangle-email
  (make-string-fmt-transformer string-mangle-email))

(test-end)

(use fmt test)
;;(use numbers) ; test with and without numbers via -R numbers

(define (check-representation n)
  (define pence
    (inexact->exact (round (/ (modulo n 1000) 10))))
  (define pounds (quotient n 1000))

  (if (> pence 99)
      (begin
        (set! pence (- 100 pence))
        (set! pounds (add1 pounds))))

  (define expected-result
    (cond
     ((= pence 0) (sprintf "~S.00" pounds))
     ((< pence 10) (sprintf "~S.0~S" pounds pence))
     (else (sprintf "~S.~S" pounds pence))))

  (test (sprintf "~S = ~S?" (exact->inexact (/ n 1000)) expected-result)
      expected-result
    (fmt #f (num (/ n 1000) 10 2))))

(test-begin)
(for-each check-representation (iota 10000))
(test-end)

;;;; match.scm -- portable hygienic pattern matcher -*- coding: utf-8 -*-
;;
;; This code is written by Alex Shinn and placed in the
;; Public Domain.  All warranties are disclaimed.

;;> \example-import[(srfi 9)]

;;> A portable hygienic pattern matcher.

;;> This is a full superset of the popular \hyperlink[
;;> "http://www.cs.indiana.edu/scheme-repository/code.match.html"]{match}
;;> package by Andrew Wright, written in fully portable \scheme{syntax-rules}
;;> and thus preserving hygiene.

;;> The most notable extensions are the ability to use \emph{non-linear}
;;> patterns - patterns in which the same identifier occurs multiple
;;> times, tail patterns after ellipsis, and the experimental tree patterns.

;;> \section{Patterns}

;;> Patterns are written to look like the printed representation of
;;> the objects they match.  The basic usage is

;;> \scheme{(match expr (pat body ...) ...)}

;;> where the result of \var{expr} is matched against each pattern in
;;> turn, and the corresponding body is evaluated for the first to
;;> succeed.  Thus, a list of three elements matches a list of three
;;> elements.

;;> \example{(let ((ls (list 1 2 3))) (match ls ((1 2 3) #t)))}

;;> If no patterns match an error is signalled.

;;> Identifiers will match anything, and make the corresponding
;;> binding available in the body.

;;> \example{(match (list 1 2 3) ((a b c) b))}

;;> If the same identifier occurs multiple times, the first instance
;;> will match anything, but subsequent instances must match a value
;;> which is \scheme{equal?} to the first.

;;> \example{(match (list 1 2 1) ((a a b) 1) ((a b a) 2))}

;;> The special identifier \scheme{_} matches anything, no matter how
;;> many times it is used, and does not bind the result in the body.

;;> \example{(match (list 1 2 1) ((_ _ b) 1) ((a b a) 2))}

;;> To match a literal identifier (or list or any other literal), use
;;> \scheme{quote}.

;;> \example{(match 'a ('b 1) ('a 2))}

;;> Analogous to its normal usage in scheme, \scheme{quasiquote} can
;;> be used to quote a mostly literally matching object with selected
;;> parts unquoted.

;;> \example|{(match (list 1 2 3) (`(1 ,b ,c) (list b c)))}|

;;> Often you want to match any number of a repeated pattern.  Inside
;;> a list pattern you can append \scheme{...} after an element to
;;> match zero or more of that pattern (like a regexp Kleene star).

;;> \example{(match (list 1 2) ((1 2 3 ...) #t))}
;;> \example{(match (list 1 2 3) ((1 2 3 ...) #t))}
;;> \example{(match (list 1 2 3 3 3) ((1 2 3 ...) #t))}

;;> Pattern variables matched inside the repeated pattern are bound to
;;> a list of each matching instance in the body.

;;> \example{(match (list 1 2) ((a b c ...) c))}
;;> \example{(match (list 1 2 3) ((a b c ...) c))}
;;> \example{(match (list 1 2 3 4 5) ((a b c ...) c))}

;;> More than one \scheme{...} may not be used in the same list, since
;;> this would require exponential backtracking in the general case.
;;> However, \scheme{...} need not be the final element in the list,
;;> and may be succeeded by a fixed number of patterns.

;;> \example{(match (list 1 2 3 4) ((a b c ... d e) c))}
;;> \example{(match (list 1 2 3 4 5) ((a b c ... d e) c))}
;;> \example{(match (list 1 2 3 4 5 6 7) ((a b c ... d e) c))}

;;> \scheme{___} is provided as an alias for \scheme{...} when it is
;;> inconvenient to use the ellipsis (as in a syntax-rules template).

;;> The \scheme{..1} syntax is exactly like the \scheme{...} except
;;> that it matches one or more repetitions (like a regexp "+").

;;> \example{(match (list 1 2) ((a b c ..1) c))}
;;> \example{(match (list 1 2 3) ((a b c ..1) c))}

;;> The boolean operators \scheme{and}, \scheme{or} and \scheme{not}
;;> can be used to group and negate patterns analogously to their
;;> Scheme counterparts.

;;> The \scheme{and} operator ensures that all subpatterns match.
;;> This operator is often used with the idiom \scheme{(and x pat)} to
;;> bind \var{x} to the entire value that matches \var{pat}
;;> (c.f. "as-patterns" in ML or Haskell).  Another common use is in
;;> conjunction with \scheme{not} patterns to match a general case
;;> with certain exceptions.

;;> \example{(match 1 ((and) #t))}
;;> \example{(match 1 ((and x) x))}
;;> \example{(match 1 ((and x 1) x))}

;;> The \scheme{or} operator ensures that at least one subpattern
;;> matches.  If the same identifier occurs in different subpatterns,
;;> it is matched independently.  All identifiers from all subpatterns
;;> are bound if the \scheme{or} operator matches, but the binding is
;;> only defined for identifiers from the subpattern which matched.

;;> \example{(match 1 ((or) #t) (else #f))}
;;> \example{(match 1 ((or x) x))}
;;> \example{(match 1 ((or x 2) x))}

;;> The \scheme{not} operator succeeds if the given pattern doesn't
;;> match.  None of the identifiers used are available in the body.

;;> \example{(match 1 ((not 2) #t))}

;;> The more general operator \scheme{?} can be used to provide a
;;> predicate.  The usage is \scheme{(? predicate pat ...)} where
;;> \var{predicate} is a Scheme expression evaluating to a predicate
;;> called on the value to match, and any optional patterns after the
;;> predicate are then matched as in an \scheme{and} pattern.

;;> \example{(match 1 ((? odd? x) x))}

;;> The field operator \scheme{=} is used to extract an arbitrary
;;> field and match against it.  It is useful for more complex or
;;> conditional destructuring that can't be more directly expressed in
;;> the pattern syntax.  The usage is \scheme{(= field pat)}, where
;;> \var{field} can be any expression, and should result in a
;;> procedure of one argument, which is applied to the value to match
;;> to generate a new value to match against \var{pat}.

;;> Thus the pattern \scheme{(and (= car x) (= cdr y))} is equivalent
;;> to \scheme{(x . y)}, except it will result in an immediate error
;;> if the value isn't a pair.

;;> \example{(match '(1 . 2) ((= car x) x))}
;;> \example{(match 4 ((= square x) x))}

;;> The record operator \scheme{$} is used as a concise way to match
;;> records defined by SRFI-9 (or SRFI-99).  The usage is
;;> \scheme{($ rtd field ...)}, where \var{rtd} should be the record
;;> type descriptor specified as the first argument to
;;> \scheme{define-record-type}, and each \var{field} is a subpattern
;;> matched against the fields of the record in order.  Not all fields
;;> must be present.

;;> \example{
;;> (let ()
;;>   (define-record-type employee
;;>     (make-employee name title)
;;>     employee?
;;>     (name get-name)
;;>     (title get-title))
;;>   (match (make-employee "Bob" "Doctor")
;;>     (($ employee n t) (list t n))))
;;> }

;;> For records with more fields it can be helpful to match them by
;;> name rather than position.  For this you can use the \scheme{@}
;;> operator, originally a Gauche extension:

;;> \example{
;;> (let ()
;;>   (define-record-type employee
;;>     (make-employee name title)
;;>     employee?
;;>     (name get-name)
;;>     (title get-title))
;;>   (match (make-employee "Bob" "Doctor")
;;>     ((@ employee (title t) (name n)) (list t n))))
;;> }

;;> The \scheme{set!} and \scheme{get!} operators are used to bind an
;;> identifier to the setter and getter of a field, respectively.  The
;;> setter is a procedure of one argument, which mutates the field to
;;> that argument.  The getter is a procedure of no arguments which
;;> returns the current value of the field.

;;> \example{(let ((x (cons 1 2))) (match x ((1 . (set! s)) (s 3) x)))}
;;> \example{(match '(1 . 2) ((1 . (get! g)) (g)))}

;;> The new operator \scheme{***} can be used to search a tree for
;;> subpatterns.  A pattern of the form \scheme{(x *** y)} represents
;;> the subpattern \var{y} located somewhere in a tree where the path
;;> from the current object to \var{y} can be seen as a list of the
;;> form \scheme{(x ...)}.  \var{y} can immediately match the current
;;> object in which case the path is the empty list.  In a sense it's
;;> a 2-dimensional version of the \scheme{...} pattern.

;;> As a common case the pattern \scheme{(_ *** y)} can be used to
;;> search for \var{y} anywhere in a tree, regardless of the path
;;> used.

;;> \example{(match '(a (a (a b))) ((x *** 'b) x))}
;;> \example{(match '(a (b) (c (d e) (f g))) ((x *** 'g) x))}

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Notes

;; The implementation is a simple generative pattern matcher - each
;; pattern is expanded into the required tests, calling a failure
;; continuation if the tests fail.  This makes the logic easy to
;; follow and extend, but produces sub-optimal code in cases where you
;; have many similar clauses due to repeating the same tests.
;; Nonetheless a smart compiler should be able to remove the redundant
;; tests.  For MATCH-LET and DESTRUCTURING-BIND type uses there is no
;; performance hit.

;; The original version was written on 2006/11/29 and described in the
;; following Usenet post:
;;   http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd
;; and is still available at
;;   http://synthcode.com/scheme/match-simple.scm
;; It's just 80 lines for the core MATCH, and an extra 40 lines for
;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar.
;;
;; A variant of this file which uses COND-EXPAND in a few places for
;; performance can be found at
;;   http://synthcode.com/scheme/match-cond-expand.scm
;;
;; 2016/03/06 - fixing named match-let (thanks to Stefan Israelsson Tampe)
;; 2015/05/09 - fixing bug in var extraction of quasiquote patterns
;; 2014/11/24 - adding Gauche's `@' pattern for named record field matching
;; 2012/12/26 - wrapping match-let&co body in lexical closure
;; 2012/11/28 - fixing typo s/vetor/vector in largely unused set! code
;; 2012/05/23 - fixing combinatorial explosion of code in certain or patterns
;; 2011/09/25 - fixing bug when directly matching an identifier repeated in
;;              the pattern (thanks to Stefan Israelsson Tampe)
;; 2011/01/27 - fixing bug when matching tail patterns against improper lists
;; 2010/09/26 - adding `..1' patterns (thanks to Ludovic Courtès)
;; 2010/09/07 - fixing identifier extraction in some `...' and `***' patterns
;; 2009/11/25 - adding `***' tree search patterns
;; 2008/03/20 - fixing bug where (a ...) matched non-lists
;; 2008/03/15 - removing redundant check in vector patterns
;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell)
;; 2007/09/04 - fixing quasiquote patterns
;; 2007/07/21 - allowing ellipsis patterns in non-final list positions
;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipsis
;;              (thanks to Taylor Campbell)
;; 2007/04/08 - clean up, commenting
;; 2006/12/24 - bugfixes
;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; force compile-time syntax errors with useful messages

(define-syntax match-syntax-error
  (syntax-rules ()
    ((_) (match-syntax-error "invalid match-syntax-error usage"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;> \section{Syntax}

;;> \macro{(match expr (pattern . body) ...)\br{}
;;> (match expr (pattern (=> failure) . body) ...)}

;;> The result of \var{expr} is matched against each \var{pattern} in
;;> turn, according to the pattern rules described in the previous
;;> section, until the the first \var{pattern} matches.  When a match is
;;> found, the corresponding \var{body}s are evaluated in order,
;;> and the result of the last expression is returned as the result
;;> of the entire \scheme{match}.  If a \var{failure} is provided,
;;> then it is bound to a procedure of no arguments which continues,
;;> processing at the next \var{pattern}.  If no \var{pattern} matches,
;;> an error is signalled.

;; The basic interface.  MATCH just performs some basic syntax
;; validation, binds the match expression to a temporary variable `v',
;; and passes it on to MATCH-NEXT.  It's a constant throughout the
;; code below that the binding `v' is a direct variable reference, not
;; an expression.

(define-syntax match
  (syntax-rules ()
    ((match)
     (match-syntax-error "missing match expression"))
    ((match atom)
     (match-syntax-error "no match clauses"))
    ((match (app ...) (pat . body) ...)
     (let ((v (app ...)))
       (match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
    ((match #(vec ...) (pat . body) ...)
     (let ((v #(vec ...)))
       (match-next v (v (set! v)) (pat . body) ...)))
    ((match atom (pat . body) ...)
     (let ((v atom))
       (match-next v (atom (set! atom)) (pat . body) ...)))
    ))

;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
;; clauses.  `g+s' is a list of two elements, the get! and set!
;; expressions respectively.

(define-syntax match-next
  (syntax-rules (=>)
    ;; no more clauses, the match failed
    ((match-next v g+s)
     (error 'match "no matching pattern"))
    ;; named failure continuation
    ((match-next v g+s (pat (=> failure) . body) . rest)
     (let ((failure (lambda () (match-next v g+s . rest))))
       ;; match-one analyzes the pattern for us
       (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ())))
    ;; anonymous failure continuation, give it a dummy name
    ((match-next v g+s (pat . body) . rest)
     (match-next v g+s (pat (=> failure) . body) . rest))))

;; MATCH-ONE first checks for ellipsis patterns, otherwise passes on to
;; MATCH-TWO.

(define-syntax match-one
  (syntax-rules ()
    ;; If it's a list of two or more values, check to see if the
    ;; second one is an ellipsis and handle accordingly, otherwise go
    ;; to MATCH-TWO.
    ((match-one v (p q . r) g+s sk fk i)
     (match-check-ellipsis
      q
      (match-extract-vars p (match-gen-ellipsis v p r  g+s sk fk i) i ())
      (match-two v (p q . r) g+s sk fk i)))
    ;; Go directly to MATCH-TWO.
    ((match-one . x)
     (match-two . x))))

;; This is the guts of the pattern matcher.  We are passed a lot of
;; information in the form:
;;
;;   (match-two var pattern getter setter success-k fail-k (ids ...))
;;
;; usually abbreviated
;;
;;   (match-two v p g+s sk fk i)
;;
;; where VAR is the symbol name of the current variable we are
;; matching, PATTERN is the current pattern, getter and setter are the
;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
;; continuation (which is just a thunk call and is thus safe to expand
;; multiple times) and IDS are the list of identifiers bound in the
;; pattern so far.

;; Replace '_' with ':_' as the former is forbidden as an auxiliariy
;; keyword in R6RS. (FBE)
(define-syntax match-two
  (syntax-rules (:_ ___ ..1 *** quote quasiquote ? $ struct @ object = and or not set! get!)
    ((match-two v () g+s (sk ...) fk i)
     (if (null? v) (sk ... i) fk))
    ((match-two v (quote p) g+s (sk ...) fk i)
     (if (equal? v 'p) (sk ... i) fk))
    ((match-two v (quasiquote p) . x)
     (match-quasiquote v p . x))
    ((match-two v (and) g+s (sk ...) fk i) (sk ... i))
    ((match-two v (and p q ...) g+s sk fk i)
     (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
    ((match-two v (or) g+s sk fk i) fk)
    ((match-two v (or p) . x)
     (match-one v p . x))
    ((match-two v (or p ...) g+s sk fk i)
     (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
    ((match-two v (not p) g+s (sk ...) fk i)
     (match-one v p g+s (match-drop-ids fk) (sk ... i) i))
    ((match-two v (get! getter) (g s) (sk ...) fk i)
     (let ((getter (lambda () g))) (sk ... i)))
    ((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
     (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
    ((match-two v (? pred . p) g+s sk fk i)
     (if (pred v) (match-one v (and . p) g+s sk fk i) fk))
    ((match-two v (= proc p) . x)
     (let ((w (proc v))) (match-one w p . x)))
    ((match-two v (p ___ . r) g+s sk fk i)
     (match-extract-vars p (match-gen-ellipsis v p r g+s sk fk i) i ()))
    ((match-two v (p) g+s sk fk i)
     (if (and (pair? v) (null? (cdr v)))
         (let ((w (car v)))
           (match-one w p ((car v) (set-car! v)) sk fk i))
         fk))
    ((match-two v (p *** q) g+s sk fk i)
     (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
    ((match-two v (p *** . q) g+s sk fk i)
     (match-syntax-error "invalid use of ***" (p *** . q)))
    ((match-two v (p ..1) g+s sk fk i)
     (if (pair? v)
         (match-one v (p ___) g+s sk fk i)
         fk))
    ((match-two v ($ rec p ...) g+s sk fk i)
     (if (is-a? v rec)
         (match-record-refs v rec 0 (p ...) g+s sk fk i)
         fk))
    ((match-two v (struct rec p ...) g+s sk fk i)
     (if (is-a? v rec)
         (match-record-refs v rec 0 (p ...) g+s sk fk i)
         fk))
    ((match-two v (@ rec p ...) g+s sk fk i)
     (if (is-a? v rec)
         (match-record-named-refs v rec (p ...) g+s sk fk i)
         fk))
    ((match-two v (object rec p ...) g+s sk fk i)
     (if (is-a? v rec)
         (match-record-named-refs v rec (p ...) g+s sk fk i)
         fk))
    ((match-two v (p . q) g+s sk fk i)
     (if (pair? v)
         (let ((w (car v)) (x (cdr v)))
           (match-one w p ((car v) (set-car! v))
                      (match-one x q ((cdr v) (set-cdr! v)) sk fk)
                      fk
                      i))
         fk))
    ((match-two v #(p ...) g+s . x)
     (match-vector v 0 () (p ...) . x))
    ;; Next line: replace '_' with ':_'. (FBE)
    ((match-two v :_ g+s (sk ...) fk i) (sk ... i))
    ;; Not a pair or vector or special literal, test to see if it's a
    ;; new symbol, in which case we just bind it, or if it's an
    ;; already bound symbol or some other literal, in which case we
    ;; compare it with EQUAL?.
    ((match-two v x g+s (sk ...) fk (id ...))
     (let-syntax
         ((new-sym?
           (syntax-rules (id ...)
             ((new-sym? x sk2 fk2) sk2)
             ((new-sym? y sk2 fk2) fk2))))
       (new-sym? random-sym-to-match
                 (let ((x v)) (sk ... (id ... x)))
                 (if (equal? v x) (sk ... (id ...)) fk))))
    ))

;; QUASIQUOTE patterns

(define-syntax match-quasiquote
  (syntax-rules (unquote unquote-splicing quasiquote)
    ((_ v (unquote p) g+s sk fk i)
     (match-one v p g+s sk fk i))
    ((_ v ((unquote-splicing p) . rest) g+s sk fk i)
     (if (pair? v)
       (match-one v
                  (p . tmp)
                  (match-quasiquote tmp rest g+s sk fk)
                  fk
                  i)
       fk))
    ((_ v (quasiquote p) g+s sk fk i . depth)
     (match-quasiquote v p g+s sk fk i #f . depth))
    ((_ v (unquote p) g+s sk fk i x . depth)
     (match-quasiquote v p g+s sk fk i . depth))
    ((_ v (unquote-splicing p) g+s sk fk i x . depth)
     (match-quasiquote v p g+s sk fk i . depth))
    ((_ v (p . q) g+s sk fk i . depth)
     (if (pair? v)
       (let ((w (car v)) (x (cdr v)))
         (match-quasiquote
          w p g+s
          (match-quasiquote-step x q g+s sk fk depth)
          fk i . depth))
       fk))
    ((_ v #(elt ...) g+s sk fk i . depth)
     (if (vector? v)
       (let ((ls (vector->list v)))
         (match-quasiquote ls (elt ...) g+s sk fk i . depth))
       fk))
    ((_ v x g+s sk fk i . depth)
     (match-one v 'x g+s sk fk i))))

(define-syntax match-quasiquote-step
  (syntax-rules ()
    ((match-quasiquote-step x q g+s sk fk depth i)
     (match-quasiquote x q g+s sk fk i . depth))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utilities

;; Takes two values and just expands into the first.
(define-syntax match-drop-ids
  (syntax-rules ()
    ((_ expr ids ...) expr)))

(define-syntax match-tuck-ids
  (syntax-rules ()
    ((_ (letish args (expr ...)) ids ...)
     (letish args (expr ... ids ...)))))

(define-syntax match-drop-first-arg
  (syntax-rules ()
    ((_ arg expr) expr)))

;; To expand an OR group we try each clause in succession, passing the
;; first that succeeds to the success continuation.  On failure for
;; any clause, we just try the next clause, finally resorting to the
;; failure continuation fk if all clauses fail.  The only trick is
;; that we want to unify the identifiers, so that the success
;; continuation can refer to a variable from any of the OR clauses.

(define-syntax match-gen-or
  (syntax-rules ()
    ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
     (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
       (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))

(define-syntax match-gen-or-step
  (syntax-rules ()
    ((_ v () g+s sk fk . x)
     ;; no OR clauses, call the failure continuation
     fk)
    ((_ v (p) . x)
     ;; last (or only) OR clause, just expand normally
     (match-one v p . x))
    ((_ v (p . q) g+s sk fk i)
     ;; match one and try the remaining on failure
     (let ((fk2 (lambda () (match-gen-or-step v q g+s sk fk i))))
       (match-one v p g+s sk (fk2) i)))
    ))

;; We match a pattern (p ...) by matching the pattern p in a loop on
;; each element of the variable, accumulating the bound ids into lists.

;; Look at the body of the simple case - it's just a named let loop,
;; matching each element in turn to the same pattern.  The only trick
;; is that we want to keep track of the lists of each extracted id, so
;; when the loop recurses we cons the ids onto their respective list
;; variables, and on success we bind the ids (what the user input and
;; expects to see in the success body) to the reversed accumulated
;; list IDs.

(define-syntax match-gen-ellipsis
  (syntax-rules ()
    ((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
     (match-check-identifier p
       ;; simplest case equivalent to (p ...), just bind the list
       (let ((p v))
         (if (list? p)
             (sk ... i)
             fk))
       ;; simple case, match all elements of the list
       (let loop ((ls v) (id-ls '()) ...)
         (cond
           ((null? ls)
            (let ((id (reverse id-ls)) ...) (sk ... i)))
           ((pair? ls)
            (let ((w (car ls)))
              (match-one w p ((car ls) (set-car! ls))
                         (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
                         fk i)))
           (else
            fk)))))
    ((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
     ;; general case, trailing patterns to match, keep track of the
     ;; remaining list length so we don't need any backtracking
     (match-verify-no-ellipsis
      r
      (let* ((tail-len (length 'r))
             (ls v)
             (len (and (list? ls) (length ls))))
        (if (or (not len) (< len tail-len))
            fk
            (let loop ((ls ls) (n len) (id-ls '()) ...)
              (cond
                ((= n tail-len)
                 (let ((id (reverse id-ls)) ...)
                   (match-one ls r (#f #f) (sk ...) fk i)))
                ((pair? ls)
                 (let ((w (car ls)))
                   (match-one w p ((car ls) (set-car! ls))
                              (match-drop-ids
                               (loop (cdr ls) (- n 1) (cons id id-ls) ...))
                              fk
                              i)))
                (else
                 fk)))))))))

;; This is just a safety check.  Although unlike syntax-rules we allow
;; trailing patterns after an ellipsis, we explicitly disable multiple
;; ellipsis at the same level.  This is because in the general case
;; such patterns are exponential in the number of ellipsis, and we
;; don't want to make it easy to construct very expensive operations
;; with simple looking patterns.  For example, it would be O(n^2) for
;; patterns like (a ... b ...) because we must consider every trailing
;; element for every possible break for the leading "a ...".

(define-syntax match-verify-no-ellipsis
  (syntax-rules ()
    ((_ (x . y) sk)
     (match-check-ellipsis
      x
      (match-syntax-error
       "multiple ellipsis patterns not allowed at same level")
      (match-verify-no-ellipsis y sk)))
    ((_ () sk)
     sk)
    ((_ x sk)
     (match-syntax-error "dotted tail not allowed after ellipsis" x))))

;; To implement the tree search, we use two recursive procedures.  TRY
;; attempts to match Y once, and on success it calls the normal SK on
;; the accumulated list ids as in MATCH-GEN-ELLIPSIS.  On failure, we
;; call NEXT which first checks if the current value is a list
;; beginning with X, then calls TRY on each remaining element of the
;; list.  Since TRY will recursively call NEXT again on failure, this
;; effects a full depth-first search.
;;
;; The failure continuation throughout is a jump to the next step in
;; the tree search, initialized with the original failure continuation
;; FK.

(define-syntax match-gen-search
  (syntax-rules ()
    ((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
     (letrec ((try (lambda (w fail id-ls ...)
                     (match-one w q g+s
                                (match-tuck-ids
                                 (let ((id (reverse id-ls)) ...)
                                   sk))
                                (next w fail id-ls ...) i)))
              (next (lambda (w fail id-ls ...)
                      (if (not (pair? w))
                          (fail)
                          (let ((u (car w)))
                            (match-one
                             u p ((car w) (set-car! w))
                             (match-drop-ids
                              ;; accumulate the head variables from
                              ;; the p pattern, and loop over the tail
                              (let ((id-ls (cons id id-ls)) ...)
                                (let lp ((ls (cdr w)))
                                  (if (pair? ls)
                                      (try (car ls)
                                           (lambda () (lp (cdr ls)))
                                           id-ls ...)
                                      (fail)))))
                             (fail) i))))))
       ;; the initial id-ls binding here is a dummy to get the right
       ;; number of '()s
       (let ((id-ls '()) ...)
         (try v (lambda () fk) id-ls ...))))))

;; Vector patterns are just more of the same, with the slight
;; exception that we pass around the current vector index being
;; matched.

(define-syntax match-vector
  (syntax-rules (___)
    ((_ v n pats (p q) . x)
     (match-check-ellipsis q
                          (match-gen-vector-ellipsis v n pats p . x)
                          (match-vector-two v n pats (p q) . x)))
    ((_ v n pats (p ___) sk fk i)
     (match-gen-vector-ellipsis v n pats p sk fk i))
    ((_ . x)
     (match-vector-two . x))))

;; Check the exact vector length, then check each element in turn.

(define-syntax match-vector-two
  (syntax-rules ()
    ((_ v n ((pat index) ...) () sk fk i)
     (if (vector? v)
         (let ((len (vector-length v)))
           (if (= len n)
               (match-vector-step v ((pat index) ...) sk fk i)
               fk))
         fk))
    ((_ v n (pats ...) (p . q) . x)
     (match-vector v (+ n 1) (pats ... (p n)) q . x))))

(define-syntax match-vector-step
  (syntax-rules ()
    ((_ v () (sk ...) fk i) (sk ... i))
    ((_ v ((pat index) . rest) sk fk i)
     (let ((w (vector-ref v index)))
       (match-one w pat ((vector-ref v index) (vector-set! v index))
                  (match-vector-step v rest sk fk)
                  fk i)))))

;; With a vector ellipsis pattern we first check to see if the vector
;; length is at least the required length.

(define-syntax match-gen-vector-ellipsis
  (syntax-rules ()
    ((_ v n ((pat index) ...) p sk fk i)
     (if (vector? v)
       (let ((len (vector-length v)))
         (if (>= len n)
           (match-vector-step v ((pat index) ...)
                              (match-vector-tail v p n len sk fk)
                              fk i)
           fk))
       fk))))

(define-syntax match-vector-tail
  (syntax-rules ()
    ((_ v p n len sk fk i)
     (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))

(define-syntax match-vector-tail-two
  (syntax-rules ()
    ((_ v p n len (sk ...) fk i ((id id-ls) ...))
     (let loop ((j n) (id-ls '()) ...)
       (if (>= j len)
         (let ((id (reverse id-ls)) ...) (sk ... i))
         (let ((w (vector-ref v j)))
           (match-one w p ((vector-ref v j) (vector-set! v j))
                      (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
                      fk i)))))))

(define-syntax match-record-refs
  (syntax-rules ()
    ((_ v rec n (p . q) g+s sk fk i)
     (let ((w (slot-ref rec v n)))
       (match-one w p ((slot-ref rec v n) (slot-set! rec v n))
                  (match-record-refs v rec (+ n 1) q g+s sk fk) fk i)))
    ((_ v rec n () g+s (sk ...) fk i)
     (sk ... i))))

(define-syntax match-record-named-refs
  (syntax-rules ()
    ((_ v rec ((f p) . q) g+s sk fk i)
     (let ((w (slot-ref rec v 'f)))
       (match-one w p ((slot-ref rec v 'f) (slot-set! rec v 'f))
                  (match-record-named-refs v rec q g+s sk fk) fk i)))
    ((_ v rec () g+s (sk ...) fk i)
     (sk ... i))))

;; Extract all identifiers in a pattern.  A little more complicated
;; than just looking for symbols, we need to ignore special keywords
;; and non-pattern forms (such as the predicate expression in ?
;; patterns), and also ignore previously bound identifiers.
;;
;; Calls the continuation with all new vars as a list of the form
;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely
;; pair with the original variable (e.g. it's used in the ellipsis
;; generation for list variables).
;;
;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))

;; Replace '_' with ':_' as the former is forbidden as an auxiliariy
;; keyword in R6RS. (FBE)
(define-syntax match-extract-vars
  (syntax-rules (:_ ___ ..1 *** ? $ struct @ object = quote quasiquote and or not get! set!)
    ((match-extract-vars (? pred . p) . x)
     (match-extract-vars p . x))
    ((match-extract-vars ($ rec . p) . x)
     (match-extract-vars p . x))
    ((match-extract-vars (struct rec . p) . x)
     (match-extract-vars p . x))
    ((match-extract-vars (@ rec (f p) ...) . x)
     (match-extract-vars (p ...) . x))
    ((match-extract-vars (object rec (f p) ...) . x)
     (match-extract-vars (p ...) . x))
    ((match-extract-vars (= proc p) . x)
     (match-extract-vars p . x))
    ((match-extract-vars (quote x) (k ...) i v)
     (k ... v))
    ((match-extract-vars (quasiquote x) k i v)
     (match-extract-quasiquote-vars x k i v (#t)))
    ((match-extract-vars (and . p) . x)
     (match-extract-vars p . x))
    ((match-extract-vars (or . p) . x)
     (match-extract-vars p . x))
    ((match-extract-vars (not . p) . x)
     (match-extract-vars p . x))
    ;; A non-keyword pair, expand the CAR with a continuation to
    ;; expand the CDR.
    ((match-extract-vars (p q . r) k i v)
     (match-check-ellipsis
      q
      (match-extract-vars (p . r) k i v)
      (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
    ((match-extract-vars (p . q) k i v)
     (match-extract-vars p (match-extract-vars-step q k i v) i ()))
    ((match-extract-vars #(p ...) . x)
     (match-extract-vars (p ...) . x))
    ;; Next line: replace '_' with ':_'. (FBE)
    ((match-extract-vars :_ (k ...) i v)    (k ... v))
    ((match-extract-vars ___ (k ...) i v)  (k ... v))
    ((match-extract-vars *** (k ...) i v)  (k ... v))
    ((match-extract-vars ..1 (k ...) i v)  (k ... v))
    ;; This is the main part, the only place where we might add a new
    ;; var if it's an unbound symbol.
    ((match-extract-vars p (k ...) (i ...) v)
     (let-syntax
         ((new-sym?
           (syntax-rules (i ...)
             ((new-sym? p sk fk) sk)
             ((new-sym? any sk fk) fk))))
       (new-sym? random-sym-to-match
                 (k ... ((p p-ls) . v))
                 (k ... v))))
    ))

;; Stepper used in the above so it can expand the CAR and CDR
;; separately.

(define-syntax match-extract-vars-step
  (syntax-rules ()
    ((_ p k i v ((v2 v2-ls) ...))
     (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
    ))

(define-syntax match-extract-quasiquote-vars
  (syntax-rules (quasiquote unquote unquote-splicing)
    ((match-extract-quasiquote-vars (quasiquote x) k i v d)
     (match-extract-quasiquote-vars x k i v (#t . d)))
    ((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
     (match-extract-quasiquote-vars (unquote x) k i v d))
    ((match-extract-quasiquote-vars (unquote x) k i v (#t))
     (match-extract-vars x k i v))
    ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
     (match-extract-quasiquote-vars x k i v d))
    ((match-extract-quasiquote-vars (x . y) k i v d)
     (match-extract-quasiquote-vars
      x
      (match-extract-quasiquote-vars-step y k i v d) i () d))
    ((match-extract-quasiquote-vars #(x ...) k i v d)
     (match-extract-quasiquote-vars (x ...) k i v d))
    ((match-extract-quasiquote-vars x (k ...) i v d)
     (k ... v))
    ))

(define-syntax match-extract-quasiquote-vars-step
  (syntax-rules ()
    ((_ x k i v d ((v2 v2-ls) ...))
     (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
    ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Gimme some sugar baby.

;;> Shortcut for \scheme{lambda} + \scheme{match}.  Creates a
;;> procedure of one argument, and matches that argument against each
;;> clause.

(define-syntax match-lambda
  (syntax-rules ()
    ((_ (pattern . body) ...) (lambda (expr) (match expr (pattern . body) ...)))))

;;> Similar to \scheme{match-lambda}.  Creates a procedure of any
;;> number of arguments, and matches the argument list against each
;;> clause.

(define-syntax match-lambda*
  (syntax-rules ()
    ((_ (pattern . body) ...) (lambda expr (match expr (pattern . body) ...)))))

;;> Matches each var to the corresponding expression, and evaluates
;;> the body with all match variables in scope.  Raises an error if
;;> any of the expressions fail to match.  Syntax analogous to named
;;> let can also be used for recursive functions which match on their
;;> arguments as in \scheme{match-lambda*}.

(define-syntax match-let
  (syntax-rules ()
    ((_ ((var value) ...) . body)
     (match-let/helper let () () ((var value) ...) . body))
    ((_ loop ((var init) ...) . body)
     (match-named-let loop () ((var init) ...) . body))))

;;> Similar to \scheme{match-let}, but analogously to \scheme{letrec}
;;> matches and binds the variables with all match variables in scope.

(define-syntax match-letrec
  (syntax-rules ()
    ((_ ((var value) ...) . body)
     (match-let/helper letrec () () ((var value) ...) . body))))

(define-syntax match-let/helper
  (syntax-rules ()
    ((_ let ((var expr) ...) () () . body)
     (let ((var expr) ...) . body))
    ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
     (let ((var expr) ...)
       (match-let* ((pat tmp) ...)
         . body)))
    ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
     (match-let/helper
      let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
    ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
     (match-let/helper
      let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
    ((_ let (v ...) (p ...) ((a expr) . rest) . body)
     (match-let/helper let (v ... (a expr)) (p ...) rest . body))))

(define-syntax match-named-let
  (syntax-rules ()
    ((_ loop ((pat expr var) ...) () . body)
     (let loop ((var expr) ...)
       (match-let ((pat var) ...)
         . body)))
    ((_ loop (v ...) ((pat expr) . rest) . body)
     (match-named-let loop (v ... (pat expr tmp)) rest . body))))

;;> \macro{(match-let* ((var value) ...) body ...)}

;;> Similar to \scheme{match-let}, but analogously to \scheme{let*}
;;> matches and binds the variables in sequence, with preceding match
;;> variables in scope.

(define-syntax match-let*
  (syntax-rules ()
    ((_ () . body)
     (let () . body))
    ((_ ((pat expr) . rest) . body)
     (match expr (pat (match-let* rest . body))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Otherwise COND-EXPANDed bits.

;; To avoid depending on srfi-0 we comment the following form and copy
;; the generic version below it. (FBE)

;; (cond-expand
;;  (chibi
;;   (define-syntax match-check-ellipsis
;;     (er-macro-transformer
;;      (lambda (expr rename compare)
;;        (if (compare '... (cadr expr))
;;            (car (cddr expr))
;;            (cadr (cddr expr))))))
;;   (define-syntax match-check-identifier
;;     (er-macro-transformer
;;      (lambda (expr rename compare)
;;        (if (identifier? (cadr expr))
;;            (car (cddr expr))
;;            (cadr (cddr expr)))))))

;;  (else
;;   ;; Portable versions
;;   ;;
;;   ;; This *should* work, but doesn't :(
;;   ;;   (define-syntax match-check-ellipsis
;;   ;;     (syntax-rules (...)
;;   ;;       ((_ ... sk fk) sk)
;;   ;;       ((_ x sk fk) fk)))
;;   ;;
;;   ;; This is a little more complicated, and introduces a new let-syntax,
;;   ;; but should work portably in any R[56]RS Scheme.  Taylor Campbell
;;   ;; originally came up with the idea.
;;   (define-syntax match-check-ellipsis
;;     (syntax-rules ()
;;       ;; these two aren't necessary but provide fast-case failures
;;       ((match-check-ellipsis (a . b) success-k failure-k) failure-k)
;;       ((match-check-ellipsis #(a ...) success-k failure-k) failure-k)
;;       ;; matching an atom
;;       ((match-check-ellipsis id success-k failure-k)
;;        (let-syntax ((ellipsis? (syntax-rules ()
;;                                  ;; iff `id' is `...' here then this will
;;                                  ;; match a list of any length
;;                                  ((ellipsis? (foo id) sk fk) sk)
;;                                  ((ellipsis? other sk fk) fk))))
;;          ;; this list of three elements will only match the (foo id) list
;;          ;; above if `id' is `...'
;;          (ellipsis? (a b c) success-k failure-k)))))

;;   ;; This is portable but can be more efficient with non-portable
;;   ;; extensions.  This trick was originally discovered by Oleg Kiselyov.
;;   (define-syntax match-check-identifier
;;     (syntax-rules ()
;;       ;; fast-case failures, lists and vectors are not identifiers
;;       ((_ (x . y) success-k failure-k) failure-k)
;;       ((_ #(x ...) success-k failure-k) failure-k)
;;       ;; x is an atom
;;       ((_ x success-k failure-k)
;;        (let-syntax
;;            ((sym?
;;              (syntax-rules ()
;;                ;; if the symbol `abracadabra' matches x, then x is a
;;                ;; symbol
;;                ((sym? x sk fk) sk)
;;                ;; otherwise x is a non-symbol datum
;;                ((sym? y sk fk) fk))))
;;          (sym? abracadabra success-k failure-k)))))))

;; Portable versions
;;
;; This *should* work, but doesn't :(
;;   (define-syntax match-check-ellipsis
;;     (syntax-rules (...)
;;       ((_ ... sk fk) sk)
;;       ((_ x sk fk) fk)))
;;
;; This is a little more complicated, and introduces a new let-syntax,
;; but should work portably in any R[56]RS Scheme.  Taylor Campbell
;; originally came up with the idea.
(define-syntax match-check-ellipsis
  (syntax-rules ()
    ;; these two aren't necessary but provide fast-case failures
    ((match-check-ellipsis (a . b) success-k failure-k) failure-k)
    ((match-check-ellipsis #(a ...) success-k failure-k) failure-k)
    ;; matching an atom
    ((match-check-ellipsis id success-k failure-k)
     (let-syntax ((ellipsis? (syntax-rules ()
                               ;; iff `id' is `...' here then this will
                               ;; match a list of any length
                               ((ellipsis? (foo id) sk fk) sk)
                               ((ellipsis? other sk fk) fk))))
       ;; this list of three elements will only match the (foo id) list
       ;; above if `id' is `...'
       (ellipsis? (a b c) success-k failure-k)))))

;; This is portable but can be more efficient with non-portable
;; extensions.  This trick was originally discovered by Oleg Kiselyov.
(define-syntax match-check-identifier
  (syntax-rules ()
    ;; fast-case failures, lists and vectors are not identifiers
    ((_ (x . y) success-k failure-k) failure-k)
    ((_ #(x ...) success-k failure-k) failure-k)
    ;; x is an atom
    ((_ x success-k failure-k)
     (let-syntax
         ((sym?
           (syntax-rules ()
             ;; if the symbol `abracadabra' matches x, then x is a
             ;; symbol
             ((sym? x sk fk) sk)
             ;; otherwise x is a non-symbol datum
             ((sym? y sk fk) fk))))
       (sym? abracadabra success-k failure-k)))))

;;; Chez-Scheme Wrappers for Alex Shinn's Match (Wright Compatible)
;;; 
;;; Copyright (c) 2016 Federico Beffa <beffa@fbengineering.ch>
;;; 
;;; Permission to use, copy, modify, and distribute this software for
;;; any purpose with or without fee is hereby granted, provided that the
;;; above copyright notice and this permission notice appear in all
;;; copies.
;;; 
;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
;;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
;;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
;;; DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA
;;; OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
;;; TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
;;; PERFORMANCE OF THIS SOFTWARE.

;; The reader in #!r6rs mode doesn't allow the '..1' identifier.
#!chezscheme
(library (matchable)
  (export 
    match
    match-lambda 
    match-lambda* 
    match-let 
    match-let* 
    match-letrec
    match-named-let
    :_ ___ ..1 *** ? $ struct @ object)
  
  #;(import 
   (rnrs base)
   (rnrs lists)
   (rnrs mutable-pairs)
   (rnrs records syntactic)
   (rnrs records procedural)
   (rnrs records inspection)
   (rnrs syntax-case)
   (only (chezscheme) iota include)
   ;; avoid dependence on chez-srfi (apart for tests)
   ;; (srfi private aux-keywords)
   ;; (srfi private include)
   )
   (import (chezscheme))

  ;; We declare end export the symbols used as auxiliary identifiers
  ;; in 'syntax-rules' to make them work in Chez Scheme's interactive
  ;; environment. (FBE)

  ;; Also we replaced '_' with ':_' as the special identifier matching
  ;; anything and not binding.  This is because R6RS forbids its use
  ;; as an auxiliary literal in a syntax-rules form.
  (define-syntax define-auxiliary-keyword
    (syntax-rules ()
      [(_ name)
       (define-syntax name 
         (lambda (x)
           (syntax-violation #f "misplaced use of auxiliary keyword" x)))]))

  (define-syntax define-auxiliary-keywords
    (syntax-rules ()
      [(_ name* ...)
       (begin (define-auxiliary-keyword name*) ...)]))

  (define-auxiliary-keywords :_ ___ ..1 *** ? $ struct @ object)

  (define-syntax is-a?
    (syntax-rules ()
      ((_ rec rtn)
       (and (record? rec)
            (eq? (record-type-name (record-rtd rec)) (quote rtn))))))

  (define-syntax slot-ref
    (syntax-rules ()
      ((_ rtn rec n)
       (if (number? n)
           ((record-accessor (record-rtd rec) n) rec)
           ;; If it's not a number, then it should be a symbol with
           ;; the name of a field.
           (let* ((rtd (record-rtd rec))
                  (fields (record-type-field-names rtd))
                  (fields-idxs (map (lambda (f i) (cons f i))
                                    (vector->list fields)
                                    (iota (vector-length fields))))
                  (idx (cdr (assv n fields-idxs))))
             ((record-accessor rtd idx) rec))))))

  (define-syntax slot-set!
    (syntax-rules ()
      ((_ rtn rec n)
       (if (number? n)
           ((record-mutator (record-rtd rec) n) rec)
           ;; If it's not a number, then it should be a symbol with
           ;; the name of a field.
           (let* ((rtd (record-rtd rec))
                  (fields (record-type-field-names rtd))
                  (fields-idxs (map (lambda (f i) (cons f i))
                                    (vector->list fields)
                                    (iota (vector-length fields))))
                  (idx (cdr (assv n fields-idxs))))
             ((record-mutator rtd idx) rec))))))
  
  (include "match.scm")

  )

;;; "sql-null.scm" -- SQL NULL object and the ternary logic  -*- Scheme -*-

;;; Ivan Shmakov, 2007  This code is in public domain.

(library (sql-null)
  (export sql-null sql-null? sql-not sql-or sql-or sql-and sql-coalesce)

  (import (chezscheme))

  ;;from chicken data-structures.scm  Copyright (c) 2008-2014, The Chicken Team
  (define (constantly . xs)
    (if (eq? 1 (length xs))
	(let ([x (car xs)])
	  (lambda _ x) )
	(lambda _ (apply values xs)) ) )

  ;; We could also (define-record sql-null) and alias sql-null to make-sql-null
  ;; but that implies creating many new objects, which we don't want.
  (define-record-type sql-null-type)
  (define sql-null-object (make-sql-null-type))
  (define sql-null (constantly sql-null-object))
  (define sql-null? sql-null-type?)

  (define (sql-not o)
    (if (sql-null? o) o (not o)))

  (define-syntax sql-or
    (syntax-rules ()
      ((sql-or a ...)
       (sql-or/null #f a ...))))

  (define-syntax sql-or/null
    (syntax-rules ()
      ((sql-or/null null)
       null)
      ((sql-or/null null a b ...)
       (let ((ea a))
	 (cond ((sql-null? ea) (sql-or/null ea    b ...))
	       ((not ea)       (sql-or/null null b ...))
	       (else           ea))))))

  (define-syntax sql-and
    (syntax-rules ()
      ((sql-and a ...)
       (sql-and/null #t a ...))))

  (define-syntax sql-and/null
    (syntax-rules ()
      ((sql-and/null null)
       null)
      ((sql-and/null null a b ...)
       (let ((ea a))
	 (cond ((sql-null? ea) (sql-and/null ea    b ...))
	       (ea             (sql-and/null null b ...))
	       (else           ea))))))

  (define-syntax sql-coalesce
    (syntax-rules ()
      ((sql-coalesce)
       (sql-null))
      ((sql-coalesce a b ...)
       (let ((ea a))
	 (if (sql-null? ea)
	     (sql-coalesce b ...)
	     ea)))))

  )

;;; Foreign types & values

(define (hashtable-walk ht f) 
  (vector-for-each (lambda (x) 
		     (f x (hashtable-ref ht x #f))) 
		   (hashtable-keys ht)))

(define (->string x)
  (with-output-to-string (lambda () (display x))))

(define (conc . args)
    (apply string-append (map ->string args)) )

;; Enumeration and constant definitions
(define sqlite3:status
  '((ok         .  0) ; Successful result (#f?)
    (error      .  1) ; SQL error or missing database
    (internal   .  2) ; NOT USED. Internal logic error in SQLite
    (permission .  3) ; Access permission denied
    (abort      .  4) ; Callback routine requested an abort
    (busy       .  5) ; The database file is locked
    (locked     .  6) ; A table in the database is locked
    (no-memory  .  7) ; A malloc() failed
    (read-only  .  8) ; Attempt to write a readonly database
    (interrupt  .  9) ; Operation terminated by sqlite3_interrupt()
    (io-error   . 10) ; Some kind of disk I/O error occurred
    (corrupt    . 11) ; The database disk image is malformed
    (not-found  . 12) ; NOT USED. Table or record not found
    (full       . 13) ; Insertion failed because database is full
    (cant-open  . 14) ; Unable to open the database file
    (protocol   . 15) ; NOT USED. Database lock protocol error
    (empty      . 16) ; Database is empty
    (schema     . 17) ; The database schema changed
    (too-big    . 18)  ; String or BLOB exceeds size limit
    (constraint . 19) ; Abort due to contraint violation
    (mismatch   . 20) ; Data type mismatch
    (misuse     . 21) ; Library used incorrectly
    (no-lfs     . 22) ; Uses OS features not supported on host
    (auth       . 23) ; Authorization denied
    (format     . 24) ; Auxiliary database format error
    (range      . 25) ; 2nd parameter to sqlite3_bind out of range
    (not-a-db   . 26) ; File opened that is not a database file
    (notice     . 27) ; Notifications from sqlite3_log()
    (warning    . 28) ; Warnings from sqlite3_log()
    (row       . 100) ; sqlite3_step() has another row ready
    (done      . 101) ; sqlite3_step() has finished executing
    ))

(define (number->sqlite3:status status)
  (let ([x (find (lambda (a) (equal? (cdr a) status)) sqlite3:status)])
    (if (pair? x) (car x) #f)))

(define sqlite3:type-enum (make-enumeration '(undefined integer float text blob null)))
(define sqlite3:type-index (enum-set-indexer sqlite3:type-enum))
(define (sqlite3:type-ref index)
  (list-ref (enum-set->list sqlite3:type-enum) index))

;; Auxiliary types

(define-ftype sqlite3:context void*)

(define-ftype sqlite3:value void*)

;; Types for databases and statements

(define-ftype sqlite3:database* void*)

(define-ftype sqlite3:database** (* sqlite3:database*))
                                        ;(define-check+error-type database)
(define-ftype sqlite3:statement* void*)
(define-ftype sqlite3:statement** (* sqlite3:statement*))

(define-record-type (&sqlite3 make-sqlite3-condition $sqlite3-condition?)
  (parent &condition)
  (fields (immutable status $sqlite3-condition-status)))

(define-record-type database
  (fields
   (mutable ptr)
   (mutable busy-handler)))

(define-record-type statement
  (fields
   (mutable ptr)
   (mutable database)))


#;(record-writer
 (type-descriptor statement)
 (lambda (r p wr)
   (wr
    (if (statement-ptr r)
        (format "#<sqlite3:statement sql=~s>" (source-sql r))
        "#<sqlite3:statement zombie>")
    p)))

                                        ;(define-check+error-type statement)


;;; Helpers

;; Conditions
(define rtd (record-type-descriptor &sqlite3))
(define sqlite3-condition? (condition-predicate rtd))
(define sqlite3-status (condition-accessor rtd $sqlite3-condition-status))


(define (make-sqlite3-error-condition loc msg sta . args)
  (condition
   (make-sqlite3-condition sta)
   (make-who-condition loc)
   (make-message-condition msg)
   (make-irritants-condition args)
   ))

(define (make-no-data-condition loc stmt params)
  (make-sqlite3-error-condition loc
                                "the statement returned no data"
                                'done
                                stmt params))

;; Errors
(define (abort-sqlite3-error loc db . args)
  (lambda (sta)
    (if (not (equal? sta 0))
        (raise
         (apply make-sqlite3-error-condition
                loc
                (if db (sqlite3-errmsg db) "sta")
                sta
                args)))))

(define (print-error-message obj port str)
  (display obj port) (display str port) (newline port))

(define (print-error msg obj)
  (print-error-message obj (current-error-port) (string-append "Error: " msg)))

;;; Database interface

;; Get any error message
(define sqlite3_errmsg
  (foreign-procedure "sqlite3_errmsg" (sqlite3:database*) string))
(define (sqlite3-errmsg db)
  (check-database 'sqlite3-errmsg db)
  (sqlite3_errmsg (database-addr db)))

;; Open a database
(define (open-database path)
  (assert (and open-database (string? path)))
  (let* ([ptr (make-ftype-pointer sqlite3:database**
                                  (foreign-alloc (ftype-sizeof sqlite3:database**)))]
         [f (foreign-procedure "sqlite3_open" (string void*) int)]
         [e (f path (ftype-pointer-address ptr))])
    (if (< e 0)
        (abort-sqlite3-error 'open-database #f path)
        (make-database (ftype-&ref sqlite3:database** (*) ptr) #f))))

(define (check-database context db)
  (assert (and context (database? db))))

(define (check-statement context db)
  (assert (and context (statement? db))))

;; Set application busy handler.  Does not use a callback, so it is safe
;; to yield.  Handler is called with DB, COUNT and LAST (the last value
;; it returned).  Return true value to continue trying, or #f to stop.
(define (set-busy-handler! db handler)
  (check-database 'set-busy-handler! db)
  (database-busy-handler-set! db handler))

(define (database-addr db)
  (ftype-pointer-address (database-ptr db)))

(define (statement-addr stmt)
  (ftype-pointer-address (statement-ptr stmt)))

;; Cancel any running database operation as soon as possible
(define (interrupt! db)
  (check-database 'interrupt! db)
  (let ([f (foreign-procedure "sqlite3_interrupt" (sqlite3:database*) void)])
    (f (database-addr db))))

;; Check whether the database is in autocommit mode
(define (auto-committing? db)
  (check-database 'auto-committing? db)
  (let ([f (foreign-procedure "sqlite3_get_autocommit" (sqlite3:database*) boolean)])
    (f (database-addr db))))

;; Get the number of changes made to the database
(define change-count
  (case-lambda
    [(db) (change-count db #f)]
    [(db total)
     (check-database 'change-count db)
     (let ([total-changes (foreign-procedure "sqlite3_total_changes" (sqlite3:database*) int)]
           [changes (foreign-procedure "sqlite3_changes" (sqlite3:database*) int)])
       (if total
           (total-changes (database-addr db))
           (changes (database-addr db))))]))

;; Get the row ID of the last inserted row
(define (last-insert-rowid db)
  (check-database 'last-insert-rowid db)
  (let ([f (foreign-procedure "sqlite3_last_insert_rowid" (sqlite3:database*) int)])
    (f (database-addr db))))

;; Close a database or statement handle
(define (sqlite3-finalize db)
  (check-database 'sqlite3-finalize db)
  (let* ([f (foreign-procedure "sqlite3_finalize"  (sqlite3:database*) int)]
         [n (f (database-addr db))])
    (database-ptr-set! db #f)
    n))

(define (sqlite3-next-stmt db)
  (check-database 'sqlite3-next-stmt db)
  (let* ([f (foreign-procedure "sqlite3_next_stmt" (sqlite3:database*) sqlite3:statement*)]
         [stmt* (f (database-addr db))])
    (make-statement (make-ftype-pointer sqlite3:statement* stmt*)
                    db)))

(define (finalize! x)
  (warning 'finalize! "not implemented!"))
;; #;(define finalize!
;;   (match-lambda*
;;    [((? database? db) . finalize-statements?)
;;      (cond
;;       [(not (database-ptr db))
;;       (void)]
;;       [(let loop ([stmt
;;                   (and
;;                     (optional finalize-statements? #f)
;;                     (sqlite3_next_stmt db #f))])
;;          (if stmt
;;              (or (sqlite3_finalize stmt) (loop (sqlite3_next_stmt db stmt)))
;;              ((foreign-safe-lambda sqlite3:status "sqlite3_close" sqlite3:database) db)))
;;       => (abort-sqlite3-error 'finalize! db db)]
;;       [else
;;       (let ([id (pointer->address (database-ptr db))]
;;             [release-qns (lambda (_ info) (object-release (vector-ref info 0)))])
;;         (call-with/synch *collations*
;;                           (cute hash-table-tree-clear! <> id release-qns))
;;         (call-with/synch *functions*
;;                           (cute hash-table-tree-clear! <> id release-qns))
;;         (database-ptr-set! db #f)
;;         (database-busy-handler-set! db #f))])]
;;    [((? statement? stmt))
;;      (cond
;;       [(not (statement-ptr stmt))
;;       (void)]
;;       [(sqlite3_finalize (statement-ptr stmt))
;;       => (abort-sqlite3-error 'finalize! (statement-database stmt) stmt)]
;;       [else
;;       (statement-ptr-set! stmt #f)])]
;;    [(v . _)
;;      (error-argument-type 'finalize! v "database or statement")]))

;;; Statement interface
(define sqlite3_prepare_v2 (foreign-procedure "sqlite3_prepare_v2"
                                              ( sqlite3:database* u8* int void* u8*) int))
(define (alloc-statement*)
  (make-ftype-pointer sqlite3:statement**
                      (foreign-alloc (ftype-sizeof sqlite3:statement**))))

;; Create a new statement
(define (prepare db sql)
  (check-database 'prepare db)
  (assert (and prepare (string? sql)))
  (let retry ([retries 0])
    (let* ([ptr (alloc-statement*)]
           [zSql (string->utf8 sql)]
           [nByte (bytevector-length zSql)]
           [e (sqlite3_prepare_v2 (database-addr db) zSql nByte (ftype-pointer-address ptr) #f)])
      (cond [(equal? e 0)
             (make-statement (ftype-&ref sqlite3:statement** (*) ptr) db)]
            [else
             (case (number->sqlite3:status e)
               [(busy)
                (let ([h (database-busy-handler db)])
                  (cond
                   [(and h (h db retries))
                    (retry (fx+ retries 1))]
                   [else
                    ((abort-sqlite3-error 'prepare db db sql) e)]))]
               [else
                ((abort-sqlite3-error 'prepare db db sql) e)])]))))

;; Retrieve the SQL source code of a statement
(define (source-sql stmt)
  (check-statement 'source-sql stmt)
  (let* ([f (foreign-procedure "sqlite3_sql" (sqlite3:statement*) string)])
    (f (statement-addr stmt))))

(define (finalize-statement! stmt)
  (check-statement 'finalize-statement! stmt)
  (let* ([f (foreign-procedure "sqlite3_finalize"  (sqlite3:statement*) int)]
         [n (f (statement-addr stmt))])
    (statement-ptr-set! stmt #f)
    n))

;; Reset an existing statement to process it again
(define (reset! stmt)
  (check-statement 'reset! stmt)
  (cond [((foreign-procedure  "sqlite3_reset" (sqlite3:statement*) int)
          (statement-addr stmt))
         => (abort-sqlite3-error 'reset! (statement-database stmt) stmt)]))

;; Get number of bindable parameters
(define (bind-parameter-count stmt)
  (check-statement 'bind-parameter-count stmt)
  ((foreign-procedure "sqlite3_bind_parameter_count" (sqlite3:statement*) int)
   (statement-addr stmt)))

;; Get index of a bindable parameter or #f if no parameter with the
;; given name exists
(define (bind-parameter-index stmt name)
  (check-statement 'bind-parameter-index stmt)
  (let ([i ((foreign-procedure "sqlite3_bind_parameter_index"
                               (sqlite3:statement* string) int)
            (statement-addr stmt) name)])
    (if (zero? i)
        #f
        (fx- i 1))))

;; Get the name of a bindable parameter
(define (bind-parameter-name stmt i)
  (check-statement 'bind-parameter-name stmt)
  ((foreign-procedure "sqlite3_bind_parameter_name" (sqlite3:statement* int) string)
   (statement-addr stmt) (fx+ i 1)))

;; Bind data as parameters to an existing statement

(define SQLITE_TRANSIENT -1)
(define (bind! stmt i v)
  (check-statement 'bind! stmt)
  (assert (and bind! (number? i) (>= i 0)))
  (cond
   [(bytevector? v)
    (cond [((foreign-procedure "sqlite3_bind_blob" (sqlite3:statement* int u8* int void*) int)
            (statement-addr stmt) (fx+ i 1) v (bytevector-length v) SQLITE_TRANSIENT)
           => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])]
   [(or (and (fixnum? v) v) (and (boolean? v) (if v 1 0)))
    => (lambda (v)
         (cond [((foreign-procedure "sqlite3_bind_int"
                                    (sqlite3:statement* int int) int)
                 (statement-addr stmt) (fx+ i 1) v)
                => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)]))]
   [(real? v)
    (cond [((foreign-procedure "sqlite3_bind_double"
                               (sqlite3:statement* int double) int)
            (statement-addr stmt) (fx+ i 1) v)
           => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])]
   [(string? v)
    (let ([f (foreign-procedure "sqlite3_bind_text"
                                (sqlite3:statement* int u8* int void*) int)]
          [s (string->utf8 v)])
      (cond [(f (statement-addr stmt) (fx+ i 1) s (bytevector-length s) SQLITE_TRANSIENT)
             => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)]))]
   [(sql-null? v)
    (cond [((foreign-procedure "sqlite3_bind_null" (sqlite3:statement* int) int)
            (statement-addr stmt) (fx+ i 1))
           => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i)])]
   [else
    (error 'bind! "blob, number, boolean, string or sql-null" v)]))

; Helper

(define (%bind-parameters! loc stmt params)
  (reset! stmt)
  (let ([cnt (bind-parameter-count stmt)]
        [vs (make-eq-hashtable)])
    (let loop ([i 0] [params params])
      (match params
        [((? symbol? k) v . rest)
         (cond
          [(bind-parameter-index stmt (string-append ":" (symbol->string k)))
           => (lambda (j)
                (hashtable-set! vs j v)
                (loop i rest))]
          [else
           (error loc "value or keyword matching a bind parameter name" k)])]
        [(v . rest)
         (hashtable-set! vs i v)
         (loop (fx+ i 1) rest)]
        [()
         (void)]))
    (if (= (hashtable-size vs) cnt)
        (unless (zero? cnt)
          (hashtable-walk vs (cut bind! stmt <> <>)))
        (raise
         (condition
          (make-who-condition loc)
	  (make-message-condition (conc "bad parameter count - received " (hashtable-size vs) " but expected " cnt))
          (make-sqlite3-condition 'error))))))

(define (bind-parameters! stmt . params)
  (%bind-parameters! 'bind-parameters! stmt params))

;; Single-step a prepared statement, return #t if data is available,
;; #f otherwise
(define (step! stmt)
  (check-statement 'step! stmt)
  (let ([db (statement-database stmt)])
    (let retry ([retries 0])
      (let ([s ((foreign-procedure
                 "sqlite3_step" (sqlite3:statement*) int) (statement-addr stmt))])
        (case (number->sqlite3:status s)
          [(row)
           #t]
          [(done)
           #f]
          [(busy)
           (let ([h (database-busy-handler db)])
             (cond
              [(and h (h db retries))
               (retry (fx+ retries 1))]
              [else
               ((abort-sqlite3-error 'step! db stmt) s)]))]
          [else
           ((abort-sqlite3-error 'step! db stmt) s)])))))

;; Retrieve information from a prepared/stepped statement
(define (column-count stmt)
  (check-statement 'column-count stmt)
  ((foreign-procedure "sqlite3_column_count" (sqlite3:statement*) int) (statement-addr stmt)))

(define (column-type stmt i)
  (check-statement 'column-type stmt)
  (sqlite3:type-ref ((foreign-procedure  "sqlite3_column_type" (sqlite3:statement* int) int) (statement-addr stmt) i)))

(define (column-declared-type stmt i)
  (check-statement 'column-declared-type stmt)
  ((foreign-procedure "sqlite3_column_decltype" (sqlite3:statement* int) string) (statement-addr stmt) i))

(define (column-name stmt i)
  (check-statement 'column-name stmt)
  ((foreign-procedure "sqlite3_column_name" (sqlite3:statement* int) string) (statement-addr stmt) i))

(define sqlite3_column_double
  (foreign-procedure "sqlite3_column_double" (sqlite3:statement* int) double))

(define sqlite3_column_boolean
  (foreign-procedure "sqlite3_column_int" (sqlite3:statement* int) boolean))

(define (sqlite3-column-bytes stmt i)
  ((foreign-procedure "sqlite3_column_bytes" (sqlite3:statement* int) int)
   (statement-addr stmt) i))

(define (void*->bytevector ptr len)
  (define-ftype byte-array (array 0 unsigned-8))
  (let ([arr (make-ftype-pointer byte-array ptr)]
        [bv  (make-bytevector len)])
    (let loop ((i 0))
      (when (< i len)
        (bytevector-u8-set! bv i (ftype-ref byte-array (i) arr))
        (loop (fx+ 1 i))))
    bv))

(define (void*->string ptr len)
  (utf8->string (void*->bytevector ptr len)))

(define (sqlite3-column-text stmt i)
  (let* ([ptr ((foreign-procedure "sqlite3_column_text" (sqlite3:statement* int) void*)
               (statement-addr stmt) i)]
         [len (sqlite3-column-bytes stmt i)])
    (void*->string ptr len)))

(define (sqlite3-column-blob stmt i)
  (let* ([ptr ((foreign-procedure "sqlite3_column_blob" (sqlite3:statement* int) void*)
               (statement-addr stmt) i)]
         [len (sqlite3-column-bytes stmt i)])
    (void*->bytevector ptr len)))

;; Retrieve data from a stepped statement
(define (column-data stmt i)
  (case (column-type stmt i)
    [(integer)
     (if (and-let* ([type (column-declared-type stmt i)])
                   (string-contains-ci type "bool"))
         (sqlite3_column_boolean (statement-addr stmt) i)
         (sqlite3_column_double (statement-addr stmt) i))]
    [(float)
     (sqlite3_column_double (statement-addr stmt) i)]
    [(text)
     (sqlite3-column-text stmt i)]
    [(blob)
     (sqlite3-column-blob stmt i)]
    [else
     (sql-null)]))

;;; Easy statement interface

;; Compile a statement and call a procedure on it, then finalize the
;; statement in a dynamic-wind exit block if it hasn't been finalized yet.
(define (call-with-temporary-statements proc db . sqls)
  (check-database 'call-with-temporary-statements db)
  (let ([stmts #f] [exn #f])
    (dynamic-wind
      (lambda ()
        (unless stmts
          (set! stmts (map (cute prepare db <>) sqls))))
      (lambda ()
        (guard (e [else (set! exn e)])
	       (apply proc stmts)))
      (lambda ()
        (and-let* ([s stmts])
                  (set! stmts #f)
                  (for-each finalize! s)) ;; leaks if error occurs before last stmt
        (and-let* ([e exn])
                  (set! exn #f)
                  (raise e))))))

(define-syntax %define/statement+params
  (syntax-rules ()
    [(%define/statement+params ((name loc) (init ...) (stmt params))
                               body ...)
     (define name
       (let ([impl (lambda (init ... stmt params) body ...)])
         (lambda (init ... db-or-stmt . params)
           (cond
            [(database? db-or-stmt)
             (call-with-temporary-statements
              (cute impl init ... <> (cdr params))
              db-or-stmt (car params))]
            [(statement? db-or-stmt)
             (impl init ... db-or-stmt params)]
            [else
             (error loc "database or statement" db-or-stmt)]))))]
    [(%define/statement+params (name (init ...) (stmt params))
                               body ...)
     (%define/statement+params ((name 'name) (init ...) (stmt params))
                               body ...)]
    [(%define/statement+params (name stmt params)
                               body ...)
     (%define/statement+params ((name 'name) () (stmt params))
                               body ...)]))

; from chicken miscmacros.scm
  (define-syntax while
    (syntax-rules ()
      ((while test body ...)
       (let loop ()
         (if test
             (begin
               body ...
               (loop)))))))

;; Step through a statement and ignore possible results
(define (%execute loc stmt params)
  (%bind-parameters! loc stmt params)
  (while (step! stmt))
  (void))

(%define/statement+params (execute stmt params)
                          (%execute 'execute stmt params))

;; Step through a statement, ignore possible results and return the
;; count of changes performed by this statement
(%define/statement+params (update stmt params)
                          (%execute 'update stmt params)
                          (change-count (statement-database stmt)))

;; Return only the first column of the first result row produced by this
;; statement

(%define/statement+params (first-result stmt params)
                          (%bind-parameters! 'first-result stmt params)
                          (if (step! stmt)
                              (let ([r (column-data stmt 0)])
                                (reset! stmt)
                                r)
                              (raise (make-no-data-condition 'first-result stmt params))))

;; Return only the first result row produced by this statement as a list

(%define/statement+params (first-row stmt params)
                          (%bind-parameters! 'first-row stmt params)
                          (if (step! stmt)
                              (map (cute column-data stmt <>)
                                   (iota (column-count stmt)))
                              (raise (make-no-data-condition 'first-row stmt params))))

;; Apply a procedure to the values of the result columns for each result row
;; while executing the statement and accumulating results.

(%define/statement+params ((%fold-row loc) (loc proc init) (stmt params))
                          (%bind-parameters! loc stmt params)
                          (let ([cl (iota (column-count stmt))])
                            (let loop ([acc init])
                              (if (step! stmt)
                                  (loop (apply proc acc (map (cute column-data stmt <>) cl)))
                                  acc))))


(define-syntax check-procedure
  (syntax-rules ()
    [(_ loc proc)
     (assert (and loc (procedure? proc)))]))

(define (fold-row proc init db-or-stmt . params)
  (apply %fold-row 'fold-row proc init db-or-stmt params))

;; Apply a procedure to the values of the result columns for each result row
;; while executing the statement and discard the results

(define (for-each-row proc db-or-stmt . params)
  (check-procedure fold-row proc)
  (apply %fold-row
         'for-each-row
         (lambda (acc . columns)
           (apply proc columns))
         (void)
         db-or-stmt params))

;; Apply a procedure to the values of the result columns for each result row
;; while executing the statement and accumulate the results in a list

(define (map-row proc db-or-stmt . params)
  (check-procedure 'map-row proc)
  (reverse!
   (apply %fold-row
          'map-row
          (lambda (acc . columns)
            (cons (apply proc columns) acc))
          '()
          db-or-stmt params)))

;;; Utility procedures

;; Run a thunk within a database transaction, commit if return value is
;; true, rollback if return value is false or the thunk is interrupted by
;; an exception
(define with-transaction
  (case-lambda
    ((db thunk) (with-transaction db thunk 'deferred))
    ((db thunk type)
     (check-database 'with-transaction db)
     (check-procedure 'with-transaction thunk)
     (unless (memq type '(deferred immediate exclusive))
       (error 'with-transaction  "bad argument: expected deferred, immediate or exclusive")
	 type)
     (let ([success? #f] [exn #f])
       (dynamic-wind
         (lambda ()
           (execute db
                    (string-append "BEGIN " (symbol->string type) " TRANSACTION;")))
         (lambda ()
           (guard (e [else (begin
			     (print-error "with-transaction" exn)
			     (set! exn e))])
		  (set! success? (thunk))
		  success?))
         (lambda ()
           (execute db
                    (if success?
                        "COMMIT TRANSACTION;"
                        "ROLLBACK TRANSACTION;"))
           (and-let* ([e exn])
                     (set! exn #f)
                     (raise e))))))))

;; Check if the given string is a valid SQL statement
(define sql-complete?
  (foreign-procedure "sqlite3_complete" (string) boolean))

;; Return a descriptive version string
(define database-version
  (foreign-procedure "sqlite3_libversion" () string))

;; Return the amount of memory currently allocated by the database
(define database-memory-used
  (foreign-procedure "sqlite3_memory_used" () int))

;; Return the maximum amount of memory allocated by the database since
;; the counter was last reset
(define database-memory-highwater
  (case-lambda
    (() (database-memory-highwater #f))
    ((reset?) ((foreign-procedure "sqlite3_memory_highwater" (boolean) int) reset?))))

;; Enables (disables) the sharing of the database cache and schema data
;; structures between connections to the same database.
(define (enable-shared-cache! enable?)
  (cond-expand
   [disable-shared-cache
    #f]
   [else
    (cond
     [((foreign-procedure "sqlite3_enable_shared_cache" (boolean) int) enable?)
      => (abort-sqlite3-error 'enable-shared-cache! #f)]
     [else
      enable?])]))

;; Enables (disables) the loading of native extensions using SQL statements.
(define (enable-load-extension! db enable?)
  (cond-expand
   [disable-load-extension
    #f]
   [else
    (cond
     [((foreign-procedure "sqlite3_enable_load_extension" (sqlite3:database* boolean) int) (database-addr db) enable?)
      => (abort-sqlite3-error 'enable-load-extension! db)]
     [else
      enable?])]))

(record-writer
 (type-descriptor database)
 (lambda (r p wr)
   (wr
    (if (database-ptr r)
        "#<sqlite3:database>"
        "#<sqlite3:database zombie>")
    p)))