Basic support for pretty printer

6 files changed, 3027 insertions, 0 deletions

diff --git a/src/clojure/contrib/pprint/ColumnWriter.clj b/src/clojure/contrib/pprint/ColumnWriter.clj
new file mode 100644
index 00000000..05fd2fe6
--- /dev/null
+++ b/src/clojure/contrib/pprint/ColumnWriter.clj
@@ -0,0 +1,72 @@
+;   Copyright (c) Tom Faulhaber, Dec 2008. All rights reserved.
+;   The use and distribution terms for this software are covered by the
+;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;   which can be found in the file epl-v10.html at the root of this distribution.
+;   By using this software in any fashion, you are agreeing to be bound by
+;   the terms of this license.
+;   You must not remove this notice, or any other, from this software.
+
+(ns clojure.contrib.pprint.ColumnWriter
+  (:gen-class
+   :extends java.io.Writer
+   :init init
+   :constructors {[java.io.Writer Integer] [], 
+                  [java.io.Writer] []}
+   :methods [[getColumn [] Integer]
+             [getMaxColumn [] Integer]
+             [setMaxColumn [Integer] Void]
+             [getWriter [] java.io.Writer]]
+   :state state))
+
+(def *default-page-width* 72)
+
+(defn- -init 
+  ([writer] (-init writer *default-page-width*))
+  ([writer max-columns] [[] (ref {:max max-columns, :cur 0, :base writer})]))
+
+(defn- get-field [#^clojure.contrib.pprint.ColumnWriter this sym]
+  (sym @(.state this)))
+
+(defn- set-field [#^clojure.contrib.pprint.ColumnWriter this sym new-val] 
+  (alter (.state this) assoc sym new-val))
+
+(defn- -getColumn [this]
+  (get-field this :cur))
+
+(defn- -getMaxColumn [this]
+  (get-field this :max))
+
+(defn- -setMaxColumn [this new-max]
+  (dosync (set-field this :max new-max)))
+
+(defn- -getWriter [this]
+  (get-field this :base))
+
+(declare write-char)
+
+(defn- -write 
+  ([#^clojure.contrib.pprint.ColumnWriter this #^chars cbuf #^Integer off #^Integer len] 
+     (let [#^java.io.Writer writer (get-field this :base)] 
+       (.write writer cbuf off len)))
+  ([#^clojure.contrib.pprint.ColumnWriter this x]
+     (condp = (class x)
+       String 
+       (let [#^String s x
+	     nl (.lastIndexOf s (int \newline))]
+	 (dosync (if (neg? nl)
+		   (set-field this :cur (+ (get-field this :cur) (count s)))
+		   (set-field this :cur (- (count s) nl 1))))
+	 (.write #^java.io.Writer (get-field this :base) s))
+
+       Integer
+       (write-char this x))))
+
+(defn- write-char [#^clojure.contrib.pprint.ColumnWriter this #^Integer c]
+  (dosync (if (= c (int \newline))
+	    (set-field this :cur 0)
+	    (set-field this :cur (inc (get-field this :cur)))))
+  (.write #^java.io.Writer (get-field this :base) c))
+
+(defn- -flush [this]) ;; Currently a no-op
+
+(defn- -close [this]) ;; Currently a no-op
diff --git a/src/clojure/contrib/pprint/PrettyWriter.clj b/src/clojure/contrib/pprint/PrettyWriter.clj
new file mode 100644
index 00000000..710994a6
--- /dev/null
+++ b/src/clojure/contrib/pprint/PrettyWriter.clj
@@ -0,0 +1,449 @@
+;   Copyright (c) Tom Faulhaber, Jan 2009. All rights reserved.
+;   The use and distribution terms for this software are covered by the
+;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;   which can be found in the file epl-v10.html at the root of this distribution.
+;   By using this software in any fashion, you are agreeing to be bound by
+;   the terms of this license.
+;   You must not remove this notice, or any other, from this software.
+
+(ns clojure.contrib.pprint.PrettyWriter
+  (:use clojure.contrib.pprint.utilities)
+  (:gen-class
+   :extends clojure.contrib.pprint.ColumnWriter
+   :init init
+   :constructors {[java.io.Writer Integer Object] [java.io.Writer Integer]}
+   :methods [[startBlock [String String String] void]
+             [endBlock [] void]
+             [newline [clojure.lang.Keyword] void]
+             [indent [clojure.lang.Keyword Integer] void]
+             [getMiserWidth [] Object]
+             [setMiserWidth [Object] void]]
+   :exposes-methods {write col-write}
+   :state pwstate))
+
+;; TODO: Support for tab directives
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Macros to simplify dealing with types and classes. These are
+;;; really utilities, but I'm experimenting with them here.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmacro #^{:private true} 
+  getf 
+  "Get the value of the field a named by the argument (which should be a keyword)."
+  [sym]
+  `(~sym @(.pwstate ~'this)))
+
+(defmacro #^{:private true} 
+  setf [sym new-val] 
+  "Set the value of the field SYM to NEW-VAL"
+  `(alter (.pwstate ~'this) assoc ~sym ~new-val))
+
+(defmacro deftype [type-name & fields]
+  (let [name-str (name type-name)]
+    `(do
+       (defstruct ~type-name :type-tag ~@fields)
+       (defn- ~(symbol (str "make-" name-str)) 
+         [& vals#] (apply struct ~type-name ~(keyword name-str) vals#))
+       (defn- ~(symbol (str name-str "?")) [x#] (= (:type-tag x#) ~(keyword name-str))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The data structures used by PrettyWriter
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defstruct #^{:private true} logical-block
+           :parent :section :start-col :indent
+           :done-nl :intra-block-nl
+           :prefix :per-line-prefix :suffix)
+
+(defn ancestor? [parent child]
+  (loop [child (:parent child)]
+    (cond 
+     (nil? child) false
+     (= parent child) true
+     :else (recur (:parent child)))))
+
+(defstruct #^{:private true} section :parent)
+
+(defmulti blob-length :type-tag)
+(defmethod blob-length :default [_] 0)
+
+(defn buffer-length [l] (reduce + (map blob-length l)))
+
+; A blob of characters (aka a string)
+(deftype buffer-blob :data :trailing-white-space)
+(defmethod blob-length :buffer-blob [b]
+  (+
+   (count (:data b))
+   (count (:trailing-white-space b))))
+
+; A newline
+(deftype nl :type :logical-block)
+
+(deftype start-block :logical-block)
+(defmethod blob-length :start-block [b] (count (:prefix (:logical-block b))))
+
+(deftype end-block :logical-block)
+(defmethod blob-length :end-block [b] (count (:suffix (:logical-block b))))
+
+(deftype indent :logical-block :relative-to :offset)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Initialize the PrettyWriter instance
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- -init 
+  [writer max-columns miser-width]
+  [[writer max-columns] 
+   (let [lb (struct logical-block nil nil (ref 0) (ref 0) (ref false) (ref false))]
+     (ref {:logical-blocks lb 
+           :sections nil
+           :mode :writing
+           :buffer []
+           :buffer-block lb
+           :buffer-level 1
+           :miser-width miser-width
+           :trailing-white-space nil}))])
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Functions to write tokens in the output buffer
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare emit-nl)
+
+(defmulti write-token #(:type-tag %2))
+(defmethod write-token :start-block [#^clojure.contrib.pprint.PrettyWriter this token]
+  (let [lb (:logical-block token)]
+    (dosync
+     (if-let [#^String prefix (:prefix lb)] 
+       (.col-write this prefix))
+     (let [col (.getColumn this)]
+       (ref-set (:start-col lb) col)
+       (ref-set (:indent lb) col)))))
+
+(defmethod write-token :end-block [#^clojure.contrib.pprint.PrettyWriter this token]
+  (if-let [#^String suffix (:suffix (:logical-block token))] 
+    (.col-write this suffix)))
+
+(defmethod write-token :indent [#^clojure.contrib.pprint.PrettyWriter this token]
+  (let [lb (:logical-block token)]
+    (ref-set (:indent lb) 
+             (+ (:offset token)
+                (condp = (:relative-to token)
+		  :block @(:start-col lb)
+		  :current (.getColumn this))))))
+
+(defmethod write-token :buffer-blob [#^clojure.contrib.pprint.PrettyWriter this token]
+  (.col-write this #^String (:data token)))
+
+(defmethod write-token :nl [#^clojure.contrib.pprint.PrettyWriter this token]
+;  (prlabel wt @(:done-nl (:logical-block token)))
+  (if (and (not (= (:type token) :fill))
+           @(:done-nl (:logical-block token)))
+    (emit-nl this token)
+    (if-let [#^String tws (getf :trailing-white-space)]
+      (.col-write this tws)))
+  (dosync (setf :trailing-white-space nil)))
+
+(defn- write-tokens [#^clojure.contrib.pprint.PrettyWriter this tokens force-trailing-whitespace]
+  (doseq [token tokens]
+    (if-not (= (:type-tag token) :nl)
+      (if-let [#^String tws (getf :trailing-white-space)]
+	(.col-write this tws)))
+    (write-token this token)
+    (setf :trailing-white-space (:trailing-white-space token)))
+  (let [#^String tws (getf :trailing-white-space)] 
+    (when (and force-trailing-whitespace tws)
+      (.col-write this tws)
+      (setf :trailing-white-space nil))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; emit-nl? method defs for each type of new line. This makes
+;;; the decision about whether to print this type of new line.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defn- tokens-fit? [#^clojure.contrib.pprint.PrettyWriter this tokens]
+;  (prlabel tf? (.getColumn this) (buffer-length tokens))
+  (< (+ (.getColumn this) (buffer-length tokens))
+     (.getMaxColumn this)))
+
+(defn- linear-nl? [this lb section]
+;  (prlabel lnl? @(:done-nl lb) (tokens-fit? this section))
+  (or @(:done-nl lb)
+      (not (tokens-fit? this section))))
+
+(defn- miser-nl? [#^clojure.contrib.pprint.PrettyWriter this lb section]
+  (let [miser-width (.getMiserWidth this)]
+    (and miser-width
+         (>= @(:start-col lb) (- (.getMaxColumn this) miser-width))
+         (linear-nl? this lb section))))
+
+(defmulti emit-nl? (fn [t _ _ _] (:type t)))
+
+(defmethod emit-nl? :linear [newl this section _]
+  (let [lb (:logical-block newl)]
+    (linear-nl? this lb section)))
+
+(defmethod emit-nl? :miser [newl this section _]
+  (let [lb (:logical-block newl)]
+    (miser-nl? this lb section)))
+
+(defmethod emit-nl? :fill [newl this section subsection]
+  (let [lb (:logical-block newl)]
+    (or @(:intra-block-nl lb)
+        (not (tokens-fit? this subsection))
+        (miser-nl? this lb section))))
+
+(defmethod emit-nl? :mandatory [_ _ _ _]
+  true)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Various support functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defn- get-section [buffer]
+  (let [nl (first buffer) 
+        lb (:logical-block nl)
+        section (seq (take-while #(not (and (nl? %) (ancestor? (:logical-block %) lb)))
+                                 (next buffer)))]
+    [section (seq (drop (inc (count section)) buffer))])) 
+
+(defn- get-sub-section [buffer]
+  (let [nl (first buffer) 
+        lb (:logical-block nl)
+        section (seq (take-while #(let [nl-lb (:logical-block %)]
+                                    (not (and (nl? %) (or (= nl-lb lb) (ancestor? nl-lb lb)))))
+                            (next buffer)))]
+    section)) 
+
+(defn- update-nl-state [lb]
+  (dosync
+   (ref-set (:intra-block-nl lb) false)
+   (ref-set (:done-nl lb) true)
+   (loop [lb (:parent lb)]
+     (if lb
+       (do (ref-set (:done-nl lb) true)
+           (ref-set (:intra-block-nl lb) true)
+           (recur (:parent lb)))))))
+
+(defn emit-nl [#^clojure.contrib.pprint.PrettyWriter this nl]
+  (.col-write this (int \newline))
+  (dosync (setf :trailing-white-space nil))
+  (let [lb (:logical-block nl)
+        #^String prefix (:per-line-prefix lb)] 
+    (if prefix 
+      (.col-write this prefix))
+    (let [#^String istr (apply str (repeat (- @(:indent lb) (count prefix))
+					  \space))] 
+      (.col-write this istr))
+    (update-nl-state lb)))
+
+(defn- split-at-newline [tokens]
+  (let [pre (seq (take-while #(not (nl? %)) tokens))]
+    [pre (seq (drop (count pre) tokens))]))
+
+;;; Methods for showing token strings for debugging
+
+(defmulti tok :type-tag)
+(defmethod tok :nl [token]
+  (:type token))
+(defmethod tok :buffer-blob [token]
+  (str \" (:data token) (:trailing-white-space token) \"))
+(defmethod tok :default [token]
+  (:type-tag token))
+(defn toks [toks] (map tok toks))
+
+;;; write-token-string is called when the set of tokens in the buffer
+;;; is longer than the available space on the line
+
+(defn- write-token-string [this tokens]
+  (let [[a b] (split-at-newline tokens)]
+;;    (prlabel wts (toks a) (toks b))
+    (if a (write-tokens this a false))
+    (if b
+      (let [[section remainder] (get-section b)
+            newl (first b)]
+;;         (prlabel wts (toks section)) (prlabel wts (:type newl)) (prlabel wts (toks remainder)) 
+        (let [do-nl (emit-nl? newl this section (get-sub-section b))
+              result (if do-nl 
+                       (do
+;;                          (prlabel emit-nl (:type newl))
+                         (emit-nl this newl)
+                         (next b))
+                       b)
+              long-section (not (tokens-fit? this result))
+              result (if long-section
+                       (let [rem2 (write-token-string this section)]
+;;;                              (prlabel recurse (toks rem2))
+                         (if (= rem2 section)
+                           (do ; If that didn't produce any output, it has no nls
+                                        ; so we'll force it
+                             (write-tokens this section false)
+                             remainder)
+                           (into [] (concat rem2 remainder))))
+                       result)
+;;              ff (prlabel wts (toks result))
+              ] 
+          result)))))
+
+(defn- write-line [#^clojure.contrib.pprint.PrettyWriter this]
+  (dosync
+   (loop [buffer (getf :buffer)]
+;;     (prlabel wl1 (toks buffer))
+     (setf :buffer (into [] buffer))
+     (if (not (tokens-fit? this buffer))
+       (let [new-buffer (write-token-string this buffer)]
+;;          (prlabel wl new-buffer)
+         (if-not (identical? buffer new-buffer)
+                 (recur new-buffer)))))))
+
+;;; Add a buffer token to the buffer and see if it's time to start
+;;; writing
+(defn- add-to-buffer [#^clojure.contrib.pprint.PrettyWriter this token]
+;  (prlabel a2b token)
+  (dosync
+   (setf :buffer (conj (getf :buffer) token))
+   (if (not (tokens-fit? this (getf :buffer)))
+     (write-line this))))
+
+;;; Write all the tokens that have been buffered
+(defn- write-buffered-output [#^clojure.contrib.pprint.PrettyWriter this]
+  (write-line this)
+  (if-let [buf (getf :buffer)]
+    (do
+      (write-tokens this buf true)
+      (setf :buffer []))))
+
+;;; If there are newlines in the string, print the lines up until the last newline, 
+;;; making the appropriate adjustments. Return the remainder of the string
+(defn- write-initial-lines 
+  [#^clojure.contrib.pprint.PrettyWriter this #^String s] 
+  (let [lines (.split s "\n" -1)]
+    (if (= (count lines) 1)
+      s
+      (dosync 
+       (let [#^String prefix (:per-line-prefix (first (getf :logical-blocks)))] 
+         (if (= :buffering (getf :mode))
+           (do
+             (add-to-buffer this (make-buffer-blob (first lines) nil))
+             (write-buffered-output this))
+           (let [#^String l (first lines)]
+	     (.col-write this l)))
+         (.col-write this (int \newline))
+         (doseq [#^String l (next (butlast lines))]
+           (.col-write this l)
+           (.col-write this (int \newline))
+           (if prefix
+             (.col-write this prefix)))
+         (setf :buffering :writing)
+         (last lines))))))
+
+
+(defn write-white-space [#^clojure.contrib.pprint.PrettyWriter this]
+  (if-let [#^String tws (getf :trailing-white-space)]
+    (dosync
+     (.col-write this tws)
+     (setf :trailing-white-space nil))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Writer overrides
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare write-char)
+
+(defn- -write 
+  ([#^clojure.contrib.pprint.PrettyWriter this x]
+     ;;     (prlabel write x (getf :mode))
+     (condp = (class x)
+       String 
+       (let [#^String s0 (write-initial-lines this x)
+	     #^String s (.replaceFirst s0 "\\s+$" "")
+	     white-space (.substring s0 (count s))
+	     mode (getf :mode)]
+	 (if (= mode :writing)
+	   (dosync
+	    (write-white-space this)
+	    (.col-write this s)
+	    (setf :trailing-white-space white-space))
+	   (add-to-buffer this (make-buffer-blob s white-space))))
+
+       Integer
+       (write-char this x))))
+
+(defn- write-char [#^clojure.contrib.pprint.PrettyWriter this #^Integer c]
+  (if (= (getf :mode) :writing)
+    (do 
+      (write-white-space this)
+      (.col-write this c))
+    (if (= c \newline)
+      (write-initial-lines this "\n")
+      (add-to-buffer this (make-buffer-blob (str (char c)) nil)))))
+
+(defn- -flush [#^clojure.contrib.pprint.PrettyWriter this]
+  (if (= (getf :mode) :buffering)
+    (dosync 
+     (write-tokens this (getf :buffer) true)
+     (setf :buffer []))
+    (write-white-space this)))
+
+(defn- -close [this]
+  (-flush this))                        ;TODO: close underlying stream?
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Methods for PrettyWriter
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- -startBlock 
+  [#^clojure.contrib.pprint.PrettyWriter this 
+   #^String prefix #^String per-line-prefix #^String suffix]
+  (dosync 
+   (let [lb (struct logical-block (getf :logical-blocks) nil (ref 0) (ref 0)
+                    (ref false) (ref false)
+                    prefix per-line-prefix suffix)]
+     (setf :logical-blocks lb)
+     (if (= (getf :mode) :writing)
+       (do
+         (write-white-space this)
+         (if prefix 
+           (.col-write this prefix))
+         (let [col (.getColumn this)]
+           (ref-set (:start-col lb) col)
+           (ref-set (:indent lb) col)))
+       (add-to-buffer this (make-start-block lb))))))
+
+(defn- -endBlock [#^clojure.contrib.pprint.PrettyWriter this]
+  (dosync
+   (let [lb (getf :logical-blocks)]
+     (if (= (getf :mode) :writing)
+       (do
+         (write-white-space this)
+         (if-let [#^String suffix (:suffix lb)]
+           (.col-write this suffix)))
+       (add-to-buffer this (make-end-block lb)))
+     (setf :logical-blocks (:parent lb)))))
+
+(defn- -newline [#^clojure.contrib.pprint.PrettyWriter this type]
+  (dosync 
+   (setf :mode :buffering)
+   (add-to-buffer this (make-nl type (getf :logical-blocks)))))
+
+(defn- -indent [#^clojure.contrib.pprint.PrettyWriter this relative-to offset]
+  (dosync 
+   (let [lb (getf :logical-blocks)]
+     (if (= (getf :mode) :writing)
+       (do
+         (write-white-space this)
+         (ref-set (:indent lb) 
+                  (+ offset (condp = relative-to
+			      :block @(:start-col lb)
+			      :current (.getColumn this)))))
+       (add-to-buffer this (make-indent lb relative-to offset))))))
+
+(defn- -getMiserWidth [#^clojure.contrib.pprint.PrettyWriter this]
+  (getf :miser-width))
+
+(defn- -setMiserWidth [#^clojure.contrib.pprint.PrettyWriter this new-miser-width]
+  (dosync (setf :miser-width new-miser-width)))
+
diff --git a/src/clojure/contrib/pprint/cl-format.clj b/src/clojure/contrib/pprint/cl-format.clj
new file mode 100644
index 00000000..26eda76c
--- /dev/null
+++ b/src/clojure/contrib/pprint/cl-format.clj
@@ -0,0 +1,1737 @@
+;   Copyright (c) Tom Faulhaber, Dec 2008. All rights reserved.
+;   The use and distribution terms for this software are covered by the
+;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;   which can be found in the file epl-v10.html at the root of this distribution.
+;   By using this software in any fashion, you are agreeing to be bound by
+;   the terms of this license.
+;   You must not remove this notice, or any other, from this software.
+
+(in-ns 'clojure.contrib.pprint)
+
+;;; Forward references
+(declare compile-format)
+(declare execute-format)
+(declare init-navigator)
+;;; End forward references
+
+(defn cl-format 
+  "An implementation of a Common Lisp compatible format function"
+  [stream format-in & args]
+  (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)
+        navigator (init-navigator args)]
+    (execute-format stream compiled-format navigator)))
+
+(def #^{:private true} *format-str* nil)
+
+(defn- format-error [message offset] 
+  (let [full-message (str message \newline *format-str* \newline 
+                           (apply str (repeat offset \space)) "^" \newline)]
+    (throw (RuntimeException. full-message))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Argument navigators manage the argument list
+;;; as the format statement moves through the list
+;;; (possibly going forwards and backwards as it does so)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defstruct #^{:private true}
+  arg-navigator :seq :rest :pos )
+
+(defn init-navigator [s]
+  "Create a new arg-navigator from the sequence with the position set to 0"
+  (let [s (seq s)]
+    (struct arg-navigator s s 0)))
+
+;; TODO call format-error with offset
+(defn- next-arg [ navigator ]
+  (let [ rst (:rest navigator) ]
+    (if rst
+      [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))]
+      (throw (new Exception  "Not enough arguments for format definition")))))
+
+(defn- next-arg-or-nil [navigator]
+  (let [rst (:rest navigator)]
+    (if rst
+      [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))]
+      [nil navigator])))
+
+;; Get an argument off the arg list and compile it if it's not already compiled
+(defn- get-format-arg [navigator]
+  (let [[raw-format navigator] (next-arg navigator)
+        compiled-format (if (instance? String raw-format) 
+                               (compile-format raw-format)
+                               raw-format)]
+    [compiled-format navigator]))
+
+(declare relative-reposition)
+
+(defn- absolute-reposition [navigator position]
+  (if (>= position (:pos navigator))
+    (relative-reposition navigator (- (:pos navigator) position))
+    (struct arg-navigator (:seq navigator) (drop position (:seq navigator)) position)))
+
+(defn- relative-reposition [navigator position]
+  (let [newpos (+ (:pos navigator) position)]
+    (if (neg? position)
+      (absolute-reposition navigator newpos)
+      (struct arg-navigator (:seq navigator) (drop position (:rest navigator)) newpos))))
+
+(defstruct #^{:private true}
+  compiled-directive :func :def :params :offset)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; When looking at the parameter list, we may need to manipulate
+;;; the argument list as well (for 'V' and '#' parameter types).
+;;; We hide all of this behind a function, but clients need to
+;;; manage changing arg navigator
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; TODO: validate parameters when they come from arg list
+(defn- realize-parameter [[param [raw-val offset]] navigator]
+  (let [[real-param new-navigator]
+        (cond 
+         (contains? #{ :at :colon } param) ;pass flags through unchanged - this really isn't necessary
+         [raw-val navigator]
+
+         (= raw-val :parameter-from-args) 
+         (next-arg navigator)
+
+         (= raw-val :remaining-arg-count) 
+         [(count (:rest navigator)) navigator]
+
+         true 
+         [raw-val navigator])]
+    [[param [real-param offset]] new-navigator]))
+         
+(defn- realize-parameter-list [parameter-map navigator]
+  (let [[pairs new-navigator] 
+        (map-passing-context realize-parameter navigator parameter-map)]
+    [(into {} pairs) new-navigator]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Functions that support individual directives
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Common handling code for ~A and ~S
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- format-ascii [print-func params arg-navigator offsets]
+  (let [ [arg arg-navigator] (next-arg arg-navigator) 
+         #^String base-output (print-func arg)
+         base-width (.length base-output)
+         min-width (+ base-width (:minpad params))
+         width (if (>= min-width (:mincol params)) 
+                 min-width
+                 (+ min-width 
+                    (* (+ (quot (- (:mincol params) min-width 1) 
+                                (:colinc params) )
+                          1)
+                       (:colinc params))))
+         chars (apply str (repeat (- width base-width) (:padchar params)))]
+    (if (:at params)
+      (print (str chars base-output))
+      (print (str base-output chars)))
+    arg-navigator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for the integer directives ~D, ~X, ~O, ~B and some
+;;; of ~R
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- integral? [x]
+  "returns true if a number is actually an integer (that is, has no fractional part)"
+  (cond
+   (integer? x) true
+   (decimal? x) (>= (.ulp (.stripTrailingZeros (bigdec 0))) 1) ; true iff no fractional part
+   (float? x)   (= x (Math/floor x))
+   (ratio? x)   (let [#^clojure.lang.Ratio r x]
+                  (= 0 (rem (.numerator r) (.denominator r))))
+   :else        false))
+
+(defn- remainders [base val]
+  "Return the list of remainders (essentially the 'digits') of val in the given base"
+  (reverse 
+   (first 
+    (consume #(if (pos? %) 
+                [(rem % base) (quot % base)] 
+                [nil nil]) 
+             val))))
+
+(defn- base-str [base val]
+  "Return val as a string in the given base"
+  (let [xlated-val (cond
+                    (float? val) (bigdec val)
+                    (ratio? val) (let [#^clojure.lang.Ratio r val] 
+                                   (/ (.numerator r) (.denominator r)))
+                    :else val)] 
+    (apply str 
+          (map 
+           #(if (< % 10) (char (+ (int \0) %)) (char (+ (int \a) (- % 10)))) 
+           (remainders base val)))))
+
+(def #^{:private true}
+     java-base-formats {8 "%o", 10 "%d", 16 "%x"})
+
+(defn- opt-base-str [base val]
+  "Return val as a string in the given base, using clojure.core/format if supported
+for improved performance"
+  (let [format-str (get java-base-formats base)]
+    (if (and format-str (integer? val))
+      (clojure.core/format format-str val)
+      (base-str base val))))
+
+(defn- group-by [unit lis]
+  (reverse
+   (first
+    (consume (fn [x] [(seq (reverse (take unit x))) (seq (drop unit x))]) (reverse lis)))))
+
+(defn- format-integer [base params arg-navigator offsets]
+  (let [[arg arg-navigator] (next-arg arg-navigator)]
+    (if (integral? arg)
+      (let [neg (neg? arg)
+            pos-arg (if neg (- arg) arg)
+            raw-str (opt-base-str base pos-arg)
+            group-str (if (:colon params)
+                        (let [groups (map #(apply str %) (group-by (:commainterval params) raw-str))
+                              commas (repeat (count groups) (:commachar params))]
+                          (apply str (next (interleave commas groups))))
+                        raw-str)
+            #^String signed-str (cond
+                                  neg (str "-" group-str)
+                                  (:at params) (str "+" group-str)
+                                  true group-str)
+            padded-str (if (< (.length signed-str) (:mincol params))
+                         (str (apply str (repeat (- (:mincol params) (.length signed-str)) 
+                                                 (:padchar params)))
+                              signed-str)
+                         signed-str)]
+        (print padded-str))
+      (format-ascii print-str {:mincol (:mincol params) :colinc 1 :minpad 0 
+                               :padchar (:padchar params) :at true} 
+                    (init-navigator [arg]) nil))
+    arg-navigator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for english formats (~R and ~:R)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def #^{:private true}
+     english-cardinal-units 
+     ["zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"
+      "ten" "eleven" "twelve" "thirteen" "fourteen"
+      "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"])
+
+(def #^{:private true}
+     english-ordinal-units 
+     ["zeroth" "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth"
+      "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth"
+      "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"])
+
+(def #^{:private true}
+     english-cardinal-tens
+     ["" "" "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety"])
+
+(def #^{:private true}
+     english-ordinal-tens
+     ["" "" "twentieth" "thirtieth" "fortieth" "fiftieth"
+      "sixtieth" "seventieth" "eightieth" "ninetieth"])
+
+;; We use "short scale" for our units (see http://en.wikipedia.org/wiki/Long_and_short_scales)
+;; Number names from http://www.jimloy.com/math/billion.htm
+;; We follow the rules for writing numbers from the Blue Book
+;; (http://www.grammarbook.com/numbers/numbers.asp)
+(def #^{:private true}
+     english-scale-numbers 
+     ["" "thousand" "million" "billion" "trillion" "quadrillion" "quintillion" 
+      "sextillion" "septillion" "octillion" "nonillion" "decillion" 
+      "undecillion" "duodecillion" "tredecillion" "quattuordecillion" 
+      "quindecillion" "sexdecillion" "septendecillion" 
+      "octodecillion" "novemdecillion" "vigintillion"])
+
+(defn- format-simple-cardinal [num]
+  "Convert a number less than 1000 to a cardinal english string"
+  (let [hundreds (quot num 100)
+        tens (rem num 100)]
+    (str
+     (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred"))
+     (if (and (pos? hundreds) (pos? tens)) " ")
+     (if (pos? tens) 
+       (if (< tens 20) 
+         (nth english-cardinal-units tens)
+         (let [ten-digit (quot tens 10)
+               unit-digit (rem tens 10)]
+           (str
+            (if (pos? ten-digit) (nth english-cardinal-tens ten-digit))
+            (if (and (pos? ten-digit) (pos? unit-digit)) "-")
+            (if (pos? unit-digit) (nth english-cardinal-units unit-digit)))))))))
+
+(defn- add-english-scales [parts offset]
+  "Take a sequence of parts, add scale numbers (e.g., million) and combine into a string
+offset is a factor of 10^3 to multiply by"
+  (let [cnt (count parts)]
+    (loop [acc []
+           pos (dec cnt)
+           this (first parts)
+           remainder (next parts)]
+      (if (nil? remainder)
+        (str (apply str (interpose ", " acc))
+             (if (and (not (empty? this)) (not (empty? acc))) ", ")
+             this
+             (if (and (not (empty? this)) (pos? (+ pos offset)))
+               (str " " (nth english-scale-numbers (+ pos offset)))))
+        (recur 
+         (if (empty? this)
+           acc
+           (conj acc (str this " " (nth english-scale-numbers (+ pos offset)))))
+         (dec pos)
+         (first remainder)
+         (next remainder))))))
+
+(defn- format-cardinal-english [params navigator offsets]
+  (let [[arg navigator] (next-arg navigator)]
+    (if (= 0 arg)
+      (print "zero")
+      (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs
+            parts (remainders 1000 abs-arg)]
+        (if (<= (count parts) (count english-scale-numbers))
+          (let [parts-strs (map format-simple-cardinal parts)
+                full-str (add-english-scales parts-strs 0)]
+            (print (str (if (neg? arg) "minus ") full-str)))
+          (format-integer ;; for numbers > 10^63, we fall back on ~D
+           10
+           { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true}
+           (init-navigator [arg])
+           { :mincol 0, :padchar 0, :commachar 0 :commainterval 0}))))
+    navigator))
+
+(defn- format-simple-ordinal [num]
+  "Convert a number less than 1000 to a ordinal english string
+Note this should only be used for the last one in the sequence"
+  (let [hundreds (quot num 100)
+        tens (rem num 100)]
+    (str
+     (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred"))
+     (if (and (pos? hundreds) (pos? tens)) " ")
+     (if (pos? tens) 
+       (if (< tens 20) 
+         (nth english-ordinal-units tens)
+         (let [ten-digit (quot tens 10)
+               unit-digit (rem tens 10)]
+           (if (and (pos? ten-digit) (not (pos? unit-digit)))
+             (nth english-ordinal-tens ten-digit)
+             (str
+              (if (pos? ten-digit) (nth english-cardinal-tens ten-digit))
+              (if (and (pos? ten-digit) (pos? unit-digit)) "-")
+              (if (pos? unit-digit) (nth english-ordinal-units unit-digit))))))
+       (if (pos? hundreds) "th")))))
+
+(defn- format-ordinal-english [params navigator offsets]
+  (let [[arg navigator] (next-arg navigator)]
+    (if (= 0 arg)
+      (print "zeroth")
+      (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs
+            parts (remainders 1000 abs-arg)]
+        (if (<= (count parts) (count english-scale-numbers))
+          (let [parts-strs (map format-simple-cardinal (drop-last parts))
+                head-str (add-english-scales parts-strs 1)
+                tail-str (format-simple-ordinal (last parts))]
+            (print (str (if (neg? arg) "minus ") 
+                        (cond 
+                         (and (not (empty? head-str)) (not (empty? tail-str))) 
+                         (str head-str ", " tail-str)
+                         
+                         (not (empty? head-str)) (str head-str "th")
+                         :else tail-str))))
+          (do (format-integer ;; for numbers > 10^63, we fall back on ~D
+               10
+               { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true}
+               (init-navigator [arg])
+               { :mincol 0, :padchar 0, :commachar 0 :commainterval 0})
+              (let [low-two-digits (rem arg 100)
+                    not-teens (or (< 11 low-two-digits) (> 19 low-two-digits))
+                    low-digit (rem low-two-digits 10)]
+                (print (cond 
+                        (and (= low-digit 1) not-teens) "st"
+                        (and (= low-digit 2) not-teens) "nd"
+                        (and (= low-digit 3) not-teens) "rd"
+                        :else "th")))))))
+    navigator))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for roman numeral formats (~@R and ~@:R)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def #^{:private true}
+     old-roman-table
+     [[ "I" "II" "III" "IIII" "V" "VI" "VII" "VIII" "VIIII"]
+      [ "X" "XX" "XXX" "XXXX" "L" "LX" "LXX" "LXXX" "LXXXX"]
+      [ "C" "CC" "CCC" "CCCC" "D" "DC" "DCC" "DCCC" "DCCCC"]
+      [ "M" "MM" "MMM"]])
+
+(def #^{:private true}
+     new-roman-table
+     [[ "I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX"]
+      [ "X" "XX" "XXX" "XL" "L" "LX" "LXX" "LXXX" "XC"]
+      [ "C" "CC" "CCC" "CD" "D" "DC" "DCC" "DCCC" "CM"]
+      [