Moved cl_format back to having a "-" in the name because apparently load

deals with this differently than use.

1 files changed, 1746 insertions, 0 deletions

diff --git a/src/clojure/contrib/pprint/cl-format.clj b/src/clojure/contrib/pprint/cl-format.clj
new file mode 100644
index 00000000..69c39a32
--- /dev/null
+++ b/src/clojure/contrib/pprint/cl-format.clj
@@ -0,0 +1,1746 @@
+;;; cl-format.clj -- part of the pretty printer for Clojure
+
+;; by Tom Faulhaber
+;; April 3, 2009
+
+;   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.
+
+;; This module implements the Common Lisp compatible format function as documented
+;; in "Common Lisp the Language, 2nd edition", Chapter 22 (available online at:
+;; http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000)
+
+(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"]
+      [ "M" "MM" "MMM"]])
+
+(defn- format-roman [table params navigator offsets]
+  "Format a roman numeral using the specified look-up table"
+  (let [[arg navigator] (next-arg navigator)]
+    (if (and (number? arg) (> arg 0) (< arg 4000))
+      (let [digits (remainders 10 arg)]
+        (loop [acc []
+               pos (dec (count digits))
+               digits digits]
+          (if (empty? digits)
+            (print (apply str acc))
+            (let [digit (first digits)]
+              (recur (if (= 0 digit) 
+                       acc 
+                       (conj acc (nth (nth table pos) (dec digit))))
+                     (dec pos)
+                     (next digits))))))
+      (format-integer ;; for anything <= 0 or > 3999, 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-old-roman [params navigator offsets]
+  (format-roman old-roman-table params navigator offsets))
+
+(defn- format-new-roman [params navigator offsets]
+  (format-roman new-roman-table params navigator offsets))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for character formats (~C)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def #^{:private true} 
+     special-chars { 8 "Backspace", 9 "Tab",  10 "Newline", 13 "Return", 32 "Space"})
+
+(defn- pretty-character [params navigator offsets]
+  (let [[c navigator] (next-arg navigator)
+        as-int (int c)
+        base-char (bit-and as-int 127)
+        meta (bit-and as-int 128)
+        special (get special-chars base-char)]
+    (if (> meta 0) (print "Meta-"))
+    (print (cond
+            special special
+            (< base-char 32) (str "Control-" (char (+ base-char 64)))
+            (= base-char 127) "Control-?"
+            :else (char base-char)))
+    navigator))
+
+(defn- readable-character [params navigator offsets]
+  (let [[c navigator] (next-arg navigator)]
+    (condp = (:char-format params)
+      \o (cl-format true "\\o~3,'0o" (int c))
+      \u (cl-format true "\\u~4,'0x" (int c))
+      nil (pr c))
+    navigator))
+
+(defn- plain-character [params navigator offsets]
+  (let [[char navigator] (next-arg navigator)]
+    (print char)
+    navigator))
+
+;; Check to see if a result is an abort (~^) construct
+;; TODO: move these funcs somewhere more appropriate
+(defn- abort? [context]
+  (let [token (first context)]
+    (or (= :up-arrow token) (= :colon-up-arrow token))))
+
+;; Handle the execution of "sub-clauses" in bracket constructions
+(defn- execute-sub-format [format args base-args]
+  (second
+   (map-passing-context 
+    (fn [element context]
+      (if (abort? context)
+        [nil context] ; just keep passing it along
+        (let [[params args] (realize-parameter-list (:params element) context)
+              [params offsets] (unzip-map params)
+              params (assoc params :base-args base-args)]
+          [nil (apply (:func element) [params args offsets])])))
+    args
+    format)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for real number formats
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; TODO - return exponent as int to eliminate double conversion
+(defn- float-parts-base
+  "Produce string parts for the mantissa (normalized 1-9) and exponent"
+  [#^Object f]
+  (let [#^String s (.toLowerCase (.toString f))
+        exploc (.indexOf s (int \e))]
+    (if (neg? exploc)
+      (let [dotloc (.indexOf s (int \.))]
+        (if (neg? dotloc)
+          [s (str (dec (count s)))]
+          [(str (subs s 0 dotloc) (subs s (inc dotloc))) (str (dec dotloc))]))
+      [(str (subs s 0 1) (subs s 2 exploc)) (subs s (inc exploc))])))
+
+
+(defn- float-parts [f]
+  "Take care of leading and trailing zeros in decomposed floats"
+  (let [[m #^String e] (float-parts-base f)
+        m1 (rtrim m \0)
+        m2 (ltrim m1 \0)
+        delta (- (count m1) (count m2))
+        #^String e (if (and (pos? (count e)) (= (nth e 0) \+)) (subs e 1) e)]
+    (if (empty? m2)
+      ["0" 0]
+      [m2 (- (Integer/valueOf e) delta)])))
+
+(defn- round-str [m e d w]
+  (if (or d w)
+    (let [len (count m)
+          round-pos (if d (+ e d 1))
+          round-pos (if (and w (< (inc e) (dec w)) 
+                             (or (nil? round-pos) (< (dec w) round-pos)))
+                      (dec w)
+                      round-pos)
+          [m1 e1 round-pos len] (if (= round-pos 0) 
+                                  [(str "0" m) (inc e) 1 (inc len)]
+                                  [m e round-pos len])]
+      (if round-pos
+        (if (> len round-pos)
+          (let [round-char (nth m1 round-pos)
+                #^String result (subs m1 0 round-pos)]
+            (if (>= (int round-char) (int \5))
+              (let [result-val (Integer/valueOf result)
+                    leading-zeros (subs result 0 (min (prefix-count result \0) (- round-pos 1)))
+                    round-up-result (str leading-zeros
+                                         (String/valueOf (+ result-val 
+                                                            (if (neg? result-val) -1 1))))
+                    expanded (> (count round-up-result) (count result))]
+                [round-up-result e1 expanded])
+              [result e1 false]))
+          [m e false])
+        [m e false]))
+    [m e false]))
+
+(defn- expand-fixed [m e d]
+  (let [m1 (if (neg? e) (str (apply str (repeat (dec (- e)) \0)) m) m)
+        len (count m1)
+        target-len (if d (+ e d 1) (inc e))]
+    (if (< len target-len) 
+      (str m1 (apply str (repeat (- target-len len) \0))) 
+      m1)))
+
+(defn- insert-decimal [m e]
+  "Insert the decimal point at the right spot in the number to match an exponent"
+  (if (neg? e)
+    (str "." m)
+    (let [loc (inc e)]
+      (str (subs m 0 loc) "." (subs m loc)))))
+
+(defn- get-fixed [m e d]
+  (insert-decimal (expand-fixed m e d) e))
+
+(defn- insert-scaled-decimal [m k]
+  "Insert the decimal point at the right spot in the number to match an exponent"
+  (if (neg? k)
+    (str "." m)
+    (str (subs m 0 k) "." (subs m k))))
+
+;; the function to render ~F directives
+;; TODO: support rationals. Back off to ~D/~A is the appropriate cases
+(defn- fixed-float [params navigator offsets]
+  (let [w (:w params)
+        d (:d params)
+        [arg navigator] (next-arg navigator)
+        [mantissa exp] (float-parts arg)
+        scaled-exp (+ exp (:k params))
+        add-sign (and (:at params) (not (neg? arg)))
+        prepend-zero (< -1.0 arg 1.0)
+        append-zero (and (not d) (<= (dec (count mantissa)) scaled-exp))
+        [rounded-mantissa scaled-exp] (round-str mantissa scaled-exp 
+                                                 d (if w (- w (if add-sign 1 0))))
+        fixed-repr (get-fixed rounded-mantissa scaled-exp d)]
+    (if w
+      (let [len (count fixed-repr)
+            signed-len (if add-sign (inc len) len)
+            prepend-zero (and prepend-zero (not (= signed-len w)))
+            append-zero (and append-zero (not (= signed-len w)))
+            full-len (if (or prepend-zero append-zero)
+                       (inc signed-len) 
+                       signed-len)]
+        (if (and (> full-len w) (:overflowchar params))
+          (print (apply str (repeat w (:overflowchar params))))
+          (print (str
+                  (apply str (repeat (- w full-len) (:padchar params)))
+                  (if add-sign "+") 
+                  (if prepend-zero "0")
+                  fixed-repr
+                  (if append-zero "0")))))
+      (print (str
+              (if add-sign "+") 
+              (if prepend-zero "0")
+              fixed-repr
+              (if append-zero "0"))))
+    navigator))
+
+
+;; the function to render ~E directives
+;; TODO: support rationals. Back off to ~D/~A is the appropriate cases
+;; TODO: define ~E representation for Infinity
+(defn- exponential-float [params navigator offsets]
+  (let [[arg navigator] (next-arg navigator)]
+    (loop [[mantissa exp] (float-parts (if (neg? arg) (- arg) arg))]
+      (let [w (:w params)
+            d (:d params)
+            e (:e params)
+            k (:k params)
+            expchar (or (:exponentchar params) \E)
+            add-sign (or (:at params) (neg? arg))
+            prepend-zero (<= k 0)
+            #^Integer scaled-exp (- exp (dec k))
+            scaled-exp-str (str (Math/abs scaled-exp))
+            scaled-exp-str (str expchar (if (neg? scaled-exp) \- \+) 
+                                (if e (apply str 
+                                             (repeat 
+                                              (- e 
+                                                 (count scaled-exp-str)) 
+                                              \0))) 
+                                scaled-exp-str)
+            exp-width (count scaled-exp-str)
+            base-mantissa-width (count mantissa)
+            scaled-mantissa (str (apply str (repeat (- k) \0))
+                                 mantissa
+                                 (if d 
+                                   (apply str 
+                                          (repeat 
+                                           (- d (dec base-mantissa-width)
+                                              (if (neg? k) (- k) 0)) \0))))
+            w-mantissa (if w (- w exp-width))
+            [rounded-mantissa _ incr-exp] (round-str 
+                                           scaled-mantissa 0
+                                           (cond
+                                            (= k 0) (dec d)
+                                            (pos? k) d
+                                            (neg? k) (dec d))
+                                           (if w-mantissa 
+                                             (- w-mantissa (if add-sign 1 0))))
+            full-mantissa (insert-scaled-decimal rounded-mantissa k)
+            append-zero (and (= k (count rounded-mantissa)) (nil? d))]
+        (if (not incr-exp)
+          (if w
+            (let [len (+ (count full-mantissa) exp-width)
+                  signed-len (if add-sign (inc len) len)
+                  prepend-zero (and prepend-zero (not (= signed-len w)))
+                  full-len (if prepend-zero (inc signed-len) signed-len)
+                  append-zero (and append-zero (< full-len w))]
+              (if (and (or (> full-len w) (and e (> (- exp-width 2) e)))
+                       (:overflowchar params))
+                (print (apply str (repeat w (:overflowchar params))))
+                (print (str
+                        (apply str 
+                               (repeat 
+                                (- w full-len (if append-zero 1 0) )
+                                (:padchar params)))
+                        (if add-sign (if (neg? arg) \- \+)) 
+                        (if prepend-zero "0")
+                        full-mantissa
+                        (if append-zero "0")
+                        scaled-exp-str))))
+            (print (str
+                    (if add-sign (if (neg? arg) \- \+)) 
+                    (if prepend-zero "0")
+                    full-mantissa
+                    (if append-zero "0")
+                    scaled-exp-str)))
+          (recur [rounded-mantissa (inc exp)]))))
+    navigator))
+
+;; the function to render ~G directives
+;; This just figures out whether to pass the request off to ~F or ~E based 
+;; on the algorithm in CLtL.
+;; TODO: support rationals. Back off to ~D/~A is the appropriate cases
+;; TODO: refactor so that float-parts isn't called twice
+(defn- general-float [params navigator offsets]
+  (let [[arg _] (next-arg navigator)
+        [mantissa exp] (float-parts (if (neg? arg) (- arg) arg))
+        w (:w params)
+        d (:d params)
+        e (:e params)
+        n (if (= arg 0.0) 0 (inc exp))
+        ee (if e (+ e 2) 4)
+        ww (if w (- w ee))
+        d (if d d (max (count mantissa) (min n 7)))
+        dd (- d n)]
+    (if (<= 0 dd d)
+      (let [navigator (fixed-float {:w ww, :d dd, :k 0, 
+                                    :overflowchar (:overflowchar params),
+                                    :padchar (:padchar params), :at (:at params)} 
+                                   navigator offsets)]
+        (print (apply str (repeat ee \space)))
+        navigator)
+      (exponential-float params navigator offsets))))
+
+;; the function to render ~$ directives
+;; TODO: support rationals. Back off to ~D/~A is the appropriate cases
+(defn- dollar-float [params navigator offsets]
+  (let [[#^Double arg navigator] (next-arg navigator)
+        [mantissa exp] (float-parts (Math/abs arg))
+        d (:d params) ; digits after the decimal
+        n (:n params) ; minimum digits before the decimal
+        w (:w params) ; minimum field width
+        add-sign (and (:at params) (not (neg? arg)))
+        [rounded-mantissa scaled-exp _] (round-str mantissa exp d nil)
+        #^String fixed-repr (get-fixed rounded-mantissa scaled-exp d)
+        full-repr (str (apply str (repeat (- n (.indexOf fixed-repr (int \.))) \0)) fixed-repr)
+        full-len (+ (count full-repr) (if add-sign 1 0))]
+    (print (str
+            (if (and (:colon params) add-sign) (if (neg? arg) \- \+))
+            (apply str (repeat (- w full-len) (:padchar params)))
+            (if (and (not (:colon params)) add-sign) (if (neg? arg) \- \+))
+            full-repr))
+    navigator))
+        
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for the '~[...~]' conditional construct in its
+;;; different flavors
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; ~[...~] without any modifiers chooses one of the clauses based on the param or 
+;; next argument
+;; TODO check arg is positive int
+(defn- choice-conditional [params arg-navigator offsets]
+  (let [arg (:selector params)
+        [arg navigator] (if arg [arg arg-navigator] (next-arg arg-navigator))
+        clauses (:clauses params)
+        clause (if (or (neg? arg) (>= arg (count clauses)))
+                 (first (:else params))
+                 (nth clauses arg))]
+    (if clause
+      (execute-sub-format clause navigator (:base-args params))
+      navigator)))
+
+;; ~:[...~] with the colon reads the next argument treating it as a truth value
+(defn- boolean-conditional [params arg-navigator offsets]
+  (let [[arg navigator] (next-arg arg-navigator)
+        clauses (:clauses params)
+        clause (if arg
+                 (second clauses)
+                 (first clauses))]
+    (if clause
+      (execute-sub-format clause navigator (:base-args params))
+      navigator)))
+
+;; ~@[...~] with the at sign executes the conditional if the next arg is not
+;; nil/false without consuming the arg
+(defn- check-arg-conditional [params arg-navigator offsets]
+  (let [[arg navigator] (next-arg arg-navigator)
+        clauses (:clauses params)
+        clause (if arg (first clauses))]
+    (if arg
+      (if clause
+        (execute-sub-format clause arg-navigator (:base-args params))
+        arg-navigator)
+      navigator)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for the '~{...~}' iteration construct in its
+;;; different flavors
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;; ~{...~} without any modifiers uses the next argument as an argument list that 
+;; is consumed by all the iterations
+(defn- iterate-sublist [params navigator offsets]
+  (let [max-count (:max-iterations params)
+        param-clause (first (:clauses params))
+        [clause navigator] (if (empty? param-clause) 
+                             (get-format-arg navigator)
+                             [param-clause navigator]) 
+        [arg-list navigator] (next-arg navigator)
+        args (init-navigator arg-list)]
+    (loop [count 0
+           args args
+           last-pos -1]
+      (if (and (not max-count) (= (:pos args) last-pos) (> count 1))
+        ;; TODO get the offset in here and call format exception
+        (throw (RuntimeException. "%{ construct not consuming any arguments: Infinite loop!")))
+      (if (or (and (empty? (:rest args))
+                   (or (not (:colon (:right-params params))) (> count 0)))
+              (and max-count (>= count max-count)))
+        navigator
+        (let [iter-result (execute-sub-format clause args (:base-args params))] 
+          (if (= :up-arrow (first iter-result))
+            navigator
+            (recur (inc count) iter-result (:pos args))))))))
+
+;; ~:{...~} with the colon treats the next argument as a list of sublists. Each of the
+;; sublists is used as the arglist for a single iteration.
+(defn- iterate-list-of-sublists [params navigator offsets]
+  (let [max-count (:max-iterations params)
+        param-clause (first (:clauses params))
+        [clause navigator] (if (empty? param-clause) 
+                             (get-format-arg navigator)
+                             [param-clause navigator]) 
+        [arg-list navigator] (next-arg navigator)]
+    (loop [count 0
+           arg-list arg-list]
+      (if (or (and (empty? arg-list)
+                   (or (not (:colon (:right-params params))) (> count 0)))
+              (and max-count (>= count max-count)))
+        navigator
+        (let [iter-result (execute-sub-format 
+                           clause 
+                           (init-navigator (first arg-list))
+                           (init-navigator (next arg-list)))]
+          (if (= :colon-up-arrow (first iter-result))
+            navigator
+            (recur (inc count) (next arg-list))))))))
+
+;; ~@{...~} with the at sign uses the main argument list as the arguments to the iterations
+;; is consumed by all the iterations
+(defn- iterate-main-list [params navigator offsets]
+  (let [max-count (:max-iterations params)
+        param-clause (first (:clauses params))
+        [clause navigator] (if (empty? param-clause) 
+                             (get-format-arg navigator)
+                             [param-clause navigator])]
+    (loop [count 0
+           navigator navigator
+           last-pos -1]
+      (if (and (not max-count) (= (:pos navigator) last-pos) (> count 1))
+        ;; TODO get the offset in here and call format exception
+        (throw (RuntimeException. "%@{ construct not consuming any arguments: Infinite loop!")))
+      (if (or (and (empty? (:rest navigator))
+                   (or (not (:colon (:right-params params))) (> count 0)))
+              (and max-count (>= count max-count)))
+        navigator
+        (let [iter-result (execute-sub-format clause navigator (:base-args params))] 
+          (if (= :up-arrow (first iter-result))
+            (second iter-result)
+            (recur 
+             (inc count) iter-result (:pos navigator))))))))
+
+;; ~@:{...~} with both colon and at sign uses the main argument list as a set of sublists, one
+;; of which is consumed with each iteration
+(defn- iterate-main-sublists [params navigator offsets]
+  (let [max-count (:max-iterations params)
+        param-clause (first (:clauses params))
+        [clause navigator] (if (empty? param-clause) 
+                             (get-format-arg navigator)
+                             [param-clause navigator]) 
+        ]
+    (loop [count 0
+           navigator navigator]
+      (if (or (and (empty? (:rest navigator))
+                   (or (not (:colon (:right-params params))) (> count 0)))
+              (and max-count (>= count max-count)))
+        navigator
+        (let [[sublist navigator] (next-arg-or-nil navigator)
+              iter-result (execute-sub-format clause (init-navigator sublist) navigator)]
+          (if (= :colon-up-arrow (first iter-result))
+            navigator
+            (recur (inc count) navigator)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The '~< directive has two completely different meanings
+;;; in the '~<...~>' form it does justification, but with
+;;; ~<...~:>' it represents the logical block operation of the
+;;; pretty printer.
+;;; 
+;;; Unfortunately, the current architecture decides what function
+;;; to call at form parsing time before the sub-clauses have been
+;;; folded, so it is left to run-time to make the decision.
+;;; 
+;;; TODO: make it possible to make these decisions at compile-time.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare format-logical-block)
+(declare justify-clauses)
+
+(defn- logical-block-or-justify [params navigator offsets]
+  (if (:colon (:right-params params))
+    (format-logical-block params navigator offsets)
+    (justify-clauses params navigator offsets)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for the '~<...~>' justification directive
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- render-clauses [clauses navigator base-navigator]
+  (loop [clauses clauses
+         acc []
+         navigator navigator]
+    (if (empty? clauses)
+      [acc navigator]
+      (let [clause (first clauses)
+            [iter-result result-str] (binding [*out* (java.io.StringWriter.)]