Added the pretty printer, clojure.pprint

Signed-off-by: Stuart Halloway <stu@thinkrelevance.com>

15 files changed, 4823 insertions, 0 deletions

diff --git a/build.xml b/build.xml
index 0f7f14d2..615ba5b1 100644
--- a/build.xml
+++ b/build.xml
@@ -104,6 +104,7 @@
       <arg value="clojure.test"/>
       <arg value="clojure.test.tap"/>
       <arg value="clojure.test.junit"/>
+      <arg value="clojure.pprint"/>
     </java>
   </target>
 
diff --git a/doc/pprint/CommonLispFormat.markdown b/doc/pprint/CommonLispFormat.markdown
new file mode 100644
index 00000000..4bb38ace
--- /dev/null
+++ b/doc/pprint/CommonLispFormat.markdown
@@ -0,0 +1,202 @@
+# A Common Lisp-compatible Format Function
+cl-format is an implementation of the incredibly baroque Common Lisp format function as specified 
+in [Common Lisp, the Language, 2nd edition, Chapter 22](http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000).
+
+Format gives you an easy and powerful way to format text and data for output. It supports rich 
+formatting of strings and numbers, loops, conditionals, embedded formats, etc. It is really a 
+domain-specific language for formatting.
+
+This implementation for clojure has the following goals:
+
+ * Support the full feature set of the Common Lisp format function (including the X3J13 extensions) with the only exception being concepts that make no sense or are differently interpreted in Clojure.
+ * Make porting code from Common Lisp easier.
+ * Provide a more native feeling solution for Clojure programmers than the Java format method and its relatives.
+ * Be fast. This includes the ability to precompile formats that are going to be used reptitively.
+ * Include useful error handling and comprehensive documentation.
+
+## Why would I use cl-format?
+
+For some people the answer to this question is that they are used to
+Common Lisp and, therefore, they already know the syntax of format
+strings and all the directives.
+
+A more interesting answer is that cl-format provides a way of
+rendering strings that is much more suited to Lisp and its data
+structures. 
+
+Because iteration and conditionals are built into the directive
+structure of cl-format, it is possible to render sequences and other
+complex data structures directly without having to loop over the data
+structure. 
+
+For example, to print the elements of a sequence separated by commas,
+you simply say:
+
+    (cl-format true "~{~a~^, ~}" aseq)
+
+(This example is taken from 
+[Practical Common Lisp](http://www.gigamonkeys.com/book/)
+by Peter Seibel.)
+
+The corresponding output using Clojure's Java-based _format_ function
+would involve a nasty loop/recur with some code to figure out about
+the commas. Yuck!
+
+## Current Status of cl-format
+
+cl-format is 100% compatible with the Common Lisp standard as
+specified in CLtLv2.
+This includes all of the functionality of Common
+Lisp's format function including iteration, conditionals, 
+text justification and rich
+options for displaying real and integer values. It also includes the
+directives to support pretty printing structured output.
+
+If you find a bug in a directive, drop me a line
+with a chunk of code that exhibits the bug and the version of
+cl-format you found it in and I'll try to get it fixed.
+
+I also intend to have good built-in documentation for the directives,
+but I haven't built that yet.
+
+The following directives are
+not yet supported: ~:T and ~@:T (but all other forms of ~T work) 
+and extensions with ~/. 
+
+The pretty printer interface is similar, but not identical to the 
+interface in Common Lisp.
+
+Next up: 
+
+ * Support for ~/
+ * True compiled formats
+ * Restructure unit tests into modular chunks.
+ * Import tests from CLISP and SBCL.
+ * Unit tests for exception conditions.
+ * Interactive documentation
+ 
+## How to use cl-format
+
+### Loading cl-format in your program
+
+Once cl-format is in your path, adding it to your code is easy:
+
+    (ns your-namespace-here
+      (:use [clojure.pprint :only (cl-format)]))
+
+If you want to refer to the cl-format function as "format" (rather
+than using the clojure function of that name), you can use this idiom:
+
+    (ns your-namespace-here
+      (:refer-clojure :exclude [format])
+      (:use clojure.pprint))
+
+    (def format cl-format)
+
+You might want to do this in code that you've ported from Common Lisp,
+for instance, or maybe just because old habits die hard.
+
+From the REPL, you can grab it using (use):
+
+    (use 'clojure.pprint)
+
+### Calling cl-format
+
+cl-format is a standard clojure function that takes a variable number
+of arguments. You call it like this:
+
+    (cl-format stream format args...)
+
+_stream_ can be any Java Writer (that is java.io.Writer) or the values
+_true_, _false_, or _nil_. The argument _true_ is identical to using
+`*`out`*` while _false_ or _nil_ indicate that cl-format should return
+its result as a string rather than writing it to a stream.
+
+_format_ is either a format string or a compiled format (see
+below). The format string controls the output that's written in a way
+that's similar to (but much more powerful than) the standard Clojure
+API format function (which is based on Java's
+java.lang.String.Format).
+
+Format strings consist of characters that are to be written to the
+output stream plus directives (which are marked by ~) as in "The
+answer is ~,2f". Format strings are documented in detail in 
+[*Common Lisp the Language*, 2nd edition, Chapter 22](http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000).
+
+_args_ is a set of arguments whose use is defined by the format.
+
+## Using column aware streams across format invocations
+
+Writers in Java have no real idea of current column or device page width, so the format
+directives that want to work relative to the current position on the
+page have nothing to work with. To deal with this, cl-format contains
+an extension to writer called pretty-writer. A pretty-writer watches the
+output and keeps track of what column the current output is going to.
+
+When you call format and your format includes a directive that cares
+about what column it's in (~T, ~&, ~<...~>), cl-format will
+automatically wrap the Writer you passed in with a pretty-writer. This
+means that by default all cl-format statements act like they begin on
+a fresh line and have a page width of 72.
+
+For many applications, these assumptions are fine and you need to do
+nothing more. But sometimes you want to use multiple cl-format calls
+that output partial lines. You may also want to mix cl-format calls
+with the native clojure calls like print. If you want stay
+column-aware while doing this you need to create a pretty-writer of
+your own (and possibly bind it to `*`out`*`).
+
+As an example of this, this function takes a nested list and prints it
+as a table (returning the result as a string):
+
+    (defn list-to-table [aseq column-width]
+      (let [string-writer (java.io.StringWriter.)
+            stream (get-pretty-writer string-writer)]
+        (binding [*out* stream]
+          (doseq [row aseq]
+            (doseq [col row]
+              (cl-format true "~4D~7,vT" col column-width))
+            (prn)))
+        (.flush stream)
+        (.toString string-writer)))
+
+(In reality, you'd probably do this as a single call to cl-format.)
+
+The get-pretty-writer function takes the Writer to wrap and
+(optionally) the page width (in columns) for use with ~<...~>. 
+
+## Examples
+
+The following function uses cl-format to dump a columnized table of the Java system properties:
+
+    (defn show-props [stream]
+      (let [p (mapcat 
+    	       #(vector (key %) (val %)) 
+    	       (sort-by key (System/getProperties)))]
+        (cl-format stream "~30A~A~%~{~20,,,'-A~10A~}~%~{~30A~S~%~}" 
+    	           "Property" "Value" ["" "" "" ""] p)))
+    
+There are some more examples in the pretty print examples gallery at 
+http://github.com/tomfaulhaber/pprint-examples:
+
+ * hexdump - a program that uses cl-format to create a standard formatted hexdump of the requested stream.
+ * multiply - a function to show a formatted multipication table in a very "first-order" way.
+ * props - the show-props example shown above.
+ * show_doc - some utilities for showing documentation from various name spaces.
+
+## Differences from the Common Lisp format function
+
+The floating point directives that show exponents (~E, ~G) show E for
+the exponent character in all cases (unless overridden with an
+_exponentchar_).  Clojure does not distinguish between floats and
+doubles in its printed representation and neither does cl-format.
+
+The ~A and ~S directives accept the colon prefix, but ignore it since
+() and nil are not equivalent in Clojure.
+
+Clojure has 3 different reader syntaxes for characters. The ~@c
+directive to cl-format has an argument extension to let you choose:
+
+ * ~@c (with no argument) prints "\c" (backslash followed by the printed representation of the character or \newline, \space, \tab, \backspace, \return)
+ * ~'o@c prints "\oDDD" where DDD are the octal digits representing the character. 
+ * ~'u@c prints "\uXXXX" prints the hex Unicode representation of the character.  
diff --git a/doc/pprint/PrettyPrinting.markdown b/doc/pprint/PrettyPrinting.markdown
new file mode 100644
index 00000000..db7b26bb
--- /dev/null
+++ b/doc/pprint/PrettyPrinting.markdown
@@ -0,0 +1,270 @@
+# A Pretty Printer for Clojure
+
+## Overview
+
+This namespace adds a new feature to Clojure: a generalized pretty
+printer.
+
+The pretty printer is easy to use:
+
+    user=> (println (for [x (range 10)] (range x)))
+    (() (0) (0 1) (0 1 2) (0 1 2 3) (0 1 2 3 4) (0 1 2 3 4 5) (0 1 2 3 4 5 6) (0 1 2 3 4 5 6 7) (0 1 2 3 4 5 6 7 8))
+    nil
+    user=> (use 'clojure.pprint)             
+    nil
+    user=> (pprint (for [x (range 10)] (range x)))         
+    (()
+     (0)
+     (0 1)
+     (0 1 2)
+     (0 1 2 3)
+     (0 1 2 3 4)
+     (0 1 2 3 4 5)
+     (0 1 2 3 4 5 6)
+     (0 1 2 3 4 5 6 7)
+     (0 1 2 3 4 5 6 7 8))
+    nil
+    user=>
+
+The pretty printer supports two modes: _code_ which has special
+formatting for special forms and core macros and _simple_ (the
+default) which formats the various Clojure data structures as
+appropriate for raw data. In fact, the pretty printer is
+highly customizable, but basic use is pretty simple.
+
+All the functions and variables described here are in the
+clojure.pprint namespace. Using them is as simple as adding a 
+`(:use clojure.pprint)` to
+your namespace declarations. Or, better practice would be 
+`(:use [clojure.pprint :only (<functions you wish to use>)])`.
+
+pprint is being developed by Tom Faulhaber (to mail me you can use
+my first name at my domain which is infolace.com).
+
+As with the rest of Clojure, the pretty printer is licensed under the 
+[http://opensource.org/licenses/eclipse-1.0.php Eclipse Public License 1.0].
+
+Future development is guided by those using it, so send feedback about
+what's working and not working for you and what you'd like to see in the 
+pretty printer.
+
+## Pretty Printing Basics
+
+Pretty printing is primarily implemented with the function
+pprint. pprint takes a single argument and formats it according to the
+settings of several special variables.
+
+Generally, the defaults are fine for pretty printing and you can
+simply use:
+
+    (pprint obj)
+
+to print your object. If you wish to write to
+another stream besides `*`out`*`, you can use:
+
+    (write obj :pretty true :stream foo)
+
+where foo is the stream to which you wish to write. (The write
+function has a lot more options which are not yet documented. Stay
+tuned.)
+
+When at the REPL, the pp macro pretty prints the last output
+value. This is useful when you get something too complex to read
+comfortably. Just type:
+
+    user=> (pp)
+
+and you'll get a pretty printed version of the last thing output (the
+magic variable `*`1).
+
+## Dispatch tables and code formatting
+
+The behavior of the pretty printer can be finely controlled through
+the use of _dispatch tables_ that contain descriptions for how
+different structures should be formatted. 
+
+Using custom dispatch tables, the pretty printer can create formatted
+output for data structures that is customized for the
+application. This allows pretty printing to be baked into any
+structured output. For information and examples, see below in
+[#Custom_Dispatch_Functions Custom Dispatch Functions].
+
+The pretty printer comes with two pre-defined dispatch tables to cover
+the most common situations:
+
+`*`simple-dispatch`*` - supports basic representation of data in various
+Clojure structures: seqs, maps, vectors, etc. in a fairly statndard
+way. When structures need to be broken across lines, following lines
+are indented to line up with the first element. `*`simple-dispatch`*` is
+the default and is good for showing the output of most operations.
+
+`*`code-dispatch`*` - has special representation for various structures
+found in code: defn, condp, binding vectors, anonymous functions,
+etc. This dispatch indents following lines of a list one more space as
+appropriate for a function/argument type of list.
+
+An example formatted with code dispatch:
+
+    user=> (def code '(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))))
+    #'user/code
+    user=> (with-pprint-dispatch *code-dispatch* (pprint code))
+    (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)))
+    nil
+    user=> 
+
+There are three ways to set the current dispatch: set it to a specific
+table permanantly with set-pprint-dispatch, bind it with
+with-pprint-dispatch (as shown in the example above), or use the
+:dispatch keyword argument to write.
+
+## Control variables
+
+The operation of pretty printing is also controlled by a set of variables
+that control general parameters of how the pretty printer makes
+decisions. The current list is as follows:
+
+*`*`print-pretty`*`*: Default: *true*  
+
+Bind to true if you want write to use pretty printing. (pprint and pp automatically 
+bind this to true.)
+
+*`*`print-right-margin`*`*: Default: *72*
+
+Pretty printing will try to avoid anything going beyond this column.
+
+*`*`print-miser-width`*`*: Default: *40*
+
+The column at which to enter miser style. Depending on the dispatch table, 
+miser style add newlines in more places to try to keep lines short allowing for further 
+levels of nesting. For example, in the code dispatch table, the pretty printer will 
+insert a newline between the "if" and its condition when in miser style.
+
+*`*`print-suppress-namespaces`*`*: Default: *false*
+
+Don't print namespaces with symbols. This is particularly useful when 
+pretty printing the results of macro expansions
+
+*`*`print-level`*`*: Default: *nil*
+
+As with the regular Clojure print function, this variable controls the 
+depth of structure that is printed. The argument itself is level 0,
+the first level of a collection is level 1, etc. When the structure
+gets deeper than the specified `*`print-level`*`, a hash sign (#) is
+printed.
+
+For example:
+
+    user=> (binding [*print-level* 2] (pprint '(a b (c d) ((e) ((f d) g)))))
+    (a b (c d) (# #))
+    nil
+    user=> 
+
+*`*`print-length`*`*: Default: *nil*
+
+As with the regular Clojure print function, this variable controls the 
+number of items that are printed at each layer of structure. When a
+layer has too many items, elipses (...) are displayed. 
+
+For example:
+
+    user=> (defn foo [x] (for [i (range x) ] (range 1 (- x (dec i)))))
+    #'user/foo
+    user=> (binding [*print-length* 6] (pprint (foo 10)))
+    ((1 2 3 4 5 6 ...)
+     (1 2 3 4 5 6 ...)
+     (1 2 3 4 5 6 ...)
+     (1 2 3 4 5 6 ...)
+     (1 2 3 4 5 6)
+     (1 2 3 4 5)
+     ...)
+    nil
+    user=>
+
+## Custom Dispatch Functions
+
+Using custom dispatch, you can easily create your own formatted output
+for structured data. Examples included with the pretty printer show
+how to use custom dispatch to translate simple Clojure structures into
+nicely formatted JSON and XML.
+
+### Basic Concepts of Pretty Printing
+
+In order to create custom dispatch functions, you need to understand
+the fundamentals of pretty printing. The clojure pretty printer is
+based on the XP pretty printer algorithm (used in many Lisps including
+Common Lisp) which supports sophisticated decision-making about line
+breaking and indentation with reasonable performance even for very
+large structures. The XP algorithm is documented in the paper,
+[http://dspace.mit.edu/handle/1721.1/6504 XP. A Common Lisp Pretty
+Printing System].
+
+The Clojure implementation of XP is similar in spirit to the Common
+Lisp implementation, but the details of the interface are somewhat
+different. The result is that writing custom dispatch in Clojure is
+more "Clojure-y."
+
+There are three key concepts to understand when creating custom pretty
+printing functions: _logical blocks_,  _conditional newlines_, and
+_indentation_.
+
+A _logical block_ marks a set of output that should be thought about
+as a single unit by the pretty printer. Logical blocks can contain
+other logical blocks (that is, they nest). As a simple example, when
+printing list structure, every sublist will typically be a logical
+block.
+
+_Conditional newlines_ tell the pretty printer where it can insert
+line breaks and how to make the decisions about when to do it. There
+are four types of conditional newline:
+
+ * Linear newlines tell the pretty printer to insert a newline in a
+   place whenever the enclosing logical block won't fit on a single
+   line. Linear newlines are an all-or-nothing proposition; if the
+   logical block doesn't fit on a single line, *all* the linear
+   newlines are emitted as actual newlines.
+ * Fill newlines tell the pretty printer that it should fit as many
+   chunks of the logical block as possible on this line and then emit
+   a newline.
+ * Mandatory newlines tell the pretty printer to emit a newline
+   regardless of where it is in the output line.  
+ * Miser newlines tell the pretty printer to emit a newline if the
+   output column is in the miser region (as defined by the pretty
+   printer variable `*`pprint-miser-width`*`). This allows you to
+   define special behavior as the output gets heavily nested near the
+   right margin.
+
+_Indentation_ commands allow you to specify how wrapped lines should
+be indented. Indentation can be relative to either the start column of
+the current logical block or the current column position of the output. 
+
+(This section is still incomplete...)
+
+## Current limitations and future plans
+
+This is an early version release of the pretty printer and there is
+plenty that is yet to come.
+
+Here are some examples:
+
+ * Support all the types and forms in Clojure (most of the way there now).
+ * Support for limiting pretty printing based on line counts.
+ * Support for circular and shared substructure detection.
+ * Finishing the integration with the format function (support for ~/ and tabular pretty printing).
+ * Performance! (Not much thought has been made to making this go fast, but there are a bunch of pretty obvious speedups to be had.)
+ * Handle Java objects intelligently
+
+Please let me know about anything that's not working right, anything that
+should work differently, or the feature you think should be at the top
+of my list. 
+
diff --git a/src/clj/clojure/pprint.clj b/src/clj/clojure/pprint.clj
new file mode 100644
index 00000000..99fc605a
--- /dev/null
+++ b/src/clj/clojure/pprint.clj
@@ -0,0 +1,48 @@
+;;; pprint.clj -- Pretty printer and Common Lisp compatible format function (cl-format) for Clojure
+
+;   Copyright (c) Rich Hickey. 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.
+
+;; Author: Tom Faulhaber
+;; April 3, 2009
+
+(ns 
+    ^{:author "Tom Faulhaber",
+      :doc "A Pretty Printer for Clojure
+
+clojure.pprint implements a flexible system for printing structured data
+in a pleasing, easy-to-understand format. Basic use of the pretty printer is 
+simple, just call pprint instead of println. More advanced users can use 
+the building blocks provided to create custom output formats. 
+
+Out of the box, pprint supports a simple structured format for basic data 
+and a specialized format for Clojure source code. More advanced formats, 
+including formats that don't look like Clojure data at all like XML and 
+JSON, can be rendered by creating custom dispatch functions. 
+
+In addition to the pprint function, this module contains cl-format, a text 
+formatting function which is fully compatible with the format function in 
+Common Lisp. Because pretty printing directives are directly integrated with
+cl-format, it supports very concise custom dispatch. It also provides
+a more powerful alternative to Clojure's standard format function.
+
+See documentation for pprint and cl-format for more information or 
+complete documentation on the the clojure web site on github.",
+       :added "1.2"}
+    clojure.pprint
+    (:refer-clojure :exclude (deftype)))
+
+
+(load "pprint/utilities")
+(load "pprint/column_writer")
+(load "pprint/pretty_writer")
+(load "pprint/pprint_base")
+(load "pprint/cl_format")
+(load "pprint/dispatch")
+
+nil
diff --git a/src/clj/clojure/pprint/cl_format.clj b/src/clj/clojure/pprint/cl_format.clj
new file mode 100644
index 00000000..71feeeed
--- /dev/null
+++ b/src/clj/clojure/pprint/cl_format.clj
@@ -0,0 +1,1896 @@
+;;; cl_format.clj -- part of the pretty printer for Clojure
+
+;   Copyright (c) Rich Hickey. 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.
+
+;; Author: Tom Faulhaber
+;; April 3, 2009
+
+
+;; 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.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. cl-format formats its
+arguments to an output stream or string based on the format control string given. It 
+supports sophisticated formatting of structured data.
+
+Writer is an instance of java.io.Writer, true to output to *out* or nil to output 
+to a string, format-in is the format control string and the remaining arguments 
+are the data to be formatted.
+
+The format control string is a string to be output with embedded 'format directives' 
+describing how to format the various arguments passed in.
+
+If writer is nil, cl-format returns the formatted result string. Otherwise, cl-format 
+returns nil.
+
+For example:
+ (let [results [46 38 22]]
+        (cl-format true \"There ~[are~;is~:;are~]~:* ~d result~:p: ~{~d~^, ~}~%\" 
+                   (count results) results))
+
+Prints to *out*:
+ There are 3 results: 46, 38, 22
+
+Detailed documentation on format control strings is available in the \"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) 
+and in the Common Lisp HyperSpec at 
+http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm
+"
+  {:added "1.2",
+   :see-also [["http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000" 
+               "Common Lisp the Language"]
+              ["http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm"
+               "Common Lisp HyperSpec"]]}
+  [writer format-in & args]
+  (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)
+        navigator (init-navigator args)]
+    (execute-format writer 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 
+  "Create a new arg-navigator from the sequence with the position set to 0"
+  {:skip-wiki true}
+  [s]
+  (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
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare opt-base-str)
+
+(def ^{:private true}
+     special-radix-markers {2 "#b" 8 "#o", 16 "#x"})
+
+(defn- format-simple-number [n]
+  (cond 
+    (integer? n) (if (= *print-base* 10)
+                   (str n (if *print-radix* "."))
+                   (str
+                    (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r")))
+                    (opt-base-str *print-base* n)))
+    (ratio? n) (str
+                (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r")))
+                (opt-base-str *print-base* (.numerator n))
+                "/"
+                (opt-base-str *print-base* (.denominator n)))
+    :else nil))
+
+(defn- format-ascii [print-func params arg-navigator offsets]
+  (let [ [arg arg-navigator] (next-arg arg-navigator) 
+         ^String base-output (or (format-simple-number arg) (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?
+  "returns true if a number is actually an integer (that is, has no fractional part)"
+  [x]
+  (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
+  "Return the list of remainders (essentially the 'digits') of val in the given base"
+  [base val]
+  (reverse 
+   (first 
+    (consume #(if (pos? %) 
+                [(rem % base) (quot % base)] 
+                [nil nil]) 
+             val))))
+
+;;; TODO: xlated-val does not seem to be used here.
+(defn- base-str
+  "Return val as a string in the given base"
+  [base val]
+  (if (zero? val)
+    "0"
+    (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
+  "Return val as a string in the given base, using clojure.core/format if supported
+for improved performance"
+  [base val]
+  (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
+  "Convert a number less than 1000 to a cardinal english string"
+  [num]
+  (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
+  "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"
+  [parts offset]
+  (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
+  "Convert a number less than 1000 to a ordinal english string
+Note this should only be used for the last one in the sequence"
+  [num]
+  (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
+  "Format a roman numeral using the specified look-up table"
+  [table params navigator offsets]
+  (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
+  "Take care of leading and trailing zeros in decomposed floats"
+  [f]
+  (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 (neg? round-pos)
+          ["0" 0 false]
+          (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
+  "Insert the decimal point at the right spot in the number to match an exponent"
+  [m e]
+  (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
+  "Insert the decimal point at the right spot in the number to match an exponent"
+  [m k]
+  (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)
+        [sign abs] (if (neg? arg) ["-" (- arg)] ["+" arg])
+        [mantissa exp] (float-parts abs)
+        scaled-exp (+ exp (:k params))
+        add-sign (or (:at params) (neg? arg))
+        append-zero (and (not d) (<= (dec (count mantissa)) scaled-exp))
+        [rounded-mantissa scaled-exp expanded] (round-str mantissa scaled-exp 
+                                                          d (if w (- w (if add-sign 1 0))))
+        fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d)
+        prepend-zero (= (first fixed-repr) \.)]
+    (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 sign) 
+                  (if prepend-zero "0")
+                  fixed-repr
+                  (if append-zero "0")))))
+      (print (str
+              (if add-sign 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 (or (:at params) (neg? arg))
+        [rounded-mantissa scaled-exp expanded] (round-str mantissa exp d nil)
+        ^String fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) 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.)]
+                                       [(execute-sub-format clause navigator base-navigator) 
+                                        (.toString *out*)])]
+        (if (= :up-arrow (first iter-result))
+          [acc (second iter-result)]
+          (recur (next clauses) (conj acc result-str) iter-result))))))
+
+;; TODO support for ~:; constructions
+(defn- justify-clauses [params navigator offsets]
+  (let [[[eol-str] new-navigator] (when-let [else (:else params)]
+                                    (render-clauses else navigator (:base-args params)))
+        navigator (or new-navigator navigator)
+        [else-params new-navigator] (when-let [p (:else-params params)]
+                                      (realize-parameter-list p navigator))
+        navigator (or new-navigator navigator)
+        min-remaining (or (first (:min-remaining else-params)) 0)
+        max-columns (or (first (:max-columns else-params))
+                        (get-max-column *out*))
+        clauses (:clauses params)
+        [strs navigator] (render-clauses clauses navigator (:base-args params))
+        slots (max 1
+                   (+ (dec (count strs)) (if (:colon params) 1 0) (if (:at params) 1 0)))
+        chars (reduce + (map count strs))
+        mincol (:mincol params)
+        minpad (:minpad params)
+        colinc (:colinc params)
+        minout (+ chars (* slots minpad))
+        result-columns (if (<= minout mincol) 
+                         mincol
+                         (+ mincol (* colinc
+                                      (+ 1 (quot (- minout mincol 1) colinc)))))
+        total-pad (- result-columns chars)
+        pad (max minpad (quot total-pad slots))
+        extra-pad (- total-pad (* pad slots))
+        pad-str (apply str (repeat pad (:padchar params)))]
+    (if (and eol-str (> (+ (get-column (:base @@*out*)) min-remaining result-columns) 
+                        max-columns))
+      (print eol-str))
+    (loop [slots slots
+           extra-pad extra-pad
+           strs strs
+           pad-only (or (:colon params)
+                        (and (= (count strs) 1) (not (:at params))))]
+      (if (seq strs)
+        (do
+          (print (str (if (not pad-only) (first strs))
+                      (if (or pad-only (next strs) (:at params)) pad-str)
+                      (if (pos? extra-pad) (:padchar params))))
+          (recur 
+           (dec slots)
+           (dec extra-pad)
+           (if pad-only strs (next strs))
+           false))))
+    navigator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for case modification with ~(...~).
+;;; We do this by wrapping the underlying writer with
+;;; a special writer to do the appropriate modification. This
+;;; allows us to support arbitrary-sized output and sources
+;;; that may block.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- downcase-writer 
+  "Returns a proxy that wraps writer, converting all characters to lower case"
+  [^java.io.Writer writer]
+  (proxy [java.io.Writer] []
+    (close [] (.close writer))
+    (flush [] (.flush writer))
+    (write ([^chars cbuf ^Integer off ^Integer len] 
+              (.write writer cbuf off len))
+           ([x]
+              (condp = (class x)
+		String 
+		(let [s ^String x]
+		  (.write writer (.toLowerCase s)))
+
+		Integer
+		(let [c ^Character x]
+		  (.write writer (int (Character/toLowerCase (char c))))))))))
+
+(defn- upcase-writer 
+  "Returns a proxy that wraps writer, converting all characters to upper case"
+  [^java.io.Writer writer]
+  (proxy [java.io.Writer] []
+    (close [] (.close writer))
+    (flush [] (.flush writer))
+    (write ([^chars cbuf ^Integer off ^Integer len] 
+              (.write writer cbuf off len))
+           ([x]
+              (condp = (class x)
+		String 
+		(let [s ^String x]
+		  (.write writer (.toUpperCase s)))
+
+		Integer
+		(let [c ^Character x]
+		  (.write writer (int (Character/toUpperCase (char c))))))))))
+
+(defn- capitalize-string
+  "Capitalizes the words in a string. If first? is false, don't capitalize the 
+                                      first character of the string even if it's a letter."
+  [s first?]
+  (let [^Character f (first s) 
+        s (if (and first? f (Character/isLetter f))
+            (str (Character/toUpperCase f) (subs s 1))
+            s)]
+    (apply str 
+           (first
+            (consume
+             (fn [s]
+               (if (empty? s)
+                 [nil nil]
+                 (let [m (re-matcher #"\W\w" s)
+                       match (re-find m)
+                       offset (and match (inc (.start m)))]
+                   (if offset
+                     [(str (subs s 0 offset) 
+                           (Character/toUpperCase ^Character (nth s offset)))
+                      (subs s (inc offset))]
+                     [s nil]))))
+             s)))))
+
+(defn- capitalize-word-writer
+  "Returns a proxy that wraps writer, captializing all words"
+  [^java.io.Writer writer]
+  (let [last-was-whitespace? (ref true)] 
+    (proxy [java.io.Writer] []
+      (close [] (.close writer))
+      (flush [] (.flush writer))
+      (write 
+       ([^chars cbuf ^Integer off ^Integer len] 
+          (.write writer cbuf off len))
+       ([x]
+          (condp = (class x)
+            String 
+            (let [s ^String x]
+              (.write writer 
+                      ^String (capitalize-string (.toLowerCase s) @last-was-whitespace?))
+              (dosync 
+               (ref-set last-was-whitespace? 
+                        (Character/isWhitespace 
+                         ^Character (nth s (dec (count s)))))))
+
+            Integer
+            (let [c (char x)]
+              (let [mod-c (if @last-was-whitespace? (Character/toUpperCase ^Character (char x)) c)] 
+                (.write writer (int mod-c))
+                (dosync (ref-set last-was-whitespace? (Character/isWhitespace ^Character (char x))))))))))))
+
+(defn- init-cap-writer
+  "Returns a proxy that wraps writer, capitalizing the first word"
+  [^java.io.Writer writer]
+  (let [capped (ref false)] 
+    (proxy [java.io.Writer] []
+      (close [] (.close writer))
+      (flush [] (.flush writer))
+      (write ([^chars cbuf ^Integer off ^Integer len] 
+                (.write writer cbuf off len))
+             ([x]
+                (condp = (class x)
+                 String 
+                 (let [s (.toLowerCase ^String x)]
+                   (if (not @capped) 
+                     (let [m (re-matcher #"\S" s)
+                           match (re-find m)
+                           offset (and match (.start m))]
+                       (if offset
+                         (do (.write writer 
+                                   (str (subs s 0 offset) 
+                                        (Character/toUpperCase ^Character (nth s offset))
+                                        (.toLowerCase ^String (subs s (inc offset)))))
+                           (dosync (ref-set capped true)))
+                         (.write writer s))) 
+                     (.write writer (.toLowerCase s))))
+
+                 Integer
+                 (let [c ^Character (char x)]
+                   (if (and (not @capped) (Character/isLetter c))
+                     (do
+                       (dosync (ref-set capped true))
+                       (.write writer (int (Character/toUpperCase c))))
+                     (.write writer (int (Character/toLowerCase c)))))))))))
+
+(defn- modify-case [make-writer params navigator offsets]
+  (let [clause (first (:clauses params))]
+    (binding [*out* (make-writer *out*)] 
+      (execute-sub-format clause navigator (:base-args params)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; If necessary, wrap the writer in a PrettyWriter object
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn get-pretty-writer 
+  "Returns the java.io.Writer passed in wrapped in a pretty writer proxy, unless it's 
+already a pretty writer. Generally, it is unneccesary to call this function, since pprint,
+write, and cl-format all call it if they need to. However if you want the state to be 
+preserved across calls, you will want to wrap them with this. 
+
+For example, when you want to generate column-aware output with multiple calls to cl-format, 
+do it like in this example:
+
+    (defn print-table [aseq column-width]
+      (binding [*out* (get-pretty-writer *out*)]
+        (doseq [row aseq]
+          (doseq [col row]
+            (cl-format true \"~4D~7,vT\" col column-width))
+          (prn))))
+
+Now when you run:
+
+    user> (print-table (map #(vector % (* % %) (* % % %)) (range 1 11)) 8)
+
+It prints a table of squares and cubes for the numbers from 1 to 10:
+
+       1      1       1    
+       2      4       8    
+       3      9      27    
+       4     16      64    
+       5     25     125    
+       6     36     216    
+       7     49     343    
+       8     64     512    
+       9     81     729    
+      10    100    1000"
+  {:added "1.2"}
+  [writer]
+  (if (pretty-writer? writer) 
+    writer
+    (pretty-writer writer *print-right-margin* *print-miser-width*)))
+ 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for column-aware operations ~&, ~T
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn fresh-line
+  "Make a newline if *out* is not already at the beginning of the line. If *out* is
+not a pretty writer (which keeps track of columns), this function always outputs a newline."
+  {:added "1.2"}
+  []
+  (if (instance? clojure.lang.IDeref *out*)
+    (if (not (= 0 (get-column (:base @@*out*))))
+      (prn))
+    (prn)))
+
+(defn- absolute-tabulation [params navigator offsets]
+  (let [colnum (:colnum params) 
+        colinc (:colinc params)
+        current (get-column (:base @@*out*))
+        space-count (cond
+                     (< current colnum) (- colnum current)
+                     (= colinc 0) 0
+                     :else (- colinc (rem (- current colnum) colinc)))]
+    (print (apply str (repeat space-count \space))))
+  navigator)
+
+(defn- relative-tabulation [params navigator offsets]
+  (let [colrel (:colnum params) 
+        colinc (:colinc params)
+        start-col (+ colrel (get-column (:base @@*out*)))
+        offset (if (pos? colinc) (rem start-col colinc) 0)
+        space-count (+ colrel (if (= 0 offset) 0 (- colinc offset)))]
+    (print (apply str (repeat space-count \space))))
+  navigator)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for accessing the pretty printer from a format
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; TODO: support ~@; per-line-prefix separator
+;; TODO: get the whole format wrapped so we can start the lb at any column
+(defn- format-logical-block [params navigator offsets]
+  (let [clauses (:clauses params)
+        clause-count (count clauses)
+        prefix (cond
+                (> clause-count 1) (:string (:params (first (first clauses))))
+                (:colon params) "(")
+        body (nth clauses (if (> clause-count 1) 1 0))
+        suffix (cond
+                (> clause-count 2) (:string (:params (first (nth clauses 2))))
+                (:colon params) ")")
+        [arg navigator] (next-arg navigator)]
+    (pprint-logical-block :prefix prefix :suffix suffix
+      (execute-sub-format 
+       body 
+       (init-navigator arg)
+       (:base-args params)))
+    navigator))
+
+(defn- set-indent [params navigator offsets]
+  (let [relative-to (if (:colon params) :current :block)]
+    (pprint-indent relative-to (:n params))
+    navigator))
+
+;;; TODO: support ~:T section options for ~T
+
+(defn- conditional-newline [params navigator offsets]
+  (let [kind (if (:colon params) 
+               (if (:at params) :mandatory :fill)
+               (if (:at params) :miser :linear))]
+    (pprint-newline kind)
+    navigator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The table of directives we support, each with its params,
+;;; properties, and the compilation function
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; We start with a couple of helpers
+(defn- process-directive-table-element [ [ char params flags bracket-info & generator-fn ] ]
+  [char, 
+   {:directive char,
+    :params `(array-map ~@params),
+    :flags flags,
+    :bracket-info bracket-info,
+    :generator-fn (concat '(fn [ params offset]) generator-fn) }])
+
+(defmacro ^{:private true}
+  defdirectives 
+  [ & directives ]
+  `(def ^{:private true}
+        directive-table (hash-map ~@(mapcat process-directive-table-element directives))))
+
+(defdirectives 
+  (\A 
+   [ :mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character] ] 
+   #{ :at :colon :both} {}
+   #(format-ascii print-str %1 %2 %3))
+
+  (\S 
+   [ :mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character] ] 
+   #{ :at :colon :both} {}
+   #(format-ascii pr-str %1 %2 %3))
+
+  (\D
+   [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] 
+    :commainterval [ 3 Integer]]
+   #{ :at :colon :both } {}
+   #(format-integer 10 %1 %2 %3))
+
+  (\B
+   [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] 
+    :commainterval [ 3 Integer]]
+   #{ :at :colon :both } {}
+   #(format-integer 2 %1 %2 %3))
+
+  (\O
+   [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] 
+    :commainterval [ 3 Integer]]
+   #{ :at :colon :both } {}
+   #(format-integer 8 %1 %2 %3))
+
+  (\X
+   [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] 
+    :commainterval [ 3 Integer]]
+   #{ :at :colon :both } {}
+   #(format-integer 16 %1 %2 %3))
+
+  (\R
+   [:base [nil Integer] :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] 
+    :commainterval [ 3 Integer]]
+   #{ :at :colon :both } {}
+   (do
+     (cond                          ; ~R is overloaded with bizareness
+       (first (:base params))     #(format-integer (:base %1) %1 %2 %3)
+       (and (:at params) (:colon params))   #(format-old-roman %1 %2 %3)
+       (:at params)               #(format-new-roman %1 %2 %3)
+       (:colon params)            #(format-ordinal-english %1 %2 %3)
+       true                       #(format-cardinal-english %1 %2 %3))))
+
+  (\P
+   [ ]
+   #{ :at :colon :both } {}
+   (fn [params navigator offsets]
+     (let [navigator (if (:colon params) (relative-reposition navigator -1) navigator)
+           strs (if (:at params) ["y" "ies"] ["" "s"])
+           [arg navigator] (next-arg navigator)]
+       (print (if (= arg 1) (first strs) (second strs)))
+       navigator)))
+
+  (\C
+   [:char-format [nil Character]]
+   #{ :at :colon :both } {}
+   (cond
+     (:colon params) pretty-character
+     (:at params) readable-character
+     :else plain-character))
+
+  (\F
+   [ :w [nil Integer] :d [nil Integer] :k [0 Integer] :overflowchar [nil Character] 
+    :padchar [\space Character] ]
+   #{ :at } {}
+   fixed-float)
+
+  (\E
+   [ :w [nil Integer] :d [nil Integer] :e [nil Integer] :k [1 Integer] 
+    :overflowchar [nil Character] :padchar [\space Character] 
+    :exponentchar [nil Character] ]
+   #{ :at } {}
+   exponential-float)
+
+  (\G
+   [ :w [nil Integer] :d [nil Integer] :e [nil Integer] :k [1 Integer] 
+    :overflowchar [nil Character] :padchar [\space Character] 
+    :exponentchar [nil Character] ]
+   #{ :at } {}
+   general-float)
+
+  (\$
+   [ :d [2 Integer] :n [1 Integer] :w [0 Integer] :padchar [\space Character]]
+   #{ :at :colon :both} {}
+   dollar-float)
+
+  (\% 
+   [ :count [1 Integer] ] 
+   #{ } {}
+   (fn [params arg-navigator offsets]
+     (dotimes [i (:count params)]
+       (prn))
+     arg-navigator))
+
+  (\&
+   [ :count [1 Integer] ] 
+   #{ :pretty } {}
+   (fn [params arg-navigator offsets]
+     (let [cnt (:count params)]
+       (if (pos? cnt) (fresh-line))
+       (dotimes [i (dec cnt)]
+         (prn)))
+     arg-navigator))
+
+  (\| 
+   [ :count [1 Integer] ] 
+   #{ } {}
+   (fn [params arg-navigator offsets]
+     (dotimes [i (:count params)]
+       (print \formfeed))
+     arg-navigator))
+
+  (\~ 
+   [ :n [1 Integer] ] 
+   #{ } {}
+   (fn [params arg-navigator offsets]
+     (let [n (:n params)]
+       (print (apply str (repeat n \~)))
+       arg-navigator)))
+
+  (\newline ;; Whitespace supression is handled in the compilation loop
+   [ ] 
+   #{:colon :at} {}
+   (fn [params arg-navigator offsets]
+     (if (:at params)
+       (prn))
+     arg-navigator))
+
+  (\T
+   [ :colnum [1 Integer] :colinc [1 Integer] ] 
+   #{ :at :pretty } {}
+   (if (:at params)
+     #(relative-tabulation %1 %2 %3)
+     #(absolute-tabulation %1 %2 %3)))
+
+  (\* 
+   [ :n [1 Integer] ] 
+   #{ :colon :at } {}
+   (fn [params navigator offsets]
+     (let [n (:n params)]
+       (if (:at params)
+         (absolute-reposition navigator n)
+         (relative-reposition navigator (if (:colon params) (- n) n)))
+       )))
+
+  (\? 
+   [ ] 
+   #{ :at } {}
+   (if (:at params)
+     (fn [params navigator offsets]     ; args from main arg list
+       (let [[subformat navigator] (get-format-arg navigator)]
+         (execute-sub-format subformat navigator  (:base-args params))))
+     (fn [params navigator offsets]     ; args from sub-list
+       (let [[subformat navigator] (get-format-arg navigator)
+             [subargs navigator] (next-arg navigator)
+             sub-navigator (init-navigator subargs)]
+         (execute-sub-format subformat sub-navigator (:base-args params))
+         navigator))))
+       
+
+  (\(
+   [ ]
+   #{ :colon :at :both} { :right \), :allows-separator nil, :else nil }
+   (let [mod-case-writer (cond
+                           (and (:at params) (:colon params))
+                           upcase-writer
+
+                           (:colon params)
+                           capitalize-word-writer
+
+                           (:at params)
+                           init-cap-writer
+
+                           :else
+                           downcase-writer)]
+     #(modify-case mod-case-writer %1 %2 %3)))
+
+  (\) [] #{} {} nil) 
+
+  (\[
+   [ :selector [nil Integer] ]
+   #{ :colon :at } { :right \], :allows-separator true, :else :last }
+   (cond
+     (:colon params)
+     boolean-conditional
+
+     (:at params)
+     check-arg-conditional
+
+     true
+     choice-conditional))
+
+  (\; [:min-remaining [nil Integer] :max-columns [nil Integer]] 
+   #{ :colon } { :separator true } nil) 
+   
+  (\] [] #{} {} nil) 
+
+  (\{
+   [ :max-iterations [nil Integer] ]
+   #{ :colon :at :both} { :right \}, :allows-separator false }
+   (cond
+     (and (:at params) (:colon params))
+     iterate-main-sublists
+
+     (:colon params)
+     iterate-list-of-sublists
+
+     (:at params)
+     iterate-main-list
+
+     true
+     iterate-sublist))
+
+   
+  (\} [] #{:colon} {} nil) 
+
+  (\<
+   [:mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character]]
+   #{:colon :at :both :pretty} { :right \>, :allows-separator true, :else :first }
+   logical-block-or-justify)
+
+  (\> [] #{:colon} {} nil) 
+
+  ;; TODO: detect errors in cases where colon not allowed
+  (\^ [:arg1 [nil Integer] :arg2 [nil Integer] :arg3 [nil Integer]] 
+   #{:colon} {} 
+   (fn [params navigator offsets]
+     (let [arg1 (:arg1 params)
+           arg2 (:arg2 params)
+           arg3 (:arg3 params)
+           exit (if (:colon params) :colon-up-arrow :up-arrow)]
+       (cond
+         (and arg1 arg2 arg3)
+         (if (<= arg1 arg2 arg3) [exit navigator] navigator)
+
+         (and arg1 arg2)
+         (if (= arg1 arg2) [exit navigator] navigator)
+
+         arg1
+         (if (= arg1 0) [exit navigator] navigator)
+
+         true     ; TODO: handle looking up the arglist stack for info
+         (if (if (:colon params) 
+               (empty? (:rest (:base-args params)))
+               (empty? (:rest navigator)))
+           [exit navigator] navigator))))) 
+
+  (\W 
+   [] 
+   #{:at :colon :both} {}
+   (if (or (:at params) (:colon params))
+     (let [bindings (concat
+                     (if (:at params) [:level nil :length nil] [])
+                     (if (:colon params) [:pretty true] []))]
+       (fn [params navigator offsets]
+         (let [[arg navigator] (next-arg navigator)]
+           (if (apply write arg bindings)
+             [:up-arrow navigator]
+             navigator))))
+     (fn [params navigator offsets]
+       (let [[arg navigator] (next-arg navigator)]
+         (if (write-out arg)
+           [:up-arrow navigator]
+           navigator)))))
+
+  (\_
+   []
+   #{:at :colon :both} {}
+   conditional-newline)
+
+  (\I
+   [:n [0 Integer]]
+   #{:colon} {}
+   set-indent)
+  )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Code to manage the parameters and flags associated with each
+;;; directive in the format string.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^{:private true}
+     param-pattern #"^([vV]|#|('.)|([+-]?\d+)|(?=,))")
+(def ^{:private true}
+     special-params #{ :parameter-from-args :remaining-arg-count })
+
+(defn- extract-param [[s offset saw-comma]]
+  (let [m (re-matcher param-pattern s)
+        param (re-find m)]
+    (if param
+      (let [token-str (first (re-groups m))
+            remainder (subs s (.end m))
+            new-offset (+ offset (.end m))]
+        (if (not (= \, (nth remainder 0)))
+          [ [token-str offset] [remainder new-offset false]]
+          [ [token-str offset] [(subs remainder 1) (inc new-offset) true]]))
+      (if saw-comma 
+        (format-error "Badly formed parameters in format directive" offset)
+        [ nil [s offset]]))))
+
+
+(defn- extract-params [s offset] 
+  (consume extract-param [s offset false]))
+
+(defn- translate-param
+  "Translate the string representation of a param to the internalized
+                                      representation"
+  [[^String p offset]]
+  [(cond 
+    (= (.length p) 0) nil
+    (and (= (.length p) 1) (contains? #{\v \V} (nth p 0))) :parameter-from-args
+    (and (= (.length p) 1) (= \# (nth p 0))) :remaining-arg-count
+    (and (= (.length p) 2) (= \' (nth p 0))) (nth p 1)
+    true (new Integer p))
+   offset])
+ 
+(def ^{:private true}
+     flag-defs { \: :colon, \@ :at })
+
+(defn- extract-flags [s offset]
+  (consume
+   (fn [[s offset flags]]
+     (if (empty? s)
+       [nil [s offset flags]]
+       (let [flag (get flag-defs (first s))]
+         (if flag
+           (if (contains? flags flag)
+             (format-error 
+              (str "Flag \"" (first s) "\" appears more than once in a directive")
+              offset)
+             [true [(subs s 1) (inc offset) (assoc flags flag [true offset])]])
+           [nil [s offset flags]]))))
+   [s offset {}]))
+
+(defn- check-flags [def flags]
+  (let [allowed (:flags def)]
+    (if (and (not (:at allowed)) (:at flags))
+      (format-error (str "\"@\" is an illegal flag for format directive \"" (:directive def) "\"")
+                    (nth (:at flags) 1)))
+    (if (and (not (:colon allowed)) (:colon flags))
+      (format-error (str "\":\" is an illegal flag for format directive \"" (:directive def) "\"")
+                    (nth (:colon flags) 1)))
+    (if (and (not (:both allowed)) (:at flags) (:colon flags))
+      (format-error (str "Cannot combine \"@\" and \":\" flags for format directive \"" 
+                         (:directive def) "\"")
+                    (min (nth (:colon flags) 1) (nth (:at flags) 1))))))
+
+(defn- map-params
+  "Takes a directive definition and the list of actual parameters and
+a map of flags and returns a map of the parameters and flags with defaults
+filled in. We check to make sure that there are the right types and number
+of parameters as well."
+  [def params flags offset]
+  (check-flags def flags)
+  (if (> (count params) (count (:params def)))
+    (format-error 
+     (cl-format 
+      nil 
+      "Too many parameters for directive \"~C\": ~D~:* ~[were~;was~:;were~] specified but only ~D~:* ~[are~;is~:;are~] allowed"
+      (:directive def) (count params) (count (:params def)))
+     (second (first params))))
+  (doall
+   (map #(let [val (first %1)]
+           (if (not (or (nil? val) (contains? special-params val) 
+                        (instance? (second (second %2)) val)))
+             (format-error (str "Parameter " (name (first %2))
+                                " has bad type in directive \"" (:directive def) "\": "
+                                (class val))
+                           (second %1))) )
+        params (:params def)))
+     
+  (merge                                ; create the result map
+   (into (array-map) ; start with the default values, make sure the order is right
+         (reverse (for [[name [default]] (:params def)] [name [default offset]])))
+   (reduce #(apply assoc %1 %2) {} (filter #(first (nth % 1)) (zipmap (keys (:params def)) params))) ; add the specified parameters, filtering out nils
+   flags))                                ; and finally add the flags
+
+(defn- compile-directive [s offset]
+  (let [[raw-params [rest offset]] (extract-params s offset)
+        [_ [rest offset flags]] (extract-flags rest offset)
+        directive (first rest)
+        def (get directive-table (Character/toUpperCase ^Character directive))
+        params (if def (map-params def (map translate-param raw-params) flags offset))]
+    (if (not directive)
+      (format-error "Format string ended in the middle of a directive" offset))
+    (if (not def)
+      (format-error (str "Directive \"" directive "\" is undefined") offset))
+    [(struct compiled-directive ((:generator-fn def) params offset) def params offset)
+     (let [remainder (subs rest 1) 
+           offset (inc offset)
+           trim? (and (= \newline (:directive def))
+                      (not (:colon params)))
+           trim-count (if trim? (prefix-count remainder [\space \tab]) 0)
+           remainder (subs remainder trim-count)
+           offset (+ offset trim-count)]
+       [remainder offset])]))
+    
+(defn- compile-raw-string [s offset]
+  (struct compiled-directive (fn [_ a _] (print s) a) nil { :string s } offset))
+
+(defn- right-bracket [this] (:right (:bracket-info (:def this))))
+(defn- separator? [this] (:separator (:bracket-info (:def this))))
+(defn- else-separator? [this] 
+  (and (:separator (:bracket-info (:def this)))
+       (:colon (:params this))))
+  
+
+(declare collect-clauses)
+
+(defn- process-bracket [this remainder]
+  (let [[subex remainder] (collect-clauses (:bracket-info (:def this))
+                                           (:offset this) remainder)]
+    [(struct compiled-directive 
+             (:func this) (:def this) 
+             (merge (:params this) (tuple-map subex (:offset this)))
+             (:offset this))
+     remainder]))
+
+(defn- process-clause [bracket-info offset remainder]
+  (consume 
+   (fn [remainder]
+     (if (empty? remainder)
+       (format-error "No closing bracket found." offset)
+       (let [this (first remainder)
+             remainder (next remainder)]
+         (cond
+          (right-bracket this)
+          (process-bracket this remainder)
+
+          (= (:right bracket-info) (:directive (:def this)))
+          [ nil [:right-bracket (:params this) nil remainder]]
+
+          (else-separator? this)
+          [nil [:else nil (:params this) remainder]]
+
+          (separator? this)
+          [nil [:separator nil nil remainder]] ;; TODO: check to make sure that there are no params on ~;
+
+          true
+          [this remainder]))))
+   remainder))
+
+(defn- collect-clauses [bracket-info offset remainder]
+  (second
+   (consume
+    (fn [[clause-map saw-else remainder]]
+      (let [[clause [type right-params else-params remainder]] 
+            (process-clause bracket-info offset remainder)]
+        (cond
+         (= type :right-bracket)
+         [nil [(merge-with concat clause-map 
+                           {(if saw-else :else :clauses) [clause] 
+                            :right-params right-params})
+               remainder]]
+
+         (= type :else)
+         (cond
+          (:else clause-map)
+          (format-error "Two else clauses (\"~:;\") inside bracket construction." offset)
+         
+          (not (:else bracket-info))
+          (format-error "An else clause (\"~:;\") is in a bracket type that doesn't support it." 
+                        offset)
+
+          (and (= :first (:else bracket-info)) (seq (:clauses clause-map)))
+          (format-error
+           "The else clause (\"~:;\") is only allowed in the first position for this directive." 
+           offset)
+         
+          true         ; if the ~:; is in the last position, the else clause
+                                        ; is next, this was a regular clause
+          (if (= :first (:else bracket-info))
+            [true [(merge-with concat clause-map { :else [clause] :else-params else-params})
+                   false remainder]]
+            [true [(merge-with concat clause-map { :clauses [clause] })
+                   true remainder]]))
+
+         (= type :separator)
+         (cond
+          saw-else
+          (format-error "A plain clause (with \"~;\") follows an else clause (\"~:;\") inside bracket construction." offset)
+         
+          (not (:allows-separator bracket-info))
+          (format-error "A separator (\"~;\") is in a bracket type that doesn't support it." 
+                        offset)
+         
+          true
+          [true [(merge-with concat clause-map { :clauses [clause] })
+                 false remainder]]))))
+    [{ :clauses [] } false remainder])))
+
+(defn- process-nesting
+  "Take a linearly compiled format and process the bracket directives to give it 
+   the appropriate tree structure"
+  [format]
+  (first
+   (consume 
+    (fn [remainder]
+      (let [this (first remainder)
+            remainder (next remainder)
+            bracket (:bracket-info (:def this))]
+        (if (:right bracket)
+          (process-bracket this remainder)
+          [this remainder])))
+    format)))
+
+(defn- compile-format 
+  "Compiles format-str into a compiled format which can be used as an argument
+to cl-format just like a plain format string. Use this function for improved 
+performance when you're using the same format string repeatedly"
+  [ format-str ]
+;  (prlabel compiling format-str)
+  (binding [*format-str* format-str]
+    (process-nesting
+     (first 
+      (consume 
+       (fn [[^String s offset]]
+         (if (empty? s)
+           [nil s]
+           (let [tilde (.indexOf s (int \~))]
+             (cond
+              (neg? tilde) [(compile-raw-string s offset) ["" (+ offset (.length s))]]
+              (zero? tilde)  (compile-directive (subs s 1) (inc offset))
+              true 
+              [(compile-raw-string (subs s 0 tilde) offset) [(subs s tilde) (+ tilde offset)]]))))
+       [format-str 0])))))
+
+(defn- needs-pretty 
+  "determine whether a given compiled format has any directives that depend on the
+column number or pretty printing"
+  [format]
+  (loop [format format]
+    (if (empty? format)
+      false
+      (if (or (:pretty (:flags (:def (first format))))
+              (some needs-pretty (first (:clauses (:params (first format)))))
+              (some needs-pretty (first (:else (:params (first format))))))
+        true
+        (recur (next format))))))
+
+(defn- execute-format 
+  "Executes the format with the arguments."
+  {:skip-wiki true}
+  ([stream format args]
+     (let [^java.io.Writer real-stream (cond 
+                                         (not stream) (java.io.StringWriter.)
+                                         (true? stream) *out*
+                                         :else stream)
+           ^java.io.Writer wrapped-stream (if (and (needs-pretty format) 
+                                                    (not (pretty-writer? real-stream)))
+                                             (get-pretty-writer real-stream)
+                                             real-stream)]
+       (binding [*out* wrapped-stream]
+         (try
+          (execute-format format args)
+          (finally
+           (if-not (identical? real-stream wrapped-stream)
+             (.flush wrapped-stream))))
+         (if (not stream) (.toString real-stream)))))
+  ([format args]
+     (map-passing-context 
+      (fn [element context]
+        (if (abort? context)
+          [nil context]
+          (let [[params args] (realize-parameter-list 
+                               (:params element) context)
+                [params offsets] (unzip-map params)
+                params (assoc params :base-args args)]
+            [nil (apply (:func element) [params args offsets])])))
+      args
+      format)
+     nil))
+
+;;; This is a bad idea, but it prevents us from leaking private symbols
+;;; This should all be replaced by really compiled formats anyway.
+(def ^{:private true} cached-compile (memoize compile-format))
+
+(defmacro formatter
+  "Makes a function which can directly run format-in. The function is
+fn [stream & args] ... and returns nil unless the stream is nil (meaning 
+output to a string) in which case it returns the resulting string.
+
+format-in can be either a control string or a previously compiled format."
+  {:added "1.2"}
+  [format-in]
+  `(let [format-in# ~format-in
+         my-c-c# (var-get (get (ns-interns (the-ns 'clojure.pprint))
+                               '~'cached-compile))
+         my-e-f# (var-get (get (ns-interns (the-ns 'clojure.pprint))
+                               '~'execute-format))
+         my-i-n# (var-get (get (ns-interns (the-ns 'clojure.pprint))
+                               '~'init-navigator))
+         cf# (if (string? format-in#) (my-c-c# format-in#) format-in#)]
+     (fn [stream# & args#]
+       (let [navigator# (my-i-n# args#)]
+         (my-e-f# stream# cf# navigator#)))))
+
+(defmacro formatter-out
+  "Makes a function which can directly run format-in. The function is
+fn [& args] ... and returns nil. This version of the formatter macro is
+designed to be used with *out* set to an appropriate Writer. In particular,
+this is meant to be used as part of a pretty printer dispatch method.
+
+format-in can be either a control string or a previously compiled format."
+  {:added "1.2"}
+  [format-in]
+  `(let [format-in# ~format-in
+         my-c-c# (var-get (get (ns-interns (the-ns 'clojure.pprint))
+                               '~'cached-compile))
+         my-e-f# (var-get (get (ns-interns (the-ns 'clojure.pprint))
+                               '~'execute-format))
+         my-i-n# (var-get (get (ns-interns (the-ns 'clojure.pprint))
+                               '~'init-navigator))
+         cf# (if (string? format-in#) (my-c-c# format-in#) format-in#)]
+     (fn [& args#]
+       (let [navigator# (my-i-n# args#)]
+         (my-e-f# cf# navigator#)))))
diff --git a/src/clj/clojure/pprint/column_writer.clj b/src/clj/clojure/pprint/column_writer.clj
new file mode 100644
index 00000000..ae996e22
--- /dev/null
+++ b/src/clj/clojure/pprint/column_writer.clj
@@ -0,0 +1,79 @@
+;;; column_writer.clj -- part of the pretty printer for Clojure
+
+
+;   Copyright (c) Rich Hickey. 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.
+
+;; Author: Tom Faulhaber
+;; April 3, 2009
+;; Revised to use proxy instead of gen-class April 2010
+
+;; This module implements a column-aware wrapper around an instance of java.io.Writer
+
+(in-ns 'clojure.pprint)
+
+(import [clojure.lang IDeref]
+        [java.io Writer])
+
+(def ^{:private true} *default-page-width* 72)
+
+(defn- get-field [^Writer this sym]
+  (sym @@this))
+
+(defn- set-field [^Writer this sym new-val] 
+  (alter @this assoc sym new-val))
+
+(defn- get-column [this]
+  (get-field this :cur))
+
+(defn- get-line [this]
+  (get-field this :line))
+
+(defn- get-max-column [this]
+  (get-field this :max))
+
+(defn- set-max-column [this new-max]
+  (dosync (set-field this :max new-max))
+  nil)
+
+(defn- get-writer [this]
+  (get-field this :base))
+
+(defn- c-write-char [^Writer this ^Integer c]
+  (dosync (if (= c (int \newline))
+	    (do
+              (set-field this :cur 0)
+              (set-field this :line (inc (get-field this :line))))
+	    (set-field this :cur (inc (get-field this :cur)))))
+  (.write ^Writer (get-field this :base) c))
+
+(defn- column-writer   
+  ([writer] (column-writer writer *default-page-width*))
+  ([writer max-columns]
+     (let [fields (ref {:max max-columns, :cur 0, :line 0 :base writer})]
+       (proxy [Writer IDeref] []
+         (deref [] fields)
+         (write
+          ([^chars cbuf ^Integer off ^Integer len] 
+             (let [^Writer writer (get-field this :base)] 
+               (.write writer cbuf off len)))
+          ([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)))
+                           (do
+                             (set-field this :cur (- (count s) nl 1))
+                             (set-field this :line (+ (get-field this :line)
+                                                      (count (filter #(= % \newline) s)))))))
+                 (.write ^Writer (get-field this :base) s))
+
+               Integer
+               (c-write-char this x))))))))
diff --git a/src/clj/clojure/pprint/dispatch.clj b/src/clj/clojure/pprint/dispatch.clj
new file mode 100644
index 00000000..47b6b41f
--- /dev/null
+++ b/src/clj/clojure/pprint/dispatch.clj
@@ -0,0 +1,448 @@
+;; dispatch.clj -- part of the pretty printer for Clojure
+
+;   Copyright (c) Rich Hickey. 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.
+
+;; Author: Tom Faulhaber
+;; April 3, 2009
+
+
+;; This module implements the default dispatch tables for pretty printing code and
+;; data.
+
+(in-ns 'clojure.pprint)
+
+(defn- use-method
+  "Installs a function as a new method of multimethod associated with dispatch-value. "
+  [multifn dispatch-val func]
+  (. multifn addMethod dispatch-val func))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Implementations of specific dispatch table entries
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Handle forms that can be "back-translated" to reader macros
+;;; Not all reader macros can be dealt with this way or at all. 
+;;; Macros that we can't deal with at all are:
+;;; ;  - The comment character is aborbed by the reader and never is part of the form
+;;; `  - Is fully processed at read time into a lisp expression (which will contain concats
+;;;      and regular quotes).
+;;; ~@ - Also fully eaten by the processing of ` and can't be used outside.
+;;; ,  - is whitespace and is lost (like all other whitespace). Formats can generate commas
+;;;      where they deem them useful to help readability.
+;;; ^  - Adding metadata completely disappears at read time and the data appears to be
+;;;      completely lost.
+;;;
+;;; Most other syntax stuff is dealt with directly by the formats (like (), [], {}, and #{})
+;;; or directly by printing the objects using Clojure's built-in print functions (like
+;;; :keyword, \char, or ""). The notable exception is #() which is special-cased.
+
+(def ^{:private true} reader-macros
+     {'quote "'", 'clojure.core/deref "@", 
+      'var "#'", 'clojure.core/unquote "~"})
+
+(defn- pprint-reader-macro [alis]
+  (let [^String macro-char (reader-macros (first alis))]
+    (when (and macro-char (= 2 (count alis)))
+      (.write ^java.io.Writer *out* macro-char)
+      (write-out (second alis))
+      true)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Dispatch for the basic data types when interpreted
+;; as data (as opposed to code).
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; TODO: inline these formatter statements into funcs so that we
+;;; are a little easier on the stack. (Or, do "real" compilation, a
+;;; la Common Lisp)
+
+;;; (def pprint-simple-list (formatter-out "~:<~@{~w~^ ~_~}~:>"))
+(defn- pprint-simple-list [alis]
+  (pprint-logical-block :prefix "(" :suffix ")"
+    (loop [alis (seq alis)]
+      (when alis
+	(write-out (first alis))
+	(when (next alis)
+	  (.write ^java.io.Writer *out* " ")
+	  (pprint-newline :linear)
+	  (recur (next alis)))))))
+
+(defn- pprint-list [alis]
+  (if-not (pprint-reader-macro alis)
+    (pprint-simple-list alis)))
+
+;;; (def pprint-vector (formatter-out "~<[~;~@{~w~^ ~_~}~;]~:>"))
+(defn- pprint-vector [avec]
+  (pprint-logical-block :prefix "[" :suffix "]"
+    (loop [aseq (seq avec)]
+      (when aseq
+	(write-out (first aseq))
+	(when (next aseq)
+	  (.write ^java.io.Writer *out* " ")
+	  (pprint-newline :linear)
+	  (recur (next aseq)))))))
+
+(def ^{:private true} pprint-array (formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>"))
+
+;;; (def pprint-map (formatter-out "~<{~;~@{~<~w~^ ~_~w~:>~^, ~_~}~;}~:>"))
+(defn- pprint-map [amap]
+  (pprint-logical-block :prefix "{" :suffix "}"
+    (loop [aseq (seq amap)]
+      (when aseq
+	(pprint-logical-block 
+          (write-out (ffirst aseq))
+          (.write ^java.io.Writer *out* " ")
+          (pprint-newline :linear)
+          (write-out (fnext (first aseq))))
+        (when (next aseq)
+          (.write ^java.io.Writer *out* ", ")
+          (pprint-newline :linear)
+          (recur (next aseq)))))))
+
+(def ^{:private true} pprint-set (formatter-out "~<#{~;~@{~w~^ ~:_~}~;}~:>"))
+(defn- pprint-ref [ref]
+  (pprint-logical-block  :prefix "#<Ref " :suffix ">"
+    (write-out @ref)))
+(defn- pprint-atom [ref]
+  (pprint-logical-block :prefix "#<Atom " :suffix ">"
+    (write-out @ref)))
+(defn- pprint-agent [ref]
+  (pprint-logical-block :prefix "#<Agent " :suffix ">"
+    (write-out @ref)))
+
+(defn- pprint-simple-default [obj]
+  (cond 
+    (.isArray (class obj)) (pprint-array obj)
+    (and *print-suppress-namespaces* (symbol? obj)) (print (name obj))
+    :else (pr obj)))
+
+
+(defmulti 
+  simple-dispatch
+  "The pretty print dispatch function for simple data structure format."
+  {:added "1.2" :arglists '[[object]]} 
+  class)
+
+(use-method simple-dispatch clojure.lang.ISeq pprint-list)
+(use-method simple-dispatch clojure.lang.IPersistentVector pprint-vector)
+(use-method simple-dispatch clojure.lang.IPersistentMap pprint-map)
+(use-method simple-dispatch clojure.lang.IPersistentSet pprint-set)
+(use-method simple-dispatch clojure.lang.Ref pprint-ref)
+(use-method simple-dispatch clojure.lang.Atom pprint-atom)
+(use-method simple-dispatch clojure.lang.Agent pprint-agent)
+(use-method simple-dispatch nil pr)
+(use-method simple-dispatch :default pprint-simple-default)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Dispatch for the code table
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare pprint-simple-code-list)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Format something that looks like a simple def (sans metadata, since the reader
+;;; won't give it to us now).
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^{:private true} pprint-hold-first (formatter-out "~:<~w~^ ~@_~w~^ ~_~@{~w~^ ~_~}~:>"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Format something that looks like a defn or defmacro
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Format the params and body of a defn with a single arity
+(defn- single-defn [alis has-doc-str?]
+  (if (seq alis)
+    (do
+      (if has-doc-str?
+        ((formatter-out " ~_"))
+        ((formatter-out " ~@_")))
+      ((formatter-out "~{~w~^ ~_~}") alis))))
+
+;;; Format the param and body sublists of a defn with multiple arities
+(defn- multi-defn [alis has-doc-str?]
+  (if (seq alis)
+    ((formatter-out " ~_~{~w~^ ~_~}") alis)))
+
+;;; TODO: figure out how to support capturing metadata in defns (we might need a 
+;;; special reader)
+(defn- pprint-defn [alis]
+  (if (next alis) 
+    (let [[defn-sym defn-name & stuff] alis
+          [doc-str stuff] (if (string? (first stuff))
+                            [(first stuff) (next stuff)]
+                            [nil stuff])
+          [attr-map stuff] (if (map? (first stuff))
+                             [(first stuff) (next stuff)]
+                             [nil stuff])]
+      (pprint-logical-block :prefix "(" :suffix ")"
+        ((formatter-out "~w ~1I~@_~w") defn-sym defn-name)
+        (if doc-str
+          ((formatter-out " ~_~w") doc-str))
+        (if attr-map
+          ((formatter-out " ~_~w") attr-map))
+        ;; Note: the multi-defn case will work OK for malformed defns too
+        (cond
+         (vector? (first stuff)) (single-defn stuff (or doc-str attr-map))
+         :else (multi-defn stuff (or doc-str attr-map)))))
+    (pprint-simple-code-list alis)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Format something with a binding form
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- pprint-binding-form [binding-vec]
+  (pprint-logical-block :prefix "[" :suffix "]"
+    (loop [binding binding-vec]
+      (when (seq binding)
+        (pprint-logical-block binding
+          (write-out (first binding))
+          (when (next binding)
+            (.write ^java.io.Writer *out* " ")
+            (pprint-newline :miser)
+            (write-out (second binding))))
+        (when (next (rest binding))
+          (.write ^java.io.Writer *out* " ")
+          (pprint-newline :linear)
+          (recur (next (rest binding))))))))
+
+(defn- pprint-let [alis]
+  (let [base-sym (first alis)]
+    (pprint-logical-block :prefix "(" :suffix ")"
+      (if (and (next alis) (vector? (second alis)))
+        (do
+          ((formatter-out "~w ~1I~@_") base-sym)
+          (pprint-binding-form (second alis))
+          ((formatter-out " ~_~{~w~^ ~_~}") (next (rest alis))))
+        (pprint-simple-code-list alis)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Format something that looks like "if"
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^{:private true} pprint-if (formatter-out "~:<~1I~w~^ ~@_~w~@{ ~_~w~}~:>"))
+
+(defn- pprint-cond [alis]
+  (pprint-logical-block :prefix "(" :suffix ")"
+    (pprint-indent :block 1)
+    (write-out (first alis))
+    (when (next alis)
+      (.write ^java.io.Writer *out* " ")
+      (pprint-newline :linear)
+     (loop [alis (next alis)]
+       (when alis
+         (pprint-logical-block alis
+          (write-out (first alis))
+          (when (next alis)
+            (.write ^java.io.Writer *out* " ")
+            (pprint-newline :miser)
+            (write-out (second alis))))
+         (when (next (rest alis))
+           (.write ^java.io.Writer *out* " ")
+           (pprint-newline :linear)
+           (recur (next (rest alis)))))))))
+
+(defn- pprint-condp [alis]
+  (if (> (count alis) 3) 
+    (pprint-logical-block :prefix "(" :suffix ")"
+      (pprint-indent :block 1)
+      (apply (formatter-out "~w ~@_~w ~@_~w ~_") alis)
+      (loop [alis (seq (drop 3 alis))]
+        (when alis
+          (pprint-logical-block alis
+            (write-out (first alis))
+            (when (next alis)
+              (.write ^java.io.Writer *out* " ")
+              (pprint-newline :miser)
+              (write-out (second alis))))
+          (when (next (rest alis))
+            (.write ^java.io.Writer *out* " ")
+            (pprint-newline :linear)
+            (recur (next (rest alis)))))))
+    (pprint-simple-code-list alis)))
+
+;;; The map of symbols that are defined in an enclosing #() anonymous function
+(def ^{:private true} *symbol-map* {})
+
+(defn- pprint-anon-func [alis]
+  (let [args (second alis)
+        nlis (first (rest (rest alis)))]
+    (if (vector? args)
+      (binding [*symbol-map* (if (= 1 (count args)) 
+                               {(first args) "%"}
+                               (into {} 
+                                     (map 
+                                      #(vector %1 (str \% %2)) 
+                                      args 
+                                      (range 1 (inc (count args))))))]
+        ((formatter-out "~<#(~;~@{~w~^ ~_~}~;)~:>") nlis))
+      (pprint-simple-code-list alis))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The master definitions for formatting lists in code (that is, (fn args...) or
+;;; special forms).
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; This is the equivalent of (formatter-out "~:<~1I~@{~w~^ ~_~}~:>"), but is
+;;; easier on the stack.
+
+(defn- pprint-simple-code-list [alis]
+  (pprint-logical-block :prefix "(" :suffix ")"
+    (pprint-indent :block 1)
+    (loop [alis (seq alis)]
+      (when alis
+	(write-out (first alis))
+	(when (next alis)
+	  (.write ^java.io.Writer *out* " ")
+	  (pprint-newline :linear)
+	  (recur (next alis)))))))
+
+;;; Take a map with symbols as keys and add versions with no namespace.
+;;; That is, if ns/sym->val is in the map, add sym->val to the result.
+(defn- two-forms [amap]
+  (into {} 
+        (mapcat 
+         identity 
+         (for [x amap] 
+           [x [(symbol (name (first x))) (second x)]]))))
+
+(defn- add-core-ns [amap]
+  (let [core "clojure.core"]
+    (into {}
+          (map #(let [[s f] %] 
+                  (if (not (or (namespace s) (special-symbol? s)))
+                    [(symbol core (name s)) f]
+                    %))
+               amap))))
+
+(def ^{:private true} *code-table*
+     (two-forms
+      (add-core-ns
+       {'def pprint-hold-first, 'defonce pprint-hold-first, 
+	'defn pprint-defn, 'defn- pprint-defn, 'defmacro pprint-defn, 'fn pprint-defn,
+        'let pprint-let, 'loop pprint-let, 'binding pprint-let,
+        'with-local-vars pprint-let, 'with-open pprint-let, 'when-let pprint-let,
+	'if-let pprint-let, 'doseq pprint-let, 'dotimes pprint-let,
+	'when-first pprint-let,
+        'if pprint-if, 'if-not pprint-if, 'when pprint-if, 'when-not pprint-if,
+        'cond pprint-cond, 'condp pprint-condp,
+        'fn* pprint-anon-func,
+        '. pprint-hold-first, '.. pprint-hold-first, '-> pprint-hold-first,
+        'locking pprint-hold-first, 'struct pprint-hold-first,
+        'struct-map pprint-hold-first, 
+        })))
+
+(defn- pprint-code-list [alis]
+  (if-not (pprint-reader-macro alis) 
+    (if-let [special-form (*code-table* (first alis))]
+      (special-form alis)
+      (pprint-simple-code-list alis))))
+
+(defn- pprint-code-symbol [sym] 
+  (if-let [arg-num (sym *symbol-map*)]
+    (print arg-num)
+    (if *print-suppress-namespaces* 
+      (print (name sym))
+      (pr sym))))
+
+(defmulti 
+  code-dispatch
+  "The pretty print dispatch function for pretty printing Clojure code."
+  {:added "1.2" :arglists '[[object]]} 
+  class)
+
+(use-method code-dispatch clojure.lang.ISeq pprint-code-list)
+(use-method code-dispatch clojure.lang.Symbol pprint-code-symbol)
+
+;; The following are all exact copies of simple-dispatch
+(use-method code-dispatch clojure.lang.IPersistentVector pprint-vector)
+(use-method code-dispatch clojure.lang.IPersistentMap pprint-map)
+(use-method code-dispatch clojure.lang.IPersistentSet pprint-set)
+(use-method code-dispatch clojure.lang.Ref pprint-ref)
+(use-method code-dispatch clojure.lang.Atom pprint-atom)
+(use-method code-dispatch clojure.lang.Agent pprint-agent)
+(use-method code-dispatch nil pr)
+(use-method code-dispatch :default pprint-simple-default)
+
+(set-pprint-dispatch simple-dispatch)
+
+
+;;; For testing
+(comment
+
+(with-pprint-dispatch code-dispatch 
+  (pprint 
+   '(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)))))
+
+(with-pprint-dispatch code-dispatch 
+  (pprint 
+   '(defn cl-format 
+      [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)))))
+
+(with-pprint-dispatch code-dispatch 
+  (pprint
+   '(defn- -write 
+      ([this x]
+         (condp = (class x)
+           String 
+           (let [s0 (write-initial-lines this x)
+                 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
+           (let [c ^Character x]
+             (if (= (getf :mode) :writing)
+               (do 
+                 (write-white-space this)
+                 (.col_write this x))
+               (if (= c (int \newline))
+                 (write-initial-lines this "\n")
+                 (add-to-buffer this (make-buffer-blob (str (char c)) nil))))))))))
+
+(with-pprint-dispatch code-dispatch 
+  (pprint 
+   '(defn pprint-defn [writer alis]
+      (if (next alis) 
+        (let [[defn-sym defn-name & stuff] alis
+              [doc-str stuff] (if (string? (first stuff))
+                                [(first stuff) (next stuff)]
+                                [nil stuff])
+              [attr-map stuff] (if (map? (first stuff))
+                                 [(first stuff) (next stuff)]
+                                 [nil stuff])]
+          (pprint-logical-block writer :prefix "(" :suffix ")"
+                                (cl-format true "~w ~1I~@_~w" defn-sym defn-name)
+                                (if doc-str
+                                  (cl-format true " ~_~w" doc-str))
+                                (if attr-map
+                                  (cl-format true " ~_~w" attr-map))
+                                ;; Note: the multi-defn case will work OK for malformed defns too
+                                (cond
+                                  (vector? (first stuff)) (single-defn stuff (or doc-str attr-map))
+                                  :else (multi-defn stuff (or doc-str attr-map)))))
+        (pprint-simple-code-list writer alis)))))
+)
+nil
+
diff --git a/src/clj/clojure/pprint/pprint_base.clj b/src/clj/clojure/pprint/pprint_base.clj
new file mode 100644
index 00000000..88e032d8
--- /dev/null
+++ b/src/clj/clojure/pprint/pprint_base.clj
@@ -0,0 +1,369 @@
+;;; pprint_base.clj -- part of the pretty printer for Clojure
+
+;   Copyright (c) Rich Hickey. 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.
+
+;; Author: Tom Faulhaber
+;; April 3, 2009
+
+
+;; This module implements the generic pretty print functions and special variables
+
+(in-ns 'clojure.pprint)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Variables that control the pretty printer
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;
+;;; *print-length*, *print-level* and *print-dup* are defined in clojure.core
+;;; TODO: use *print-dup* here (or is it supplanted by other variables?)
+;;; TODO: make dispatch items like "(let..." get counted in *print-length*
+;;; constructs
+
+
+(def
+ ^{:doc "Bind to true if you want write to use pretty printing", :added "1.2"}
+ *print-pretty* true)
+
+(defonce ; If folks have added stuff here, don't overwrite
+ ^{:doc "The pretty print dispatch function. Use with-pprint-dispatch or set-pprint-dispatch
+to modify.",
+   :added "1.2"}
+ *print-pprint-dispatch* nil)
+
+(def
+ ^{:doc "Pretty printing will try to avoid anything going beyond this column.
+Set it to nil to have pprint let the line be arbitrarily long. This will ignore all 
+non-mandatory newlines.",
+   :added "1.2"}
+ *print-right-margin* 72)
+
+(def
+ ^{:doc "The column at which to enter miser style. Depending on the dispatch table, 
+miser style add newlines in more places to try to keep lines short allowing for further 
+levels of nesting.",
+   :added "1.2"}
+ *print-miser-width* 40)
+
+;;; TODO implement output limiting
+(def
+ ^{:private true,
+   :doc "Maximum number of lines to print in a pretty print instance (N.B. This is not yet used)"}
+ *print-lines* nil)
+
+;;; TODO: implement circle and shared
+(def
+ ^{:private true,
+   :doc "Mark circular structures (N.B. This is not yet used)"}
+ *print-circle* nil)
+
+;;; TODO: should we just use *print-dup* here?
+(def
+ ^{:private true,
+   :doc "Mark repeated structures rather than repeat them (N.B. This is not yet used)"}
+ *print-shared* nil)
+
+(def
+ ^{:doc "Don't print namespaces with symbols. This is particularly useful when 
+pretty printing the results of macro expansions"
+   :added "1.2"}
+ *print-suppress-namespaces* nil)
+
+;;; TODO: support print-base and print-radix in cl-format
+;;; TODO: support print-base and print-radix in rationals
+(def
+ ^{:doc "Print a radix specifier in front of integers and rationals. If *print-base* is 2, 8, 
+or 16, then the radix specifier used is #b, #o, or #x, respectively. Otherwise the 
+radix specifier is in the form #XXr where XX is the decimal value of *print-base* "
+   :added "1.2"}
+ *print-radix* nil)
+
+(def
+ ^{:doc "The base to use for printing integers and rationals."
+   :added "1.2"}
+ *print-base* 10)
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Internal variables that keep track of where we are in the 
+;; structure
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^{ :private true } *current-level* 0)
+
+(def ^{ :private true } *current-length* nil)
+
+;; TODO: add variables for length, lines.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Support for the write function
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare format-simple-number)
+
+(def ^{:private true} orig-pr pr)
+
+(defn- pr-with-base [x]
+  (if-let [s (format-simple-number x)]
+    (print s)
+    (orig-pr x)))
+
+(def ^{:private true} write-option-table
+     {;:array            *print-array*
+      :base             'clojure.pprint/*print-base*,
+      ;;:case             *print-case*,
+      :circle           'clojure.pprint/*print-circle*,
+      ;;:escape           *print-escape*,
+      ;;:gensym           *print-gensym*,
+      :length           'clojure.core/*print-length*,
+      :level            'clojure.core/*print-level*,
+      :lines            'clojure.pprint/*print-lines*,
+      :miser-width      'clojure.pprint/*print-miser-width*,
+      :dispatch         'clojure.pprint/*print-pprint-dispatch*,
+      :pretty           'clojure.pprint/*print-pretty*,
+      :radix            'clojure.pprint/*print-radix*,
+      :readably         'clojure.core/*print-readably*,
+      :right-margin     'clojure.pprint/*print-right-margin*,
+      :suppress-namespaces 'clojure.pprint/*print-suppress-namespaces*})
+
+
+(defmacro ^{:private true} binding-map [amap & body]
+  (let []
+    `(do
+       (. clojure.lang.Var (pushThreadBindings ~amap))
+       (try
+        ~@body
+        (finally
+         (. clojure.lang.Var (popThreadBindings)))))))
+
+(defn- table-ize [t m] 
+  (apply hash-map (mapcat 
+                   #(when-let [v (get t (key %))] [(find-var v) (val %)]) 
+                   m)))
+
+(defn- pretty-writer? 
+  "Return true iff x is a PrettyWriter"
+  [x] (and (instance? clojure.lang.IDeref x) (:pretty-writer @@x)))
+
+(defn- make-pretty-writer 
+  "Wrap base-writer in a PrettyWriter with the specified right-margin and miser-width"
+  [base-writer right-margin miser-width]
+  (pretty-writer base-writer right-margin miser-width))
+
+(defmacro ^{:private true} with-pretty-writer [base-writer & body]
+  `(let [base-writer# ~base-writer
+         new-writer# (not (pretty-writer? base-writer#))]
+     (binding [*out* (if new-writer#
+                      (make-pretty-writer base-writer# *print-right-margin* *print-miser-width*)
+                      base-writer#)]
+       ~@body
+       (.flush *out*))))
+
+
+;;;TODO: if pretty print is not set, don't use pr but rather something that respects *print-base*, etc.
+(defn write-out 
+  "Write an object to *out* subject to the current bindings of the printer control 
+variables. Use the kw-args argument to override individual variables for this call (and 
+any recursive calls).
+
+*out* must be a PrettyWriter if pretty printing is enabled. This is the responsibility
+of the caller.
+
+This method is primarily intended for use by pretty print dispatch functions that 
+already know that the pretty printer will have set up their environment appropriately.
+Normal library clients should use the standard \"write\" interface. "
+  {:added "1.2"}
+  [object]
+  (let [length-reached (and 
+                        *current-length*
+                        *print-length*
+                        (>= *current-length* *print-length*))]
+    (if-not *print-pretty*
+      (pr object)
+      (if length-reached
+        (print "...")
+        (do
+          (if *current-length* (set! *current-length* (inc *current-length*)))
+          (*print-pprint-dispatch* object))))
+    length-reached))
+
+(defn write 
+  "Write an object subject to the current bindings of the printer control variables.
+Use the kw-args argument to override individual variables for this call (and any 
+recursive calls). Returns the string result if :stream is nil or nil otherwise.
+
+The following keyword arguments can be passed with values:
+  Keyword              Meaning                              Default value
+  :stream              Writer for output or nil             true (indicates *out*)
+  :base                Base to use for writing rationals    Current value of *print-base*
+  :circle*             If true, mark circular structures    Current value of *print-circle*
+  :length              Maximum elements to show in sublists Current value of *print-length*
+  :level               Maximum depth                        Current value of *print-level*
+  :lines*              Maximum lines of output              Current value of *print-lines*
+  :miser-width         Width to enter miser mode            Current value of *print-miser-width*
+  :dispatch            The pretty print dispatch function   Current value of *print-pprint-dispatch*
+  :pretty              If true, do pretty printing          Current value of *print-pretty*
+  :radix               If true, prepend a radix specifier   Current value of *print-radix*
+  :readably*           If true, print readably              Current value of *print-readably*
+  :right-margin        The column for the right margin      Current value of *print-right-margin*
+  :suppress-namespaces If true, no namespaces in symbols    Current value of *print-suppress-namespaces*
+
+  * = not yet supported
+"
+  {:added "1.2"}
+  [object & kw-args]
+  (let [options (merge {:stream true} (apply hash-map kw-args))]
+    (binding-map (table-ize write-option-table options) 
+      (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {}) 
+        (let [optval (if (contains? options :stream) 
+                       (:stream options)
+                       true) 
+              base-writer (condp = optval
+                            nil (java.io.StringWriter.)
+                            true *out*
+                            optval)]
+          (if *print-pretty*
+            (with-pretty-writer base-writer
+              (write-out object))
+            (binding [*out* base-writer]
+              (pr object)))
+          (if (nil? optval) 
+            (.toString ^java.io.StringWriter base-writer)))))))
+
+
+(defn pprint 
+  "Pretty print object to the optional output writer. If the writer is not provided, 
+print the object to the currently bound value of *out*."
+  {:added "1.2"}
+  ([object] (pprint object *out*)) 
+  ([object writer]
+     (with-pretty-writer writer
+       (binding [*print-pretty* true]
+         (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {}) 
+           (write-out object)))
+       (if (not (= 0 (get-column *out*)))
+         (.write *out* (int \newline))))))
+
+(defmacro pp 
+  "A convenience macro that pretty prints the last thing output. This is
+exactly equivalent to (pprint *1)."
+  {:added "1.2"}
+  [] `(pprint *1))
+
+(defn set-pprint-dispatch  
+  "Set the pretty print dispatch function to a function matching (fn [obj] ...)
+where obj is the object to pretty print. That function will be called with *out* set
+to a pretty printing writer to which it should do its printing.
+
+For example functions, see simple-dispatch and code-dispatch in 
+clojure.pprint.dispatch.clj."
+  {:added "1.2"}
+  [function]
+  (let [old-meta (meta #'*print-pprint-dispatch*)]
+    (alter-var-root #'*print-pprint-dispatch* (constantly function))
+    (alter-meta! #'*print-pprint-dispatch* (constantly old-meta)))
+  nil)
+
+(defmacro with-pprint-dispatch 
+  "Execute body with the pretty print dispatch function bound to function."
+  {:added "1.2"}
+  [function & body]
+  `(binding [*print-pprint-dispatch* ~function]
+     ~@body))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Support for the functional interface to the pretty printer
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- parse-lb-options [opts body]
+  (loop [body body
+         acc []]
+    (if (opts (first body))
+      (recur (drop 2 body) (concat acc (take 2 body)))
+      [(apply hash-map acc) body])))
+
+(defn- check-enumerated-arg [arg choices]
+  (if-not (choices arg)
+          (throw
+           (IllegalArgumentException.
+            ;; TODO clean up choices string
+            (str "Bad argument: " arg ". It must be one of " choices)))))
+
+(defn- level-exceeded []
+  (and *print-level* (>= *current-level* *print-level*)))
+
+(defmacro pprint-logical-block 
+  "Execute the body as a pretty printing logical block with output to *out* which 
+must be a pretty printing writer. When used from pprint or cl-format, this can be 
+assumed. 
+
+This function is intended for use when writing custom dispatch functions.
+
+Before the body, the caller can optionally specify options: :prefix, :per-line-prefix, 
+and :suffix."
+  {:added "1.2", :arglists '[[options* body]]}
+  [& args]
+  (let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} args)]
+    `(do (if (level-exceeded) 
+           (.write ^java.io.Writer *out* "#")
+           (binding [*current-level* (inc *current-level*)
+                     *current-length* 0] 
+             (start-block *out*
+                          ~(:prefix options) ~(:per-line-prefix options) ~(:suffix options))
+             ~@body
+             (end-block *out*)))
+         nil)))
+
+(defn pprint-newline
+  "Print a conditional newline to a pretty printing stream. kind specifies if the 
+newline is :linear, :miser, :fill, or :mandatory. 
+
+This function is intended for use when writing custom dispatch functions.
+
+Output is sent to *out* which must be a pretty printing writer."
+  {:added "1.2"}
+  [kind] 
+  (check-enumerated-arg kind #{:linear :miser :fill :mandatory})
+  (nl *out* kind))
+
+(defn pprint-indent 
+  "Create an indent at this point in the pretty printing stream. This defines how 
+following lines are indented. relative-to can be either :block or :current depending 
+whether the indent should be computed relative to the start of the logical block or
+the current column position. n is an offset. 
+
+This function is intended for use when writing custom dispatch functions.
+
+Output is sent to *out* which must be a pretty printing writer."
+  {:added "1.2"}
+  [relative-to n] 
+  (check-enumerated-arg relative-to #{:block :current})
+  (indent *out* relative-to n))
+
+;; TODO a real implementation for pprint-tab
+(defn pprint-tab 
+  "Tab at this point in the pretty printing stream. kind specifies whether the tab
+is :line, :section, :line-relative, or :section-relative. 
+
+Colnum and colinc specify the target column and the increment to move the target
+forward if the output is already past the original target.
+
+This function is intended for use when writing custom dispatch functions.
+
+Output is sent to *out* which must be a pretty printing writer.
+
+THIS FUNCTION IS NOT YET IMPLEMENTED."
+  {:added "1.2"}
+  [kind colnum colinc] 
+  (check-enumerated-arg kind #{:line :section :line-relative :section-relative})
+  (throw (UnsupportedOperationException. "pprint-tab is not yet implemented")))
+
+
+nil
diff --git a/src/clj/clojure/pprint/pretty_writer.clj b/src/clj/clojure/pprint/pretty_writer.clj
new file mode 100644
index 00000000..f3fd4dbf
--- /dev/null
+++ b/src/clj/clojure/pprint/pretty_writer.clj
@@ -0,0 +1,483 @@
+;;; pretty_writer.clj -- part of the pretty printer for Clojure
+
+;   Copyright (c) Rich Hickey. 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.
+
+;; Author: Tom Faulhaber
+;; April 3, 2009
+;; Revised to use proxy instead of gen-class April 2010
+
+;; This module implements a wrapper around a java.io.Writer which implements the
+;; core of the XP algorithm.
+
+(in-ns 'clojure.pprint)
+
+(import [clojure.lang IDeref]
+        [java.io Writer])
+
+;; TODO: Support for tab directives
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Forward declarations
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare get-miser-width)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 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 @@~'this))
+
+(defmacro ^{:private true} 
+  setf [sym new-val] 
+  "Set the value of the field SYM to NEW-VAL"
+  `(alter @~'this assoc ~sym ~new-val))
+
+(defmacro ^{:private true} 
+  deftype [type-name & fields]
+  (let [name-str (name type-name)]
+    `(do
+       (defstruct ~type-name :type-tag ~@fields)
+       (alter-meta! #'~type-name assoc :private true)
+       (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 pretty-writer
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defstruct ^{:private true} logical-block
+           :parent :section :start-col :indent
+           :done-nl :intra-block-nl
+           :prefix :per-line-prefix :suffix
+           :logical-block-callback)
+
+(defn- ancestor? [parent child]
+  (loop [child (:parent child)]
+    (cond 
+     (nil? child) false
+     (identical? parent child) true
+     :else (recur (:parent child)))))
+
+(defstruct ^{:private true} section :parent)
+
+(defn- buffer-length [l] 
+  (let [l (seq l)]
+    (if l 
+      (- (:end-pos (last l)) (:start-pos (first l)))
+      0)))
+
+; A blob of characters (aka a string)
+(deftype buffer-blob :data :trailing-white-space :start-pos :end-pos)
+
+; A newline
+(deftype nl-t :type :logical-block :start-pos :end-pos)
+
+(deftype start-block-t :logical-block :start-pos :end-pos)
+
+(deftype end-block-t :logical-block :start-pos :end-pos)
+
+(deftype indent-t :logical-block :relative-to :offset :start-pos :end-pos)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Functions to write tokens in the output buffer
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare emit-nl)
+
+(defmulti ^{:private true} write-token #(:type-tag %2))
+(defmethod write-token :start-block-t [^Writer this token]
+   (when-let [cb (getf :logical-block-callback)] (cb :start))
+   (let [lb (:logical-block token)]
+    (dosync
+     (when-let [^String prefix (:prefix lb)] 
+       (.write (getf :base) prefix))
+     (let [col (get-column (getf :base))]
+       (ref-set (:start-col lb) col)
+       (ref-set (:indent lb) col)))))
+
+(defmethod write-token :end-block-t [^Writer this token]
+  (when-let [cb (getf :logical-block-callback)] (cb :end))
+  (when-let [^String suffix (:suffix (:logical-block token))] 
+    (.write (getf :base) suffix)))
+
+(defmethod write-token :indent-t [^Writer this token]
+  (let [lb (:logical-block token)]
+    (ref-set (:indent lb) 
+             (+ (:offset token)
+                (condp = (:relative-to token)
+		  :block @(:start-col lb)
+		  :current (get-column (getf :base)))))))
+
+(defmethod write-token :buffer-blob [^Writer this token]
+  (.write (getf :base) ^String (:data token)))
+
+(defmethod write-token :nl-t [^Writer this token]
+;  (prlabel wt @(:done-nl (:logical-block token)))
+;  (prlabel wt (:type token) (= (:type token) :mandatory))
+  (if (or (= (:type token) :mandatory)
+           (and (not (= (:type token) :fill))
+                @(:done-nl (:logical-block token))))
+    (emit-nl this token)
+    (if-let [^String tws (getf :trailing-white-space)]
+      (.write (getf :base) tws)))
+  (dosync (setf :trailing-white-space nil)))
+
+(defn- write-tokens [^Writer this tokens force-trailing-whitespace]
+  (doseq [token tokens]
+    (if-not (= (:type-tag token) :nl-t)
+      (if-let [^String tws (getf :trailing-white-space)]
+	(.write (getf :base) 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)
+      (.write (getf :base) 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? [^Writer this tokens]
+;;;  (prlabel tf? (get-column (getf :base) (buffer-length tokens))
+  (let [maxcol (get-max-column (getf :base))]
+    (or 
+     (nil? maxcol) 
+     (< (+ (get-column (getf :base)) (buffer-length tokens)) maxcol))))
+
+(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? [^Writer this lb section]
+  (let [miser-width (get-miser-width this)
+        maxcol (get-max-column (getf :base))]
+    (and miser-width maxcol
+         (>= @(:start-col lb) (- maxcol miser-width))
+         (linear-nl? this lb section))))
+
+(defmulti ^{:private true} 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-t? %) (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-t? %) (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 [^Writer this nl]
+  (.write (getf :base) (int \newline))
+  (dosync (setf :trailing-white-space nil))
+  (let [lb (:logical-block nl)
+        ^String prefix (:per-line-prefix lb)] 
+    (if prefix 
+      (.write (getf :base) prefix))
+    (let [^String istr (apply str (repeat (- @(:indent lb) (count prefix))
+					  \space))] 
+      (.write (getf :base) istr))
+    (update-nl-state lb)))
+
+(defn- split-at-newline [tokens]
+  (let [pre (seq (take-while #(not (nl-t? %)) tokens))]
+    [pre (seq (drop (count pre) tokens))]))
+
+;;; Methods for showing token strings for debugging
+
+(defmulti ^{:private true} tok :type-tag)
+(defmethod tok :nl-t [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 [^Writer 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 [^Writer 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 [^Writer 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 
+  [^Writer 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)))
+             ^String l (first lines)] 
+         (if (= :buffering (getf :mode))
+           (let [oldpos (getf :pos)
+                 newpos (+ oldpos (count l))]
+             (setf :pos newpos)
+             (add-to-buffer this (make-buffer-blob l nil oldpos newpos))
+             (write-buffered-output this))
+           (.write (getf :base) l))
+         (.write (getf :base) (int \newline))
+         (doseq [^String l (next (butlast lines))]
+           (.write (getf :base) l)
+           (.write (getf :base) (int \newline))
+           (if prefix
+             (.write (getf :base) prefix)))
+         (setf :buffering :writing)
+         (last lines))))))
+
+
+(defn- write-white-space [^Writer this]
+  (if-let [^String tws (getf :trailing-white-space)]
+    (dosync
+     (.write (getf :base) tws)
+     (setf :trailing-white-space nil))))
+
+(defn- p-write-char [^Writer this ^Integer c]
+  (if (= (getf :mode) :writing)
+    (do 
+      (write-white-space this)
+      (.write (getf :base) c))
+    (if (= c \newline)
+      (write-initial-lines this "\n")
+      (let [oldpos (getf :pos)
+            newpos (inc oldpos)]
+        (dosync
+         (setf :pos newpos)
+         (add-to-buffer this (make-buffer-blob (str (char c)) nil oldpos newpos)))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Initialize the pretty-writer instance
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defn- pretty-writer [writer max-columns miser-width]
+  (let [lb (struct logical-block nil nil (ref 0) (ref 0) (ref false) (ref false))
+        fields (ref {:pretty-writer true
+                     :base (column-writer writer max-columns)
+                     :logical-blocks lb 
+                     :sections nil
+                     :mode :writing
+                     :buffer []
+                     :buffer-block lb
+                     :buffer-level 1
+                     :miser-width miser-width
+                     :trailing-white-space nil
+                     :pos 0})]
+    (proxy [Writer IDeref] []
+      (deref [] fields)
+
+      (write 
+       ([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)]
+              (dosync
+               (if (= mode :writing)
+                 (do
+                   (write-white-space this)
+                   (.write (getf :base) s)
+                   (setf :trailing-white-space white-space))
+                 (let [oldpos (getf :pos)
+                       newpos (+ oldpos (count s0))]
+                   (setf :pos newpos)
+                   (add-to-buffer this (make-buffer-blob s white-space oldpos newpos))))))
+
+            Integer
+            (p-write-char this x))))
+
+      (flush []
+             (if (= (getf :mode) :buffering)
+               (dosync 
+                (write-tokens this (getf :buffer) true)
+                (setf :buffer []))
+               (write-white-space this)))
+
+      (close []
+             (.flush this)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Methods for pretty-writer
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- start-block 
+  [^Writer 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)
+          (when-let [cb (getf :logical-block-callback)] (cb :start))
+          (if prefix 
+           (.write (getf :base) prefix))
+         (let [col (get-column (getf :base))]
+           (ref-set (:start-col lb) col)
+           (ref-set (:indent lb) col)))
+       (let [oldpos (getf :pos)
+             newpos (+ oldpos (if prefix (count prefix) 0))]
+         (setf :pos newpos)
+         (add-to-buffer this (make-start-block-t lb oldpos newpos)))))))
+
+(defn- end-block [^Writer this]
+  (dosync
+   (let [lb (getf :logical-blocks)
+         ^String suffix (:suffix lb)]
+     (if (= (getf :mode) :writing)
+       (do
+         (write-white-space this)
+         (if suffix
+           (.write (getf :base) suffix))
+         (when-let [cb (getf :logical-block-callback)] (cb :end)))
+       (let [oldpos (getf :pos)
+             newpos (+ oldpos (if suffix (count suffix) 0))]
+         (setf :pos newpos)
+         (add-to-buffer this (make-end-block-t lb oldpos newpos))))
+     (setf :logical-blocks (:parent lb)))))
+
+(defn- nl [^Writer this type]
+  (dosync 
+   (setf :mode :buffering)
+   (let [pos (getf :pos)]
+     (add-to-buffer this (make-nl-t type (getf :logical-blocks) pos pos)))))
+
+(defn- indent [^Writer 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 (get-column (getf :base))))))
+       (let [pos (getf :pos)]
+         (add-to-buffer this (make-indent-t lb relative-to offset pos pos)))))))
+
+(defn- get-miser-width [^Writer this]
+  (getf :miser-width))
+
+(defn- set-miser-width [^Writer this new-miser-width]
+  (dosync (setf :miser-width new-miser-width)))
+
+(defn- set-logical-block-callback [^Writer this f]
+  (dosync (setf :logical-block-callback f)))
diff --git a/src/clj/clojure/pprint/utilities.clj b/src/clj/clojure/pprint/utilities.clj
new file mode 100644
index 00000000..0385fd3b
--- /dev/null
+++ b/src/clj/clojure/pprint/utilities.clj
@@ -0,0 +1,104 @@
+;;; utilities.clj -- part of the pretty printer for Clojure
+
+;   Copyright (c) Rich Hickey. 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.
+
+;; Author: Tom Faulhaber
+;; April 3, 2009
+
+;; This module implements some utility function used in formatting and pretty
+;; printing. The functions here could go in a more general purpose library,
+;; perhaps.
+
+(in-ns 'clojure.pprint)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Helper functions for digesting formats in the various
+;;; phases of their lives.
+;;; These functions are actually pretty general.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- map-passing-context [func initial-context lis]
+  (loop [context initial-context
+         lis lis
+         acc []]
+    (if (empty? lis)
+      [acc context]
+    (let [this (first lis)
+          remainder (next lis)
+          [result new-context] (apply func [this context])]
+      (recur new-context remainder (conj acc result))))))
+
+(defn- consume [func initial-context]
+  (loop [context initial-context
+         acc []]
+    (let [[result new-context] (apply func [context])]
+      (if (not result)
+        [acc new-context]
+      (recur new-context (conj acc result))))))
+
+(defn- consume-while [func initial-context]
+  (loop [context initial-context
+         acc []]
+    (let [[result continue new-context] (apply func [context])]
+      (if (not continue)
+        [acc context]
+      (recur new-context (conj acc result))))))
+
+(defn- unzip-map [m]
+  "Take a  map that has pairs in the value slots and produce a pair of maps, 
+   the first having all the first elements of the pairs and the second all 
+   the second elements of the pairs"
+  [(into {} (for [[k [v1 v2]] m] [k v1]))
+   (into {} (for [[k [v1 v2]] m] [k v2]))])
+
+(defn- tuple-map [m v1]
+  "For all the values, v, in the map, replace them with [v v1]"
+  (into {} (for [[k v] m] [k [v v1]])))
+
+(defn- rtrim [s c]
+  "Trim all instances of c from the end of sequence s"
+  (let [len (count s)]
+    (if (and (pos? len) (= (nth s (dec (count s))) c))
+      (loop [n (dec len)]
+        (cond 
+         (neg? n) ""
+         (not (= (nth s n) c)) (subs s 0 (inc n))
+         true (recur (dec n))))
+      s)))
+
+(defn- ltrim [s c]
+  "Trim all instances of c from the beginning of sequence s"
+  (let [len (count s)]
+    (if (and (pos? len) (= (nth s 0) c))
+      (loop [n 0]
+        (if (or (= n len) (not (= (nth s n) c)))
+          (subs s n)
+          (recur (inc n))))
+      s)))
+
+(defn- prefix-count [aseq val]
+  "Return the number of times that val occurs at the start of sequence aseq, 
+if val is a seq itself, count the number of times any element of val occurs at the
+beginning of aseq"
+  (let [test (if (coll? val) (set val) #{val})]
+    (loop [pos 0]
+     (if (or (= pos (count aseq)) (not (test (nth aseq pos))))
+       pos
+       (recur (inc pos))))))
+
+(defn- prerr [& args]
+  "Println to *err*"
+  (binding [*out* *err*]
+    (apply println args)))
+       
+(defmacro ^{:private true} prlabel [prefix arg & more-args]
+  "Print args to *err* in name = value format"
+  `(prerr ~@(cons (list 'quote prefix) (mapcat #(list (list 'quote %) "=" %) 
+                                                  (cons arg (seq more-args))))))
+
diff --git a/test/clojure/test_clojure.clj b/test/clojure/test_clojure.clj
index bb5e8412..4613b2e8 100644
--- a/test/clojure/test_clojure.clj
+++ b/test/clojure/test_clojure.clj
@@ -53,6 +53,7 @@
       :main
       :vectors
       :annotations
+      :pprint
       ])
 
 (def test-namespaces
diff --git a/test/clojure/test_clojure/pprint.clj b/test/clojure/test_clojure/pprint.clj
new file mode 100644
index 00000000..221236fe
--- /dev/null
+++ b/test/clojure/test_clojure/pprint.clj
@@ -0,0 +1,18 @@
+;   Copyright (c) Rich Hickey. 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.
+
+;; Author: Tom Faulhaber
+
+(ns clojure.test-clojure.pprint
+  (:refer-clojure :exclude [format])
+  (:use [clojure.test :only (deftest are run-tests)]
+        clojure.test-clojure.pprint.test-helper
+        clojure.pprint))
+
+(load "pprint/test_cl_format")
+(load "pprint/test_pretty")
diff --git a/test/clojure/test_clojure/pprint/test_cl_format.clj b/test/clojure/test_clojure/pprint/test_cl_format.clj
new file mode 100644
index 00000000..c8fdf18d
--- /dev/null
+++ b/test/clojure/test_clojure/pprint/test_cl_format.clj
@@ -0,0 +1,688 @@
+;;; test_cl_format.clj -- part of the pretty printer for Clojure
+
+;   Copyright (c) Rich Hickey. 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.
+
+;; Author: Tom Faulhaber
+;; April 3, 2009
+
+;; This test set tests the basic cl-format functionality
+
+
+(in-ns 'clojure.test-clojure.pprint)
+
+(def format cl-format)
+
+;; TODO tests for ~A, ~D, etc.
+;; TODO add tests for ~F, etc.: 0.0, 9.9999 with rounding, 9.9999E99 with rounding
+
+(simple-tests d-tests
+  (cl-format nil "~D" 0) "0"
+  (cl-format nil "~D" 2e6) "2000000"
+  (cl-format nil "~D" 2000000) "2000000"
+  (cl-format nil "~:D" 2000000) "2,000,000"
+  (cl-format nil "~D" 1/2) "1/2"
+  (cl-format nil "~D" 'fred) "fred"
+)
+
+(simple-tests base-tests
+  (cl-format nil "~{~2r~^ ~}~%" (range 10))
+  "0 1 10 11 100 101 110 111 1000 1001\n"
+  (with-out-str
+    (dotimes [i 35]
+      (binding [*print-base* (+ i 2)]       ;print the decimal number 40 
+        (write 40)                          ;in each base from 2 to 36
+        (if (zero? (mod i 10)) (prn) (cl-format true " ")))))
+  "101000
+1111 220 130 104 55 50 44 40 37 34
+31 2c 2a 28 26 24 22 20 1j 1i
+1h 1g 1f 1e 1d 1c 1b 1a 19 18
+17 16 15 14 "
+  (with-out-str
+    (doseq [pb [2 3 8 10 16]]               
+      (binding [*print-radix* true      ;print the integer 10 and 
+            *print-base* pb]            ;the ratio 1/10 in bases 2, 
+        (cl-format true "~&~S  ~S~%" 10 1/10))))        ;3, 8, 10, 16
+  "#b1010  #b1/1010
+#3r101  #3r1/101
+#o12  #o1/12
+10.  #10r1/10
+#xa  #x1/a
+")
+
+
+
+(simple-tests cardinal-tests
+  (cl-format nil "~R" 0) "zero"
+  (cl-format nil "~R" 4) "four"
+  (cl-format nil "~R" 15) "fifteen"
+  (cl-format nil "~R" -15) "minus fifteen"
+  (cl-format nil "~R" 25) "twenty-five"
+  (cl-format nil "~R" 20) "twenty"
+  (cl-format nil "~R" 200) "two hundred"
+  (cl-format nil "~R" 203) "two hundred three"
+
+  (cl-format nil "~R" 44879032)
+  "forty-four million, eight hundred seventy-nine thousand, thirty-two"
+
+  (cl-format nil "~R" -44879032)
+  "minus forty-four million, eight hundred seventy-nine thousand, thirty-two"
+  
+  (cl-format nil "~R = ~:*~:D" 44000032)
+  "forty-four million, thirty-two = 44,000,032"
+
+  (cl-format nil "~R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094)
+  "four hundred forty-eight septendecillion, seven hundred ninety sexdecillion, three hundred twenty-nine quindecillion, four hundred eighty quattuordecillion, nine hundred forty-eight tredecillion, two hundred nine duodecillion, three hundred eighty-four undecillion, three hundred eighty-nine decillion, four hundred twenty-nine nonillion, three hundred eighty-four octillion, twenty-nine septillion, three hundred eighty-four sextillion, twenty-nine quintillion, eight hundred forty-two quadrillion, ninety-eight trillion, four hundred twenty billion, nine hundred eighty-nine million, eight hundred forty-two thousand, ninety-four = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094"
+
+  (cl-format nil "~R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094490320942058747587584758375847593475)
+  "448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,475 = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,475"
+
+  (cl-format nil "~R = ~:*~:D" 2e6)
+  "two million = 2,000,000"
+
+  (cl-format nil "~R = ~:*~:D" 200000200000)
+  "two hundred billion, two hundred thousand = 200,000,200,000")
+
+(simple-tests ordinal-tests
+  (cl-format nil "~:R" 0) "zeroth"
+  (cl-format nil "~:R" 4) "fourth"
+  (cl-format nil "~:R" 15) "fifteenth"
+  (cl-format nil "~:R" -15) "minus fifteenth"
+  (cl-format nil "~:R" 25) "twenty-fifth"
+  (cl-format nil "~:R" 20) "twentieth"
+  (cl-format nil "~:R" 200) "two hundredth"
+  (cl-format nil "~:R" 203) "two hundred third"
+
+  (cl-format nil "~:R" 44879032)
+  "forty-four million, eight hundred seventy-nine thousand, thirty-second"
+
+  (cl-format nil "~:R" -44879032)
+  "minus forty-four million, eight hundred seventy-nine thousand, thirty-second"
+  
+  (cl-format nil "~:R = ~:*~:D" 44000032)
+  "forty-four million, thirty-second = 44,000,032"
+
+  (cl-format nil "~:R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094)
+  "four hundred forty-eight septendecillion, seven hundred ninety sexdecillion, three hundred twenty-nine quindecillion, four hundred eighty quattuordecillion, nine hundred forty-eight tredecillion, two hundred nine duodecillion, three hundred eighty-four undecillion, three hundred eighty-nine decillion, four hundred twenty-nine nonillion, three hundred eighty-four octillion, twenty-nine septillion, three hundred eighty-four sextillion, twenty-nine quintillion, eight hundred forty-two quadrillion, ninety-eight trillion, four hundred twenty billion, nine hundred eighty-nine million, eight hundred forty-two thousand, ninety-fourth = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094"
+  (cl-format nil "~:R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094490320942058747587584758375847593475)
+  "448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,475th = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,475"
+  (cl-format nil "~:R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094490320942058747587584758375847593471)
+  "448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,471st = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,471"
+  (cl-format nil "~:R = ~:*~:D" 2e6)
+  "two millionth = 2,000,000")
+
+(simple-tests ordinal1-tests
+  (cl-format nil "~:R" 1) "first"
+  (cl-format nil "~:R" 11) "eleventh"
+  (cl-format nil "~:R" 21) "twenty-first"
+  (cl-format nil "~:R" 20) "twentieth"
+  (cl-format nil "~:R" 220) "two hundred twentieth"
+  (cl-format nil "~:R" 200) "two hundredth"
+  (cl-format nil "~:R" 999) "nine hundred ninety-ninth"
+  )
+
+(simple-tests roman-tests
+  (cl-format nil "~@R" 3) "III"
+  (cl-format nil "~@R" 4) "IV"
+  (cl-format nil "~@R" 9) "IX"
+  (cl-format nil "~@R" 29) "XXIX"
+  (cl-format nil "~@R" 429) "CDXXIX"
+  (cl-format nil "~@:R" 429) "CCCCXXVIIII"
+  (cl-format nil "~@:R" 3429) "MMMCCCCXXVIIII"
+  (cl-format nil "~@R" 3429) "MMMCDXXIX"
+  (cl-format nil "~@R" 3479) "MMMCDLXXIX"
+  (cl-format nil "~@R" 3409) "MMMCDIX"
+  (cl-format nil "~@R" 300) "CCC"
+  (cl-format nil "~@R ~D" 300 20) "CCC 20"
+  (cl-format nil "~@R" 5000) "5,000"
+  (cl-format nil "~@R ~D" 5000 20) "5,000 20"
+  (cl-format nil "~@R" "the quick") "the quick")
+
+(simple-tests c-tests
+  (cl-format nil "~{~c~^, ~}~%" "hello") "h, e, l, l, o\n"
+  (cl-format nil "~{~:c~^, ~}~%" "hello") "h, e, l, l, o\n"
+  (cl-format nil "~@C~%" \m) "\\m\n"
+  (cl-format nil "~@C~%" (char 222)) "\\Þ\n"
+  (cl-format nil "~@C~%" (char 8)) "\\backspace\n"
+  (cl-format nil "~@C~%" (char 3)) "\\\n")
+
+(simple-tests e-tests
+  (cl-format nil "*~E*" 0.0) "*0.0E+0*"
+  (cl-format nil "*~6E*" 0.0) "*0.0E+0*"
+  (cl-format nil "*~6,0E*" 0.0) "* 0.E+0*"
+  (cl-format nil "*~7,2E*" 0.0) "*0.00E+0*"
+  (cl-format nil "*~5E*" 0.0) "*0.E+0*"
+  (cl-format nil "*~10,2,2,,'?E*" 2.8E120) "*??????????*"
+  (cl-format nil "*~10,2E*" 9.99999) "*   1.00E+1*"
+  (cl-format nil "*~10,2E*" 9.99999E99) "* 1.00E+100*"
+  (cl-format nil "*~10,2,2E*" 9.99999E99) "* 1.00E+100*"
+  (cl-format nil "*~10,2,2,,'?E*" 9.99999E99) "*??????????*"
+  )
+  
+(simple-tests $-tests
+  (cl-format nil "~$" 22.3) "22.30"
+  (cl-format nil "~$" 22.375) "22.38"
+  (cl-format nil "~3,5$" 22.375) "00022.375"
+  (cl-format nil "~3,5,8$" 22.375) "00022.375"
+  (cl-format nil "~3,5,10$" 22.375) " 00022.375"
+  (cl-format nil "~3,5,14@$" 22.375) "    +00022.375"
+  (cl-format nil "~3,5,14@$" 22.375) "    +00022.375"
+  (cl-format nil "~3,5,14@:$" 22.375) "+    00022.375"
+  (cl-format nil "~3,,14@:$" 0.375) "+        0.375"
+  (cl-format nil "~1,1$" -12.0) "-12.0"
+  (cl-format nil "~1,1$" 12.0) "12.0"
+  (cl-format nil "~1,1$" 12.0) "12.0"
+  (cl-format nil "~1,1@$" 12.0) "+12.0"
+  (cl-format nil "~1,1,8,' @:$" 12.0) "+   12.0"
+  (cl-format nil "~1,1,8,' @$" 12.0) "   +12.0"
+  (cl-format nil "~1,1,8,' :$" 12.0) "    12.0"
+  (cl-format nil "~1,1,8,' $" 12.0) "    12.0"
+  (cl-format nil "~1,1,8,' @:$" -12.0) "-   12.0"
+  (cl-format nil "~1,1,8,' @$" -12.0) "   -12.0"
+  (cl-format nil "~1,1,8,' :$" -12.0) "-   12.0"
+  (cl-format nil "~1,1,8,' $" -12.0) "   -12.0"
+  (cl-format nil "~1,1$" 0.001) "0.0"
+  (cl-format nil "~2,1$" 0.001) "0.00"
+  (cl-format nil "~1,1,6$" 0.001) "   0.0"
+  (cl-format nil "~1,1,6$" 0.0015) "   0.0"
+  (cl-format nil "~2,1,6$" 0.005) "  0.01"
+  (cl-format nil "~2,1,6$" 0.01) "  0.01"
+  (cl-format nil "~$" 0.099) "0.10"
+  (cl-format nil "~1$" 0.099) "0.1"
+  (cl-format nil "~1$" 0.1) "0.1"
+  (cl-format nil "~1$" 0.99) "1.0"
+  (cl-format nil "~1$" -0.99) "-1.0")
+
+(simple-tests f-tests
+  (cl-format nil "~,1f" -12.0) "-12.0"
+  (cl-format nil "~,0f" 9.4) "9."
+  (cl-format nil "~,0f" 9.5) "10."
+  (cl-format nil "~,0f" -0.99) "-1."
+  (cl-format nil "~,1f" -0.99) "-1.0"
+  (cl-format nil "~,2f" -0.99) "-0.99"
+  (cl-format nil "~,3f" -0.99) "-0.990"
+  (cl-format nil "~,0f" 0.99) "1."
+  (cl-format nil "~,1f" 0.99) "1.0"
+  (cl-format nil "~,2f" 0.99) "0.99"
+  (cl-format nil "~,3f" 0.99) "0.990"
+  (cl-format nil "~f" -1) "-1.0"
+  (cl-format nil "~2f" -1) "-1."
+  (cl-format nil "~3f" -1) "-1."
+  (cl-format nil "~4f" -1) "-1.0"
+  (cl-format nil "~8f" -1) "    -1.0"
+  (cl-format nil "~1,1f" 0.1) ".1")
+
+(simple-tests ampersand-tests
+  (cl-format nil "The quick brown ~a jumped over ~d lazy dogs" 'elephant 5)
+  "The quick brown elephant jumped over 5 lazy dogs"
+  (cl-format nil "The quick brown ~&~a jumped over ~d lazy dogs" 'elephant 5)
+  "The quick brown \nelephant jumped over 5 lazy dogs"
+  (cl-format nil "The quick brown ~&~a jumped\n~& over ~d lazy dogs" 'elephant 5)
+  "The quick brown \nelephant jumped\n over 5 lazy dogs"
+  (cl-format nil "~&The quick brown ~&~a jumped\n~& over ~d lazy dogs" 'elephant 5)
+  "The quick brown \nelephant jumped\n over 5 lazy dogs"
+  (cl-format nil "~3&The quick brown ~&~a jumped\n~& over ~d lazy dogs" 'elephant 5)
+  "\n\nThe quick brown \nelephant jumped\n over 5 lazy dogs"
+  (cl-format nil "~@{~&The quick brown ~a jumped over ~d lazy dogs~}" 'elephant 5 'fox 10)
+  "The quick brown elephant jumped over 5 lazy dogs\nThe quick brown fox jumped over 10 lazy dogs"
+  (cl-format nil "I ~[don't ~:;d~&o ~]have one~%" 0) "I don't have one\n"
+  (cl-format nil "I ~[don't ~:;d~&o ~]have one~%" 1) "I d\no have one\n")
+
+(simple-tests t-tests
+  (cl-format nil "~@{~&~A~8,4T~:*~A~}" 
+             'a 'aa 'aaa 'aaaa 'aaaaa 'aaaaaa 'aaaaaaa 'aaaaaaaa 'aaaaaaaaa 'aaaaaaaaaa)
+  "a       a\naa      aa\naaa     aaa\naaaa    aaaa\naaaaa   aaaaa\naaaaaa  aaaaaa\naaaaaaa aaaaaaa\naaaaaaaa    aaaaaaaa\naaaaaaaaa   aaaaaaaaa\naaaaaaaaaa  aaaaaaaaaa"
+  (cl-format nil "~@{~&~A~,4T~:*~A~}" 
+             'a 'aa 'aaa 'aaaa 'aaaaa 'aaaaaa 'aaaaaaa 'aaaaaaaa 'aaaaaaaaa 'aaaaaaaaaa)
+  "a    a\naa   aa\naaa  aaa\naaaa aaaa\naaaaa    aaaaa\naaaaaa   aaaaaa\naaaaaaa  aaaaaaa\naaaaaaaa aaaaaaaa\naaaaaaaaa    aaaaaaaaa\naaaaaaaaaa   aaaaaaaaaa"
+  (cl-format nil "~@{~&~A~2,6@T~:*~A~}" 'a 'aa 'aaa 'aaaa 'aaaaa 'aaaaaa 'aaaaaaa 'aaaaaaaa 'aaaaaaaaa 'aaaaaaaaaa)
+  "a     a\naa    aa\naaa   aaa\naaaa  aaaa\naaaaa       aaaaa\naaaaaa      aaaaaa\naaaaaaa     aaaaaaa\naaaaaaaa    aaaaaaaa\naaaaaaaaa   aaaaaaaaa\naaaaaaaaaa  aaaaaaaaaa"
+)
+
+(simple-tests paren-tests
+  (cl-format nil "~(PLEASE SPEAK QUIETLY IN HERE~)") "please speak quietly in here"
+  (cl-format nil "~@(PLEASE SPEAK QUIETLY IN HERE~)") "Please speak quietly in here"
+  (cl-format nil "~@:(but this Is imporTant~)") "BUT THIS IS IMPORTANT"
+  (cl-format nil "~:(the greAt gatsby~)!") "The Great Gatsby!"
+  ;; Test cases from CLtL 18.3 - string-upcase, et al.
+  (cl-format nil "~@:(~A~)" "Dr. Livingstone, I presume?") "DR. LIVINGSTONE, I PRESUME?" 
+  (cl-format nil "~(~A~)" "Dr. Livingstone, I presume?") "dr. livingstone, i presume?" 
+  (cl-format nil "~:(~A~)" " hello ") " Hello " 
+  (cl-format nil "~:(~A~)" "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION") 
+  "Occluded Casements Forestall Inadvertent Defenestration" 
+  (cl-format nil "~:(~A~)" 'kludgy-hash-search) "Kludgy-Hash-Search" 
+  (cl-format nil "~:(~A~)" "DON'T!") "Don'T!"     ;not "Don't!" 
+  (cl-format nil "~:(~A~)" "pipe 13a, foo16c") "Pipe 13a, Foo16c"
+)
+
+(simple-tests square-bracket-tests
+  ;; Tests for format without modifiers
+  (cl-format nil "I ~[don't ~]have one~%" 0) "I don't have one\n"
+  (cl-format nil "I ~[don't ~]have one~%" 1) "I have one\n"
+  (cl-format nil "I ~[don't ~;do ~]have one~%" 0) "I don't have one\n"
+  (cl-format nil "I ~[don't ~;do ~]have one~%" 1) "I do have one\n"
+  (cl-format nil "I ~[don't ~;do ~]have one~%" 2) "I have one\n"
+  (cl-format nil "I ~[don't ~:;do ~]have one~%" 0) "I don't have one\n"
+  (cl-format nil "I ~[don't ~:;do ~]have one~%" 1) "I do have one\n"
+  (cl-format nil "I ~[don't ~:;do ~]have one~%" 2) "I do have one\n"
+  (cl-format nil "I ~[don't ~:;do ~]have one~%" 700) "I do have one\n"
+
+  ;; Tests for format with a colon 
+  (cl-format nil "I ~:[don't ~;do ~]have one~%" true) "I do have one\n"
+  (cl-format nil "I ~:[don't ~;do ~]have one~%" 700) "I do have one\n"
+  (cl-format nil "I ~:[don't ~;do ~]have one~%" '(a b)) "I do have one\n"
+  (cl-format nil "I ~:[don't ~;do ~]have one~%" nil) "I don't have one\n"
+  (cl-format nil "I ~:[don't ~;do ~]have one~%" false) "I don't have one\n"
+
+  ;; Tests for format with an at sign
+  (cl-format nil "We had ~D wins~@[ (out of ~D tries)~].~%" 15 nil) "We had 15 wins.\n"
+  (cl-format nil "We had ~D wins~@[ (out of ~D tries)~].~%" 15 17)
+  "We had 15 wins (out of 17 tries).\n"
+
+  ;; Format tests with directives
+  (cl-format nil "Max ~D: ~[Blue team ~D~;Red team ~D~:;No team ~A~].~%" 15, 0, 7)
+  "Max 15: Blue team 7.\n"
+  (cl-format nil "Max ~D: ~[Blue team ~D~;Red team ~D~:;No team ~A~].~%" 15, 1, 12)
+  "Max 15: Red team 12.\n"
+  (cl-format nil "Max ~D: ~[Blue team ~D~;Red team ~D~:;No team ~A~].~%" 
+             15, -1, "(system failure)")
+  "Max 15: No team (system failure).\n"
+
+  ;; Nested format tests
+  (cl-format nil "Max ~D: ~[Blue team ~D~:[~; (complete success)~]~;Red team ~D~:;No team ~].~%" 
+             15, 0, 7, true)
+  "Max 15: Blue team 7 (complete success).\n"
+  (cl-format nil "Max ~D: ~[Blue team ~D~:[~; (complete success)~]~;Red team ~D~:;No team ~].~%" 
+             15, 0, 7, false)
+  "Max 15: Blue team 7.\n"
+
+  ;; Test the selector as part of the argument
+  (cl-format nil "The answer is ~#[nothing~;~D~;~D out of ~D~:;something crazy~].")
+  "The answer is nothing."
+  (cl-format nil "The answer is ~#[nothing~;~D~;~D out of ~D~:;something crazy~]." 4)
+  "The answer is 4."
+  (cl-format nil "The answer is ~#[nothing~;~D~;~D out of ~D~:;something crazy~]." 7 22)
+  "The answer is 7 out of 22."
+  (cl-format nil "The answer is ~#[nothing~;~D~;~D out of ~D~:;something crazy~]." 1 2 3 4)
+  "The answer is something crazy."
+)
+
+(simple-tests curly-brace-plain-tests
+  ;; Iteration from sublist
+  (cl-format nil "Coordinates are~{ [~D,~D]~}~%" [ 0, 1, 1, 0, 3, 5, 2, 1 ])
+  "Coordinates are [0,1] [1,0] [3,5] [2,1]\n"
+
+  (cl-format nil "Coordinates are~2{ [~D,~D]~}~%" [ 0, 1, 1, 0, 3, 5, 2, 1 ])
+  "Coordinates are [0,1] [1,0]\n"
+
+  (cl-format nil "Coordinates are~{ ~#[none~;<~D>~:;[~D,~D]~]~}~%" [ ])
+  "Coordinates are\n"
+
+  (cl-format nil "Coordinates are~{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [ ])
+  "Coordinates are none\n"
+
+  (cl-format nil "Coordinates are~{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [2 3 1])
+  "Coordinates are [2,3] <1>\n"
+
+  (cl-format nil "Coordinates are~{~:}~%" "" [])
+  "Coordinates are\n"
+
+  (cl-format nil "Coordinates are~{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [2 3 1])
+  "Coordinates are [2,3] <1>\n"
+
+  (cl-format nil "Coordinates are~{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [ ])
+  "Coordinates are none\n"
+)
+
+
+(simple-tests curly-brace-colon-tests
+  ;; Iteration from list of sublists
+  (cl-format nil "Coordinates are~:{ [~D,~D]~}~%" [ [0, 1], [1, 0], [3, 5], [2, 1] ])
+  "Coordinates are [0,1] [1,0] [3,5] [2,1]\n"
+
+  (cl-format nil "Coordinates are~:{ [~D,~D]~}~%" [ [0, 1, 0], [1, 0, 12], [3, 5], [2, 1] ])
+  "Coordinates are [0,1] [1,0] [3,5] [2,1]\n"
+
+  (cl-format nil "Coordinates are~2:{ [~D,~D]~}~%" [ [0, 1], [1, 0], [3, 5], [2, 1] ])
+  "Coordinates are [0,1] [1,0]\n"
+
+  (cl-format nil "Coordinates are~:{ ~#[none~;<~D>~:;[~D,~D]~]~}~%" [ ])
+  "Coordinates are\n"
+
+  (cl-format nil "Coordinates are~:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [ ])
+  "Coordinates are none\n"
+
+  (cl-format nil "Coordinates are~:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [[2 3] [1]])
+  "Coordinates are [2,3] <1>\n"
+
+  (cl-format nil "Coordinates are~:{~:}~%" "" [])
+  "Coordinates are\n"
+
+  (cl-format nil "Coordinates are~:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [[2 3] [1]])
+  "Coordinates are [2,3] <1>\n"
+
+  (cl-format nil "Coordinates are~:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [ ])
+  "Coordinates are none\n"
+)
+
+(simple-tests curly-brace-at-tests
+  ;; Iteration from main list
+  (cl-format nil "Coordinates are~@{ [~D,~D]~}~%"  0, 1, 1, 0, 3, 5, 2, 1)
+  "Coordinates are [0,1] [1,0] [3,5] [2,1]\n"
+
+  (cl-format nil "Coordinates are~2@{ [~D,~D]~}~%" 0, 1, 1, 0, 3, 5, 2, 1)
+  "Coordinates are [0,1] [1,0]\n"
+
+  (cl-format nil "Coordinates are~@{ ~#[none~;<~D>~:;[~D,~D]~]~}~%")
+  "Coordinates are\n"
+
+  (cl-format nil "Coordinates are~@{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%")
+  "Coordinates are none\n"
+
+  (cl-format nil "Coordinates are~@{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" 2 3 1)
+  "Coordinates are [2,3] <1>\n"
+
+  (cl-format nil "Coordinates are~@{~:}~%" "")
+  "Coordinates are\n"
+
+  (cl-format nil "Coordinates are~@{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" 2 3 1)
+  "Coordinates are [2,3] <1>\n"
+
+  (cl-format nil "Coordinates are~@{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]")
+  "Coordinates are none\n"
+)
+
+(simple-tests curly-brace-colon-at-tests
+  ;; Iteration from sublists on the main arg list
+  (cl-format nil "Coordinates are~@:{ [~D,~D]~}~%"  [0, 1], [1, 0], [3, 5], [2, 1] )
+  "Coordinates are [0,1] [1,0] [3,5] [2,1]\n"
+
+  (cl-format nil "Coordinates are~@:{ [~D,~D]~}~%" [0, 1, 0], [1, 0, 12], [3, 5], [2, 1] )
+  "Coordinates are [0,1] [1,0] [3,5] [2,1]\n"
+
+  (cl-format nil "Coordinates are~2@:{ [~D,~D]~}~%" [0, 1], [1, 0], [3, 5], [2, 1])
+  "Coordinates are [0,1] [1,0]\n"
+
+  (cl-format nil "Coordinates are~@:{ ~#[none~;<~D>~:;[~D,~D]~]~}~%")
+  "Coordinates are\n"
+
+  (cl-format nil "Coordinates are~@:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%")
+  "Coordinates are none\n"
+
+  (cl-format nil "Coordinates are~@:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [2 3] [1])
+  "Coordinates are [2,3] <1>\n"
+
+  (cl-format nil "Coordinates are~@:{~:}~%" "")
+  "Coordinates are\n"
+
+  (cl-format nil "Coordinates are~@:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [2 3] [1])
+  "Coordinates are [2,3] <1>\n"
+
+  (cl-format nil "Coordinates are~@:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]")
+  "Coordinates are none\n"
+)
+
+;; TODO tests for ~^ in ~[ constructs and other brackets
+;; TODO test ~:^ generates an error when used improperly
+;; TODO test ~:^ works in ~@:{...~}
+(let [aseq '(a quick brown fox jumped over the lazy dog)
+      lseq (mapcat identity (for [x aseq] [x (.length (name x))]))]
+  (simple-tests up-tests
+    (cl-format nil "~{~a~^, ~}" aseq) "a, quick, brown, fox, jumped, over, the, lazy, dog"
+    (cl-format nil "~{~a~0^, ~}" aseq) "a"
+    (cl-format nil "~{~a~#,3^, ~}" aseq) "a, quick, brown, fox, jumped, over"
+    (cl-format nil "~{~a~v,3^, ~}" lseq) "a, quick, brown, fox"
+    (cl-format nil "~{~a~3,v,4^, ~}" lseq) "a, quick, brown, fox"
+))
+
+(simple-tests angle-bracket-tests
+  (cl-format nil "~<foo~;bar~;baz~>") "foobarbaz"
+  (cl-format nil "~20<foo~;bar~;baz~>") "foo      bar     baz"
+  (cl-format nil "~,,2<foo~;bar~;baz~>") "foo  bar  baz"
+  (cl-format nil "~20<~A~;~A~;~A~>" "foo" "bar" "baz") "foo      bar     baz"
+  (cl-format nil "~20:<~A~;~A~;~A~>" "foo" "bar" "baz") "    foo    bar   baz"
+  (cl-format nil "~20@<~A~;~A~;~A~>" "foo" "bar" "baz") "foo    bar    baz   "
+  (cl-format nil "~20@:<~A~;~A~;~A~>" "foo" "bar" "baz") "   foo   bar   baz  "
+  (cl-format nil "~10,,2<~A~;~A~;~A~>" "foo" "bar" "baz") "foo  bar  baz"
+  (cl-format nil "~10,10,2<~A~;~A~;~A~>" "foo" "bar" "baz") "foo      bar     baz"
+  (cl-format nil "~10,10<~A~;~A~;~A~>" "foo" "bar" "baz") "foo barbaz"
+  (cl-format nil "~20<~A~;~^~A~;~^~A~>" "foo" "bar" "baz") "foo      bar     baz"
+  (cl-format nil "~20<~A~;~^~A~;~^~A~>" "foo" "bar") "foo              bar"
+  (cl-format nil "~20@<~A~;~^~A~;~^~A~>" "foo") "foo                 "
+  (cl-format nil "~20:<~A~;~^~A~;~^~A~>" "foo") "                 foo"
+)
+
+(simple-tests angle-bracket-max-column-tests
+  (cl-format nil "~%;; ~{~<~%;; ~1,50:; ~A~>~}.~%" (into [] (.split "This function computes the circular thermodynamic coefficient of the thrombulator angle for use in determining the reaction distance" "\\s")))
+  "\n;;  This function computes the circular\n;;  thermodynamic coefficient of the thrombulator\n;;  angle for use in determining the reaction\n;;  distance.\n"
+(cl-format true "~%;; ~{~<~%;; ~:; ~A~>~}.~%" (into [] (.split "This function computes the circular thermodynamic coefficient of the thrombulator angle for use in determining the reaction distance." "\\s"))))
+
+(defn list-to-table [aseq column-width]
+  (let [stream (get-pretty-writer (java.io.StringWriter.))]
+    (binding [*out* stream]
+     (doseq [row aseq]
+       (doseq [col row]
+         (cl-format true "~4D~7,vT" col column-width))
+       (prn)))
+    (.flush stream)
+    (.toString (:base @@(:base @@stream)))))
+
+(simple-tests column-writer-test
+  (list-to-table (map #(vector % (* % %) (* % % %)) (range 1 21)) 8)
+  "   1      1       1    \n   2      4       8    \n   3      9      27    \n   4     16      64    \n   5     25     125    \n   6     36     216    \n   7     49     343    \n   8     64     512    \n   9     81     729    \n  10    100    1000    \n  11    121    1331    \n  12    144    1728    \n  13    169    2197    \n  14    196    2744    \n  15    225    3375    \n  16    256    4096    \n  17    289    4913    \n  18    324    5832    \n  19    361    6859    \n  20    400    8000    \n")
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The following tests are the various examples from the format
+;; documentation in Common Lisp, the Language, 2nd edition, Chapter 22.3
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn expt [base pow] (reduce * (repeat pow base)))
+
+(let [x 5, y "elephant", n 3]
+  (simple-tests cltl-intro-tests
+   (format nil "foo")  "foo" 
+   (format nil "The answer is ~D." x)  "The answer is 5." 
+   (format nil "The answer is ~3D." x)  "The answer is   5." 
+   (format nil "The answer is ~3,'0D." x)  "The answer is 005." 
+   (format nil "The answer is ~:D." (expt 47 x)) "The answer is 229,345,007."
+   (format nil "Look at the ~A!" y)  "Look at the elephant!" 
+   (format nil "Type ~:C to ~A." (char 4) "delete all your files") 
+   "Type Control-D to delete all your files."
+   (format nil "~D item~:P found." n)  "3 items found."
+   (format nil "~R dog~:[s are~; is~] here." n (= n 1)) "three dogs are here."
+   (format nil "~R dog~:*~[s are~; is~:;s are~] here." n) "three dogs are here."
+   (format nil "Here ~[are~;is~:;are~] ~:*~R pupp~:@P." n) "Here are three puppies."))
+ 
+(simple-tests cltl-B-tests
+  ;; CLtL didn't have the colons here, but the spec requires them
+  (format nil "~,,' ,4:B" 0xFACE) "1111 1010 1100 1110" 
+  (format nil "~,,' ,4:B" 0x1CE) "1 1100 1110" 
+  (format nil "~19,,' ,4:B" 0xFACE) "1111 1010 1100 1110" 
+  ;; This one was a nice idea, but nothing in the spec supports it working this way
+  ;; (and SBCL doesn't work this way either)
+  ;(format nil "~19,,' ,4:B" 0x1CE) "0000 0001 1100 1110")
+  )
+
+(simple-tests cltl-P-tests
+  (format nil "~D tr~:@P/~D win~:P" 7 1) "7 tries/1 win" 
+  (format nil "~D tr~:@P/~D win~:P" 1 0) "1 try/0 wins" 
+  (format nil "~D tr~:@P/~D win~:P" 1 3) "1 try/3 wins")
+
+(defn foo [x] 
+  (format nil "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F" 
+          x x x x x x))
+
+(simple-tests cltl-F-tests
+  (foo 3.14159)  "  3.14| 31.42|  3.14|3.1416|3.14|3.14159" 
+  (foo -3.14159) " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159" 
+  (foo 100.0)    "100.00|******|100.00| 100.0|100.00|100.0" 
+  (foo 1234.0)   "1234.00|******|??????|1234.0|1234.00|1234.0" 
+  (foo 0.006)    "  0.01|  0.06|  0.01| 0.006|0.01|0.006")
+
+(defn foo-e [x] 
+  (format nil 
+          "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~9,3,2,-2,'%@E|~9,2E" 
+          x x x x)) 
+
+;; Clojure doesn't support float/double differences in representation
+(simple-tests cltl-E-tests
+  (foo-e 0.0314159) "  3.14E-2| 31.42$-03|+.003E+01|  3.14E-2"  ; Added this one 
+  (foo-e 3.14159)  "  3.14E+0| 31.42$-01|+.003E+03|  3.14E+0" 
+  (foo-e -3.14159) " -3.14E+0|-31.42$-01|-.003E+03| -3.14E+0"
+  (foo-e 1100.0)   "  1.10E+3| 11.00$+02|+.001E+06|  1.10E+3" 
+; In Clojure, this is identical to the above
+;  (foo-e 1100.0L0) "  1.10L+3| 11.00$+02|+.001L+06|  1.10L+3" 
+  (foo-e 1.1E13)   "*********| 11.00$+12|+.001E+16| 1.10E+13" 
+  (foo-e 1.1E120)  "*********|??????????|%%%%%%%%%|1.10E+120" 
+; Clojure doesn't support real numbers this large
+;  (foo-e 1.1L1200) "*********|??????????|%%%%%%%%%|1.10L+1200"
+)
+
+(simple-tests cltl-E-scale-tests
+  (map
+    (fn [k] (format nil "Scale factor ~2D~:*: |~13,6,2,VE|" 
+                    (- k 5) 3.14159))              ;Prints 13 lines 
+    (range 13))
+  '("Scale factor -5: | 0.000003E+06|"
+    "Scale factor -4: | 0.000031E+05|"
+    "Scale factor -3: | 0.000314E+04|"
+    "Scale factor -2: | 0.003142E+03|"
+    "Scale factor -1: | 0.031416E+02|"
+    "Scale factor  0: | 0.314159E+01|"
+    "Scale factor  1: | 3.141590E+00|"
+    "Scale factor  2: | 31.41590E-01|"
+    "Scale factor  3: | 314.1590E-02|"
+    "Scale factor  4: | 3141.590E-03|"
+    "Scale factor  5: | 31415.90E-04|"
+    "Scale factor  6: | 314159.0E-05|"
+    "Scale factor  7: | 3141590.E-06|"))
+
+(defn foo-g [x] 
+  (format nil 
+          "~9,2,1,,'*G|~9,3,2,3,'?,,'$G|~9,3,2,0,'%G|~9,2G" 
+          x x x x)) 
+
+;; Clojure doesn't support float/double differences in representation
+(simple-tests cltl-G-tests
+  (foo-g 0.0314159) "  3.14E-2|314.2$-04|0.314E-01|  3.14E-2" 
+  (foo-g 0.314159)  "  0.31   |0.314    |0.314    | 0.31    " 
+  (foo-g 3.14159)   "   3.1   | 3.14    | 3.14    |  3.1    " 
+  (foo-g 31.4159)   "   31.   | 31.4    | 31.4    |  31.    " 
+  (foo-g 314.159)   "  3.14E+2| 314.    | 314.    |  3.14E+2" 
+  (foo-g 3141.59)   "  3.14E+3|314.2$+01|0.314E+04|  3.14E+3" 
+; In Clojure, this is identical to the above
+;  (foo-g 3141.59L0) "  3.14L+3|314.2$+01|0.314L+04|  3.14L+3" 
+  (foo-g 3.14E12)   "*********|314.0$+10|0.314E+13| 3.14E+12" 
+  (foo-g 3.14E120)  "*********|?????????|%%%%%%%%%|3.14E+120" 
+; Clojure doesn't support real numbers this large
+;  (foo-g 3.14L1200) "*********|?????????|%%%%%%%%%|3.14L+1200"
+)
+
+(defn type-clash-error [fun nargs argnum right-type wrong-type]
+  (format nil ;; CLtL has this format string slightly wrong
+          "~&Function ~S requires its ~:[~:R ~;~*~]~
+           argument to be of type ~S,~%but it was called ~
+           with an argument of type ~S.~%" 
+          fun (= nargs 1) argnum right-type wrong-type)) 
+
+(simple-tests cltl-Newline-tests
+  (type-clash-error 'aref nil 2 'integer 'vector)
+"Function aref requires its second argument to be of type integer,
+but it was called with an argument of type vector.\n"
+  (type-clash-error 'car 1 1 'list 'short-float)
+"Function car requires its argument to be of type list,
+but it was called with an argument of type short-float.\n")
+
+(simple-tests cltl-?-tests
+  (format nil "~? ~D" "<~A ~D>" '("Foo" 5) 7) "<Foo 5> 7" 
+  (format nil "~? ~D" "<~A ~D>" '("Foo" 5 14) 7) "<Foo 5> 7"
+  (format nil "~@? ~D" "<~A ~D>" "Foo" 5 7) "<Foo 5> 7" 
+  (format nil "~@? ~D" "<~A ~D>" "Foo" 5 14 7) "<Foo 5> 14")
+
+(defn f [n] (format nil "~@(~R~) error~:P detected." n)) 
+
+(simple-tests cltl-paren-tests
+  (format nil "~@R ~(~@R~)" 14 14) "XIV xiv" 
+  (f 0) "Zero errors detected." 
+  (f 1) "One error detected." 
+  (f 23) "Twenty-three errors detected.")
+
+(let [*print-level* nil *print-length* 5] 
+  (simple-tests cltl-bracket-tests
+    (format nil "~@[ print level = ~D~]~@[ print length = ~D~]" 
+            *print-level* *print-length*) 
+    " print length = 5"))
+
+(let [foo "Items:~#[ none~; ~S~; ~S and ~S~
+           ~:;~@{~#[~; and~] ~
+           ~S~^,~}~]."]
+  (simple-tests cltl-bracket1-tests
+    (format nil foo) "Items: none." 
+    (format nil foo 'foo) "Items: foo." 
+    (format nil foo 'foo 'bar) "Items: foo and bar." 
+    (format nil foo 'foo 'bar 'baz) "Items: foo, bar, and baz." 
+    (format nil foo 'foo 'bar 'baz 'quux) "Items: foo, bar, baz, and quux."))
+
+(simple-tests cltl-curly-bracket-tests
+  (format nil 
+        "The winners are:~{ ~S~}." 
+        '(fred harry jill)) 
+  "The winners are: fred harry jill." 
+
+  (format nil "Pairs:~{ <~S,~S>~}." '(a 1 b 2 c 3)) 
+  "Pairs: <a,1> <b,2> <c,3>."
+
+  (format nil "Pairs:~:{ <~S,~S>~}." '((a 1) (b 2) (c 3))) 
+  "Pairs: <a,1> <b,2> <c,3>."
+
+  (format nil "Pairs:~@{ <~S,~S>~}." 'a 1 'b 2 'c 3) 
+  "Pairs: <a,1> <b,2> <c,3>."
+
+  (format nil "Pairs:~:@{ <~S,~S>~}." '(a 1) '(b 2) '(c 3)) 
+  "Pairs: <a,1> <b,2> <c,3>.")
+
+(simple-tests cltl-angle-bracket-tests
+  (format nil "~10<foo~;bar~>")           "foo    bar" 
+  (format nil "~10:<foo~;bar~>")          "  foo  bar" 
+  (format nil "~10:@<foo~;bar~>")         "  foo bar " 
+  (format nil "~10<foobar~>")             "    foobar" 
+  (format nil "~10:<foobar~>")            "    foobar" 
+  (format nil "~10@<foobar~>")            "foobar    " 
+  (format nil "~10:@<foobar~>")           "  foobar  ")
+
+(let [donestr "Done.~^  ~D warning~:P.~^  ~D error~:P."
+      tellstr "~@{~@(~@[~R~^ ~]~A~)~}."] ;; The CLtL example is a little wrong here
+
+  (simple-tests cltl-up-tests
+    (format nil donestr) "Done." 
+    (format nil donestr 3) "Done.  3 warnings." 
+    (format nil donestr 1 5) "Done.  1 warning.  5 errors."
+    (format nil tellstr 23) "Twenty-three." 
+    (format nil tellstr nil "losers") "Losers." 
+    (format nil tellstr 23 "losers") "Twenty-three losers."
+    (format nil "~15<~S~;~^~S~;~^~S~>" 'foo) 
+    "            foo" 
+    (format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar) 
+    "foo         bar" 
+    (format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar 'baz) 
+    "foo   bar   baz"))
+
+(simple-tests cltl-up-x3j13-tests
+  (format nil 
+          "~:{/~S~^ ...~}" 
+          '((hot dog) (hamburger) (ice cream) (french fries))) 
+  "/hot .../hamburger/ice .../french ..."
+  (format nil 
+          "~:{/~S~:^ ...~}" 
+          '((hot dog) (hamburger) (ice cream) (french fries))) 
+  "/hot .../hamburger .../ice .../french"
+
+  (format nil 
+          "~:{/~S~#:^ ...~}"  ;; This is wrong in CLtL
+          '((hot dog) (hamburger) (ice cream) (french fries))) 
+  "/hot .../hamburger")
+
diff --git a/test/clojure/test_clojure/pprint/test_helper.clj b/test/clojure/test_clojure/pprint/test_helper.clj
new file mode 100644
index 00000000..3cc31506
--- /dev/null
+++ b/test/clojure/test_clojure/pprint/test_helper.clj
@@ -0,0 +1,22 @@
+;;; test_helper.clj -- part of the pretty printer for Clojure
+
+;   Copyright (c) Rich Hickey. 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.
+
+;; Author: Tom Faulhaber
+;; April 3, 2009
+
+
+;; This is just a macro to make my tests a little cleaner
+
+(ns clojure.test-clojure.pprint.test-helper
+  (:use [clojure.test :only (deftest are run-tests)]))
+
+(defmacro simple-tests [name & test-pairs]
+  `(deftest ~name (are [x y] (= x y) ~@test-pairs)))
+
diff --git a/test/clojure/test_clojure/pprint/test_pretty.clj b/test/clojure/test_clojure/pprint/test_pretty.clj
new file mode 100644
index 00000000..5615da44
--- /dev/null
+++ b/test/clojure/test_clojure/pprint/test_pretty.clj
@@ -0,0 +1,194 @@
+;;; test_pretty.clj -- part of the pretty printer for Clojure
+
+;   Copyright (c) Rich Hickey. 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.
+
+;; Author: Tom Faulhaber
+;; April 3, 2009
+
+
+(in-ns 'clojure.test-clojure.pprint)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Unit tests for the pretty printer
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(simple-tests xp-fill-test
+  (binding [*print-pprint-dispatch* simple-dispatch
+            *print-right-margin* 38
+            *print-miser-width* nil]
+    (cl-format nil "(let ~:<~@{~:<~w ~_~w~:>~^ ~:_~}~:>~_ ...)~%"
+               '((x 4) (*print-length* nil) (z 2) (list nil))))
+  "(let ((x 4) (*print-length* nil)\n      (z 2) (list nil))\n ...)\n"
+
+  (binding [*print-pprint-dispatch* simple-dispatch
+            *print-right-margin* 22]
+    (cl-format nil "(let ~:<~@{~:<~w ~_~w~:>~^ ~:_~}~:>~_ ...)~%"
+               '((x 4) (*print-length* nil) (z 2) (list nil))))
+  "(let ((x 4)\n      (*print-length*\n       nil)\n      (z 2)\n      (list nil))\n ...)\n")
+
+(simple-tests xp-miser-test
+  (binding [*print-pprint-dispatch* simple-dispatch
+            *print-right-margin* 10, *print-miser-width* 9]
+    (cl-format nil "~:<LIST ~@_~W ~@_~W ~@_~W~:>" '(first second third)))
+  "(LIST\n first\n second\n third)"
+
+  (binding [*print-pprint-dispatch* simple-dispatch
+            *print-right-margin* 10, *print-miser-width* 8]
+    (cl-format nil "~:<LIST ~@_~W ~@_~W ~@_~W~:>" '(first second third)))
+  "(LIST first second third)")
+
+(simple-tests mandatory-fill-test
+  (cl-format nil
+             "<pre>~%~<Usage: ~:I~@{*~a*~^~:@_~}~:>~%</pre>~%"
+             [ "hello" "gooodbye" ])
+  "<pre>
+Usage: *hello*
+       *gooodbye*
+</pre>
+")
+
+(simple-tests prefix-suffix-test
+  (binding [*print-pprint-dispatch* simple-dispatch
+            *print-right-margin* 10, *print-miser-width* 10]
+    (cl-format nil "~<{~;LIST ~@_~W ~@_~W ~@_~W~;}~:>" '(first second third)))
+  "{LIST\n first\n second\n third}")
+
+(simple-tests pprint-test
+  (binding [*print-pprint-dispatch* simple-dispatch]
+    (write '(defn foo [x y] 
+              (let [result (* x y)] 
+                (if (> result 400) 
+                  (cl-format true "That number is too big")
+                  (cl-format true "The  result of ~d x ~d is ~d" x y result))))
+           :stream nil))
+  "(defn
+ foo
+ [x y]
+ (let
+  [result (* x y)]
+  (if
+   (> result 400)
+   (cl-format true \"That number is too big\")
+   (cl-format true \"The  result of ~d x ~d is ~d\" x y result))))"
+
+  (with-pprint-dispatch code-dispatch
+    (write '(defn foo [x y] 
+              (let [result (* x y)] 
+                (if (> result 400) 
+                  (cl-format true "That number is too big")
+                  (cl-format true "The  result of ~d x ~d is ~d" x y result))))
+           :stream nil))
+  "(defn foo [x y]
+  (let [result (* x y)]
+    (if (> result 400)
+      (cl-format true \"That number is too big\")
+      (cl-format true \"The  result of ~d x ~d is ~d\" x y result))))"
+
+  (binding [*print-pprint-dispatch* simple-dispatch
+            *print-right-margin* 15] 
+    (write '(fn (cons (car x) (cdr y))) :stream nil))
+  "(fn\n (cons\n  (car x)\n  (cdr y)))"
+
+  (with-pprint-dispatch code-dispatch
+    (binding [*print-right-margin* 52] 
+      (write 
+       '(add-to-buffer this (make-buffer-blob (str (char c)) nil))
+       :stream nil)))
+  "(add-to-buffer\n  this\n  (make-buffer-blob (str (char c)) nil))"
+  )
+
+
+
+(simple-tests pprint-reader-macro-test
+  (with-pprint-dispatch code-dispatch
+    (write (read-string "(map #(first %) [[1 2 3] [4 5 6] [7]])")
+	   :stream nil))
+  "(map #(first %) [[1 2 3] [4 5 6] [7]])"
+
+  (with-pprint-dispatch code-dispatch
+    (write (read-string "@@(ref (ref 1))")
+	   :stream nil))
+  "@@(ref (ref 1))"
+
+  (with-pprint-dispatch code-dispatch
+    (write (read-string "'foo")
+	   :stream nil))
+  "'foo"
+)
+
+(simple-tests code-block-tests 
+ (with-out-str
+   (with-pprint-dispatch code-dispatch 
+     (pprint 
+      '(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))))))
+ "(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)))
+"
+
+ (with-out-str
+   (with-pprint-dispatch code-dispatch 
+     (pprint 
+      '(defn pprint-defn [writer alis]
+         (if (next alis) 
+           (let [[defn-sym defn-name & stuff] alis
+                 [doc-str stuff] (if (string? (first stuff))
+                                   [(first stuff) (next stuff)]
+                                   [nil stuff])
+                 [attr-map stuff] (if (map? (first stuff))
+                                    [(first stuff) (next stuff)]
+                                    [nil stuff])]
+             (pprint-logical-block writer :prefix "(" :suffix ")"
+                                   (cl-format true "~w ~1I~@_~w" defn-sym defn-name)
+                                   (if doc-str
+                                     (cl-format true " ~_~w" doc-str))
+                                   (if attr-map
+                                     (cl-format true " ~_~w" attr-map))
+                                   ;; Note: the multi-defn case will work OK for malformed defns too
+                                   (cond
+                                    (vector? (first stuff)) (single-defn stuff (or doc-str attr-map))
+                                    :else (multi-defn stuff (or doc-str attr-map)))))
+           (pprint-simple-code-list writer alis))))))
+ "(defn pprint-defn [writer alis]
+  (if (next alis)
+    (let [[defn-sym defn-name & stuff] alis
+          [doc-str stuff] (if (string? (first stuff))
+                            [(first stuff) (next stuff)]
+                            [nil stuff])
+          [attr-map stuff] (if (map? (first stuff))
+                             [(first stuff) (next stuff)]
+                             [nil stuff])]
+      (pprint-logical-block
+        writer
+        :prefix
+        \"(\"
+        :suffix
+        \")\"
+        (cl-format true \"~w ~1I~@_~w\" defn-sym defn-name)
+        (if doc-str (cl-format true \" ~_~w\" doc-str))
+        (if attr-map (cl-format true \" ~_~w\" attr-map))
+        (cond
+          (vector? (first stuff)) (single-defn
+                                    stuff
+                                    (or doc-str attr-map))
+          :else (multi-defn stuff (or doc-str attr-map)))))
+    (pprint-simple-code-list writer alis)))
+")