New multimethod-based dispatch system. Made a path all the way through

that assumes that you have a pretty writer bound to *out* so we don't
have to rebind it everywhere.

3 files changed, 270 insertions, 260 deletions

diff --git a/src/clojure/contrib/pprint/cl-format.clj b/src/clojure/contrib/pprint/cl-format.clj
index d2a57f82..293741a2 100644
--- a/src/clojure/contrib/pprint/cl-format.clj
+++ b/src/clojure/contrib/pprint/cl-format.clj
@@ -1170,7 +1170,7 @@ N.B. Only works on ColumnWriters right now."
                 (> clause-count 2) (:string (:params (first (nth clauses 2))))
                 (:colon params) ")")
         [arg navigator] (next-arg navigator)]
-    (pprint-logical-block *out* :prefix prefix :suffix suffix
+    (pprint-logical-block :prefix prefix :suffix suffix
       (execute-sub-format 
        body 
        (init-navigator arg)
@@ -1251,12 +1251,12 @@ N.B. Only works on ColumnWriters right now."
     :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))))
+     (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
    [ ]
@@ -1272,9 +1272,9 @@ N.B. Only works on ColumnWriters right now."
    [:char-format [nil Character]]
    #{ :at :colon :both } {}
    (cond
-    (:colon params) pretty-character
-    (:at params) readable-character
-    :else plain-character))
+     (:colon params) pretty-character
+     (:at params) readable-character
+     :else plain-character))
 
   (\F
    [ :w [nil Integer] :d [nil Integer] :k [0 Integer] :overflowchar [nil Character] 
@@ -1364,10 +1364,10 @@ N.B. Only works on ColumnWriters right now."
    [ ] 
    #{ :at } {}
    (if (:at params)
-     (fn [params navigator offsets]        ; args from main arg list
+     (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
+     (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)]
@@ -1379,17 +1379,17 @@ N.B. Only works on ColumnWriters right now."
    [ ]
    #{ :colon :at :both} { :right \), :allows-separator nil, :else nil }
    (let [mod-case-writer (cond
-                          (and (:at params) (:colon params))
-                          upcase-writer
+                           (and (:at params) (:colon params))
+                           upcase-writer
 
-                          (:colon params)
-                          capitalize-word-writer
+                           (:colon params)
+                           capitalize-word-writer
 
-                          (:at params)
-                          init-cap-writer
+                           (:at params)
+                           init-cap-writer
 
-                          :else
-                          downcase-writer)]
+                           :else
+                           downcase-writer)]
      #(modify-case mod-case-writer %1 %2 %3)))
 
   (\) [] #{} {} nil) 
@@ -1398,14 +1398,14 @@ N.B. Only works on ColumnWriters right now."
    [ :selector [nil Integer] ]
    #{ :colon :at } { :right \], :allows-separator true, :else :last }
    (cond
-    (:colon params)
-    boolean-conditional
+     (:colon params)
+     boolean-conditional
 
-    (:at params)
-    check-arg-conditional
+     (:at params)
+     check-arg-conditional
 
-    true
-    choice-conditional))
+     true
+     choice-conditional))
 
   (\; [:min-remaining [nil Integer] :max-columns [nil Integer]] 
    #{ :colon } { :separator true } nil) 
@@ -1416,17 +1416,17 @@ N.B. Only works on ColumnWriters right now."
    [ :max-iterations [nil Integer] ]
    #{ :colon :at :both} { :right \}, :allows-separator false }
    (cond
-    (and (:at params) (:colon params))
-    iterate-main-sublists
+     (and (:at params) (:colon params))
+     iterate-main-sublists
 
-    (:colon params)
-    iterate-list-of-sublists
+     (:colon params)
+     iterate-list-of-sublists
 
-    (:at params)
-    iterate-main-list
+     (:at params)
+     iterate-main-list
 
-    true
-    iterate-sublist))
+     true
+     iterate-sublist))
 
    
   (\} [] #{:colon} {} nil) 
@@ -1447,30 +1447,36 @@ N.B. Only works on ColumnWriters right now."
            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 arg3)
+         (if (<= arg1 arg2 arg3) [exit navigator] navigator)
 
-        (and arg1 arg2)
-        (if (= arg1 arg2) [exit navigator] navigator)
+         (and arg1 arg2)
+         (if (= arg1 arg2) [exit navigator] navigator)
 
-        arg1
-        (if (= arg1 0) [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))))) 
+         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} {}
-   (let [bindings (concat
-                   (if (:at params) [:level nil :length nil] [])
-                   (if (:colon params) [:pretty true] []))]
+   (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 (apply write arg bindings)
+         (if (write-out arg)
            [:up-arrow navigator]
            navigator)))))
 
@@ -1486,7 +1492,7 @@ N.B. Only works on ColumnWriters right now."
   )
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Code to manage the parameters and flags accociated with each
+;;; Code to manage the parameters and flags associated with each
 ;;; directive in the format string.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -1751,34 +1757,36 @@ column number or pretty printing"
 
 (defn execute-format 
   "Executes the format with the arguments. This should never be used directly, but is public
-because the formtter macro uses it."
+because the formatter macro uses it."
   {: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 (instance? PrettyWriter real-stream)))
-                                          (pretty-writer real-stream)
-                                          real-stream)]
-    (binding [*out* wrapped-stream]
-      (try
-       (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)
-       (finally
-        (if-not (identical? real-stream wrapped-stream)
-          (.flush wrapped-stream))))
-      (if (not stream) (.toString real-stream)))))
+  ([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 (instance? PrettyWriter real-stream)))
+                                             (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)))
 
 
 (defmacro formatter
@@ -1795,3 +1803,19 @@ format-in can be either a control string or a previously compiled format."
            (fn [stream# & args#]
              (let [navigator# (init-navigator args#)]
                (execute-format 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."
+  [format-in]
+  (let [cf (gensym "compiled-format")]
+    `(let [format-in# ~format-in]
+       (do (defonce test-format# format-in#)
+           (defonce ~cf (if (string? format-in#) (compile-format format-in#) format-in#))
+           (fn [& args#]
+             (let [navigator# (init-navigator args#)]
+               (execute-format ~cf navigator#)))))))
diff --git a/src/clojure/contrib/pprint/dispatch.clj b/src/clojure/contrib/pprint/dispatch.clj
index ebd0fdb6..c27db51d 100644
--- a/src/clojure/contrib/pprint/dispatch.clj
+++ b/src/clojure/contrib/pprint/dispatch.clj
@@ -16,13 +16,15 @@
 
 (in-ns 'clojure.contrib.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
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(def *simple-dispatch* (ref []))
-(def *code-dispatch* (ref []))
-
 ;;; 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:
@@ -31,7 +33,7 @@
 ;;;      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 to help readability.
+;;;      where they deem them useful to help readability.
 ;;; #^ - Adding metadata completely disappears at read time and the data appears to be
 ;;;      completely lost.
 ;;;
@@ -42,13 +44,12 @@
 (def reader-macros
      {'quote "'", 'clojure.core/meta "^", 'clojure.core/deref "@", 
       'var "#'", 'clojure.core/unquote "~"})
-(defn pprint-reader-macro [#^java.io.Writer writer alis]
+(defn pprint-reader-macro [alis]
   (let [#^String macro-char (reader-macros (first alis))]
-    (if (and macro-char (= 2 (count alis)))
-      (do
-        (.write writer macro-char)
-        (write (second alis) :stream writer)
-        true))))
+    (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
@@ -59,41 +60,46 @@
 ;;; are a little easier on the stack. (Or, do "real" compilation, a
 ;;; la Common Lisp)
 
-(def pprint-simple-list (formatter "~:<~@{~w~^ ~_~}~:>"))
-(defn pprint-list [writer alis]
-  (if-not (pprint-reader-macro writer alis)
-    (pprint-simple-list writer alis)))
-(dosync (alter *simple-dispatch* conj [list? pprint-list]))
-(dosync (alter *simple-dispatch* conj [#(instance? clojure.lang.Cons %) pprint-list]))
-(dosync (alter *simple-dispatch* conj [#(instance? clojure.lang.LazySeq %) pprint-list]))
-(dosync (alter *simple-dispatch* conj [#(instance? clojure.lang.ArraySeq %) pprint-list]))
-
-(def pprint-vector (formatter "~<[~;~@{~w~^ ~_~}~;]~:>"))
-(dosync (alter *simple-dispatch* conj [vector? pprint-vector]))
-
-(def pprint-array (formatter "~<[~;~@{~w~^, ~:_~}~;]~:>"))
-(dosync (alter *simple-dispatch* conj [#(and % (.isArray (class %))) pprint-array]))
-
-(def pprint-map (formatter "~<{~;~@{~<~w~^ ~_~w~:>~^, ~_~}~;}~:>"))
-(dosync (alter *simple-dispatch* conj [map? pprint-map]))
-
-(def pprint-set (formatter "~<#{~;~@{~w~^ ~:_~}~;}~:>"))
-(dosync (alter *simple-dispatch* conj [set? pprint-set]))
-
-(defn pprint-ref [writer ref]
-  (pprint-logical-block writer :prefix "#<Ref " :suffix ">"
-    (write @ref)))
-(dosync (alter *simple-dispatch* conj [#(instance? clojure.lang.Ref %) pprint-ref]))
-
-(defn pprint-atom [writer ref]
-  (pprint-logical-block writer :prefix "#<Atom " :suffix ">"
-    (write @ref)))
-(dosync (alter *simple-dispatch* conj [#(instance? clojure.lang.Atom %) pprint-atom]))
-
-(defn pprint-agent [writer ref]
-  (pprint-logical-block writer :prefix "#<Agent " :suffix ">"
-    (write @ref :stream writer)))
-(dosync (alter *simple-dispatch* conj [#(instance? clojure.lang.Agent %) pprint-agent]))
+(def pprint-simple-list (formatter-out "~:<~@{~w~^ ~_~}~:>"))
+(defn pprint-list [alis]
+  (if-not (pprint-reader-macro alis)
+    (pprint-simple-list alis)))
+(def pprint-vector (formatter-out "~<[~;~@{~w~^ ~_~}~;]~:>"))
+(def pprint-array (formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>"))
+(def pprint-map (formatter-out "~<{~;~@{~<~w~^ ~_~w~:>~^, ~_~}~;}~:>"))
+(def 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."
+  {: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
@@ -101,21 +107,12 @@
 
 (declare pprint-simple-code-list)
 
-(dosync (alter *code-dispatch* conj [vector? pprint-vector]))
-(dosync (alter *code-dispatch* conj [#(and % (.isArray (class %))) pprint-array]))
-(dosync (alter *code-dispatch* conj [map? pprint-map]))
-(dosync (alter *code-dispatch* conj [set? pprint-set]))
-(dosync (alter *code-dispatch* conj [#(instance? clojure.lang.Ref %) pprint-ref]))
-(dosync (alter *code-dispatch* conj [#(instance? clojure.lang.Atom %) pprint-atom]))
-(dosync (alter *code-dispatch* conj [#(instance? clojure.lang.Agent %) pprint-agent]))
-
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Format something that looks like a simple def (sans metadata, since the reader
 ;;; won't give it to us now).
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(def pprint-hold-first (formatter "~:<~w~^ ~@_~w~^ ~_~@{~w~^ ~_~}~:>"))
+(def pprint-hold-first (formatter-out "~:<~w~^ ~@_~w~^ ~_~@{~w~^ ~_~}~:>"))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Format something that looks like a defn or defmacro
@@ -126,18 +123,18 @@
   (if (seq alis)
     (do
       (if has-doc-str?
-        ((formatter " ~_") true)
-        ((formatter " ~@_") true))
-      ((formatter "~{~w~^ ~_~}") true alis))))
+        ((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 " ~_~{~w~^ ~_~}") true alis)))
+    ((formatter-out " ~_~{~w~^ ~_~}") alis)))
 
 ;;; TODO: figure out how to support capturing metadata in defns (we might need a 
 ;;; special reader)
-(defn pprint-defn [writer alis]
+(defn pprint-defn [alis]
   (if (next alis) 
     (let [[defn-sym defn-name & stuff] alis
           [doc-str stuff] (if (string? (first stuff))
@@ -146,97 +143,97 @@
           [attr-map stuff] (if (map? (first stuff))
                              [(first stuff) (next stuff)]
                              [nil stuff])]
-      (pprint-logical-block writer :prefix "(" :suffix ")"
-        ((formatter "~w ~1I~@_~w") true defn-sym defn-name)
+      (pprint-logical-block :prefix "(" :suffix ")"
+        ((formatter-out "~w ~1I~@_~w") defn-sym defn-name)
         (if doc-str
-          ((formatter " ~_~w") true doc-str))
+          ((formatter-out " ~_~w") doc-str))
         (if attr-map
-          ((formatter " ~_~w") true 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 writer alis)))
+    (pprint-simple-code-list alis)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Format something with a binding form
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defn pprint-binding-form [writer binding-vec]
-  (pprint-logical-block writer :prefix "[" :suffix "]"
+(defn pprint-binding-form [binding-vec]
+  (pprint-logical-block :prefix "[" :suffix "]"
     (loop [binding binding-vec]
       (when (seq binding)
-        (pprint-logical-block *out* binding
-          (write (first binding))
+        (pprint-logical-block binding
+          (write-out (first binding))
           (when (next binding)
-            (.write *out* " ")
+            (.write #^java.io.Writer *out* " ")
             (pprint-newline :miser)
-            (write (second binding))))
+            (write-out (second binding))))
         (when (next (rest binding))
-          (.write *out* " ")
+          (.write #^java.io.Writer *out* " ")
           (pprint-newline :linear)
           (recur (next (rest binding))))))))
 
-(defn pprint-let [writer alis]
+(defn pprint-let [alis]
   (let [base-sym (first alis)]
-    (pprint-logical-block writer :prefix "(" :suffix ")"
+    (pprint-logical-block :prefix "(" :suffix ")"
       (if (and (next alis) (vector? (second alis)))
         (do
-          ((formatter "~w ~1I~@_") true base-sym)
-          (pprint-binding-form *out* (second alis))
-          ((formatter " ~_~{~w~^ ~_~}") true (next (rest alis))))
-        (pprint-simple-code-list *out* alis)))))
+          ((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 pprint-if (formatter "~:<~1I~w~^ ~@_~w~@{ ~_~w~}~:>"))
+(def pprint-if (formatter-out "~:<~1I~w~^ ~@_~w~@{ ~_~w~}~:>"))
 
-(defn pprint-cond [writer alis]
-  (pprint-logical-block writer :prefix "(" :suffix ")"
+(defn pprint-cond [alis]
+  (pprint-logical-block :prefix "(" :suffix ")"
     (pprint-indent :block 1)
-    (write (first alis))
+    (write-out (first alis))
     (when (next alis)
-      (.write *out* " ")
+      (.write #^java.io.Writer *out* " ")
       (pprint-newline :linear)
      (loop [alis (next alis)]
        (when alis
-         (pprint-logical-block *out* alis
-          (write (first alis))
+         (pprint-logical-block alis
+          (write-out (first alis))
           (when (next alis)
-            (.write *out* " ")
+            (.write #^java.io.Writer *out* " ")
             (pprint-newline :miser)
-            (write (second alis))))
+            (write-out (second alis))))
          (when (next (rest alis))
-           (.write *out* " ")
+           (.write #^java.io.Writer *out* " ")
            (pprint-newline :linear)
            (recur (next (rest alis)))))))))
 
-(defn pprint-condp [writer alis]
+(defn pprint-condp [alis]
   (if (> (count alis) 3) 
-    (pprint-logical-block writer :prefix "(" :suffix ")"
+    (pprint-logical-block :prefix "(" :suffix ")"
       (pprint-indent :block 1)
-      (apply (formatter "~w ~@_~w ~@_~w ~_") true alis)
+      (apply (formatter-out "~w ~@_~w ~@_~w ~_") alis)
       (loop [alis (seq (drop 3 alis))]
         (when alis
-          (pprint-logical-block *out* alis
-            (write (first alis))
+          (pprint-logical-block alis
+            (write-out (first alis))
             (when (next alis)
-              (.write *out* " ")
+              (.write #^java.io.Writer *out* " ")
               (pprint-newline :miser)
-              (write (second alis))))
+              (write-out (second alis))))
           (when (next (rest alis))
-            (.write *out* " ")
+            (.write #^java.io.Writer *out* " ")
             (pprint-newline :linear)
             (recur (next (rest alis)))))))
-    (pprint-simple-code-list writer alis)))
+    (pprint-simple-code-list alis)))
 
 ;;; The map of symbols that are defined in an enclosing #() anonymous function
 (def *symbol-map* {})
 
-(defn pprint-anon-func [writer alis]
+(defn pprint-anon-func [alis]
   (let [args (second alis)
         nlis (first (rest (rest alis)))]
     (if (vector? args)
@@ -247,25 +244,25 @@
                                       #(vector %1 (str \% %2)) 
                                       args 
                                       (range 1 (inc (count args))))))]
-        ((formatter "~<#(~;~@{~w~^ ~_~}~;)~:>") writer nlis))
-      (pprint-simple-code-list writer alis))))
+        ((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 "~:<~1I~@{~w~^ ~_~}~:>"), but is
+;;; This is the equivalent of (formatter-out "~:<~1I~@{~w~^ ~_~}~:>"), but is
 ;;; easier on the stack.
 
-(defn pprint-simple-code-list [writer alis]
-  (pprint-logical-block writer :prefix "(" :suffix ")"
+(defn pprint-simple-code-list [alis]
+  (pprint-logical-block :prefix "(" :suffix ")"
     (pprint-indent :block 1)
     (loop [alis (seq alis)]
       (when alis
-	(write (first alis))
+	(write-out (first alis))
 	(when (next alis)
-	  (.write *out* " ")
+	  (.write #^java.io.Writer *out* " ")
 	  (pprint-newline :linear)
 	  (recur (next alis)))))))
 
@@ -304,24 +301,37 @@
         'struct-map pprint-hold-first, 
         })))
 
-(defn pprint-code-list [writer alis]
-  (if-not (pprint-reader-macro writer alis) 
+(defn pprint-code-list [alis]
+  (if-not (pprint-reader-macro alis) 
     (if-let [special-form (*code-table* (first alis))]
-      (special-form writer alis)
-      (pprint-simple-code-list writer alis))))
-
-(dosync (alter *code-dispatch* conj [list? pprint-code-list]))
-(dosync (alter *code-dispatch* conj [#(instance? clojure.lang.Cons %) pprint-code-list]))
-(dosync (alter *code-dispatch* conj [#(instance? clojure.lang.LazySeq %) pprint-code-list]))
-(dosync (alter *code-dispatch* conj [#(instance? clojure.lang.ArraySeq %) pprint-code-list]))
+      (special-form alis)
+      (pprint-simple-code-list alis))))
 
-(defn pprint-code-symbol [writer sym] 
+(defn pprint-code-symbol [sym] 
   (if-let [arg-num (sym *symbol-map*)]
     (print arg-num)
     (if *print-suppress-namespaces* 
       (print (name sym))
       (pr sym))))
-(dosync (alter *code-dispatch* conj [symbol? pprint-code-symbol]))
+
+(defmulti 
+  *code-dispatch*
+  "The pretty print dispatch function for pretty printing Clojure code."
+  {: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*)
 
diff --git a/src/clojure/contrib/pprint/pprint_base.clj b/src/clojure/contrib/pprint/pprint_base.clj
index ecabe204..eb876e4f 100644
--- a/src/clojure/contrib/pprint/pprint_base.clj
+++ b/src/clojure/contrib/pprint/pprint_base.clj
@@ -30,10 +30,10 @@
  #^{ :doc "Bind to true if you want write to use pretty printing"}
  *print-pretty* true)
 
-;;; TODO: implement true data-driven dispatch
 (defonce ; If folks have added stuff here, don't overwrite
- #^{ :doc "The pretty print dispatch table"}
- *print-pprint-dispatch* (ref []))
+ #^{ :doc "The pretty print dispatch function. Use with-pprint-dispatch or set-pprint-dispatch
+to modify."}
+ *print-pprint-dispatch* nil)
 
 (def
  #^{ :doc "Pretty printing will try to avoid anything going beyond this column."}
@@ -150,17 +150,9 @@ Normal library clients should use the standard \"write\" interface. "
       (pr object)
       (if length-reached
         (print "...")
-        ;; TODO better/faster dispatch mechanism!
         (do
           (if *current-length* (set! *current-length* (inc *current-length*)))
-          (loop [dispatch @*print-pprint-dispatch*]
-            (let [[test func] (first dispatch)]
-              (cond
-                (empty? dispatch) (if (and *print-suppress-namespaces* (symbol? object))
-                                    (print (name object))
-                                    (pr object))
-                (test object) (func *out* object)
-                :else (recur (next dispatch))))))))
+          (*print-pprint-dispatch* object))))
     length-reached))
 
 (defn write 
@@ -209,7 +201,8 @@ print the object to the currently bound value of *out*."
   ([object] (pprint object *out*)) 
   ([object writer]
      (with-pretty-writer writer
-       (write object :pretty true)
+       (binding [*print-pretty* true]
+         (write-out object))
        (if (not (= 0 (.getColumn #^PrettyWriter *out*)))
          (.write *out* (int \newline))))))
 
@@ -219,16 +212,20 @@ exactly equivalent to (pprint *1)."
   [] `(pprint *1))
 
 (defn set-pprint-dispatch  
-  "Set the pretty print dispatch table to TABLE. Currently the supported values are
-*simple-dispatch* or *code-dispatch*. In the future, this will support custom tables."
-  [table]
-  (dosync (ref-set *print-pprint-dispatch* @table))
+  "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.contrib.pprint.dispatch.clj."
+  [function]
+  (def *print-pprint-dispatch* function)
   nil)
 
 (defmacro with-pprint-dispatch 
-  "Execute body with the pretty print dispatch table bound to table."
-  [table & body]
-  `(binding [*print-pprint-dispatch* ~table]
+  "Execute body with the pretty print dispatch function bound to function."
+  [function & body]
+  `(binding [*print-pprint-dispatch* ~function]
      ~@body))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -251,39 +248,32 @@ exactly equivalent to (pprint *1)."
 
 (defmacro pprint-logical-block 
   "Execute the body as a pretty printing logical block with output to *out* which 
-is a pretty printing writer wrapping base-stream (unless base-stream is already a pretty 
-printing writer in which case *out* is just bound to base-stream). 
-
-After the writer, the caller can optionally specify :prefix, :per-line-prefix, and
-:suffix."
-  [base-stream & body]
-  (let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} body)]
-    `(with-pretty-writer ~base-stream
-       (if (and *print-level* (>= *current-level* *print-level*)) 
-         (.write #^PrettyWriter *out* "#")
-         (binding [*current-level* (inc *current-level*)
-                   *current-length* 0] 
-           (.startBlock #^PrettyWriter *out*
-                        ~(:prefix options) ~(:per-line-prefix options) ~(:suffix options))
-           ~@body
-           (.endBlock #^PrettyWriter *out*)))
-       nil)))
+must be a pretty printing writer. When used from pprint or cl-format, this can be 
+assumed. 
+
+Before the body, the caller can optionally specify options: :prefix, :per-line-prefix, 
+and :suffix."
+  {:arglists '[[options* body]]}
+  [& args]
+  (let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} args)]
+    `(do (if (and *print-level* (>= *current-level* *print-level*)) 
+           (.write #^PrettyWriter *out* "#")
+           (binding [*current-level* (inc *current-level*)
+                     *current-length* 0] 
+             (.startBlock #^PrettyWriter *out*
+                          ~(:prefix options) ~(:per-line-prefix options) ~(:suffix options))
+             ~@body
+             (.endBlock #^PrettyWriter *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. 
 
-Optionally, a second argument which is a stream may be used. If supplied, that is 
-the writer to which the newline is sent, otherwise *out* is used.
-
-If the requested stream is not a PrettyWriter, this function does nothing."
-  [kind & more] 
+Output is sent to *out* which must be a pretty printing writer."
+  [kind] 
   (check-enumerated-arg kind #{:linear :miser :fill :mandatory})
-  (let [stream (if (pos? (count more))
-                 (first more)
-                 *out*)]
-    (if (instance? PrettyWriter stream)
-      (.newline #^PrettyWriter stream kind))))
+  (.newline #^PrettyWriter *out* kind))
 
 (defn pprint-indent 
   "Create an indent at this point in the pretty printing stream. This defines how 
@@ -291,17 +281,10 @@ following lines are indented. relative-to can be either :block or :current depen
 whether the indent should be computed relative to the start of the logical block or
 the current column position. n is an offset. 
 
-Optionally, a third argument which is a stream may be used. If supplied, that is 
-the writer indented, otherwise *out* is used.
-
-If the requested stream is not a PrettyWriter, this function does nothing."
-  [relative-to n & more] 
+Output is sent to *out* which must be a pretty printing writer."
+  [relative-to n] 
   (check-enumerated-arg relative-to #{:block :current})
-  (let [stream (if (pos? (count more))
-                 (first more)
-                 *out*)]
-    (if (instance? PrettyWriter stream)
-      (.indent #^PrettyWriter stream relative-to n))))
+  (.indent #^PrettyWriter *out* relative-to n))
 
 ;; TODO a real implementation for pprint-tab
 (defn pprint-tab 
@@ -311,19 +294,12 @@ 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.
 
-Optionally, a fourth argument which is a stream may be used. If supplied, that is 
-the writer indented, otherwise *out* is used.
-
-If the requested stream is not a PrettyWriter, this function does nothing.
+Output is sent to *out* which must be a pretty printing writer.
 
 THIS FUNCTION IS NOT YET IMPLEMENTED."
-  [kind colnum colinc & more] 
+  [kind colnum colinc] 
   (check-enumerated-arg kind #{:line :section :line-relative :section-relative})
-  (let [stream (if (pos? (count more))
-                 (first more)
-                 *out*)]
-    (if (instance? PrettyWriter stream)
-      (throw (UnsupportedOperationException. "pprint-tab is not yet implemented")))))
+  (throw (UnsupportedOperationException. "pprint-tab is not yet implemented")))
 
 
 nil