1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/pprint/dispatch.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,467 @@
     1.4 +;; dispatch.clj -- part of the pretty printer for Clojure
     1.5 +
     1.6 +;   Copyright (c) Rich Hickey. All rights reserved.
     1.7 +;   The use and distribution terms for this software are covered by the
     1.8 +;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
     1.9 +;   which can be found in the file epl-v10.html at the root of this distribution.
    1.10 +;   By using this software in any fashion, you are agreeing to be bound by
    1.11 +;   the terms of this license.
    1.12 +;   You must not remove this notice, or any other, from this software.
    1.13 +
    1.14 +;; Author: Tom Faulhaber
    1.15 +;; April 3, 2009
    1.16 +
    1.17 +
    1.18 +;; This module implements the default dispatch tables for pretty printing code and
    1.19 +;; data.
    1.20 +
    1.21 +(in-ns 'clojure.pprint)
    1.22 +
    1.23 +(defn- use-method
    1.24 +  "Installs a function as a new method of multimethod associated with dispatch-value. "
    1.25 +  [multifn dispatch-val func]
    1.26 +  (. multifn addMethod dispatch-val func))
    1.27 +
    1.28 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.29 +;; Implementations of specific dispatch table entries
    1.30 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.31 +
    1.32 +;;; Handle forms that can be "back-translated" to reader macros
    1.33 +;;; Not all reader macros can be dealt with this way or at all. 
    1.34 +;;; Macros that we can't deal with at all are:
    1.35 +;;; ;  - The comment character is aborbed by the reader and never is part of the form
    1.36 +;;; `  - Is fully processed at read time into a lisp expression (which will contain concats
    1.37 +;;;      and regular quotes).
    1.38 +;;; ~@ - Also fully eaten by the processing of ` and can't be used outside.
    1.39 +;;; ,  - is whitespace and is lost (like all other whitespace). Formats can generate commas
    1.40 +;;;      where they deem them useful to help readability.
    1.41 +;;; ^  - Adding metadata completely disappears at read time and the data appears to be
    1.42 +;;;      completely lost.
    1.43 +;;;
    1.44 +;;; Most other syntax stuff is dealt with directly by the formats (like (), [], {}, and #{})
    1.45 +;;; or directly by printing the objects using Clojure's built-in print functions (like
    1.46 +;;; :keyword, \char, or ""). The notable exception is #() which is special-cased.
    1.47 +
    1.48 +(def ^{:private true} reader-macros
    1.49 +     {'quote "'", 'clojure.core/deref "@", 
    1.50 +      'var "#'", 'clojure.core/unquote "~"})
    1.51 +
    1.52 +(defn- pprint-reader-macro [alis]
    1.53 +  (let [^String macro-char (reader-macros (first alis))]
    1.54 +    (when (and macro-char (= 2 (count alis)))
    1.55 +      (.write ^java.io.Writer *out* macro-char)
    1.56 +      (write-out (second alis))
    1.57 +      true)))
    1.58 +
    1.59 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.60 +;; Dispatch for the basic data types when interpreted
    1.61 +;; as data (as opposed to code).
    1.62 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.63 +
    1.64 +;;; TODO: inline these formatter statements into funcs so that we
    1.65 +;;; are a little easier on the stack. (Or, do "real" compilation, a
    1.66 +;;; la Common Lisp)
    1.67 +
    1.68 +;;; (def pprint-simple-list (formatter-out "~:<~@{~w~^ ~_~}~:>"))
    1.69 +(defn- pprint-simple-list [alis]
    1.70 +  (pprint-logical-block :prefix "(" :suffix ")"
    1.71 +    (loop [alis (seq alis)]
    1.72 +      (when alis
    1.73 +	(write-out (first alis))
    1.74 +	(when (next alis)
    1.75 +	  (.write ^java.io.Writer *out* " ")
    1.76 +	  (pprint-newline :linear)
    1.77 +	  (recur (next alis)))))))
    1.78 +
    1.79 +(defn- pprint-list [alis]
    1.80 +  (if-not (pprint-reader-macro alis)
    1.81 +    (pprint-simple-list alis)))
    1.82 +
    1.83 +;;; (def pprint-vector (formatter-out "~<[~;~@{~w~^ ~_~}~;]~:>"))
    1.84 +(defn- pprint-vector [avec]
    1.85 +  (pprint-logical-block :prefix "[" :suffix "]"
    1.86 +    (loop [aseq (seq avec)]
    1.87 +      (when aseq
    1.88 +	(write-out (first aseq))
    1.89 +	(when (next aseq)
    1.90 +	  (.write ^java.io.Writer *out* " ")
    1.91 +	  (pprint-newline :linear)
    1.92 +	  (recur (next aseq)))))))
    1.93 +
    1.94 +(def ^{:private true} pprint-array (formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>"))
    1.95 +
    1.96 +;;; (def pprint-map (formatter-out "~<{~;~@{~<~w~^ ~_~w~:>~^, ~_~}~;}~:>"))
    1.97 +(defn- pprint-map [amap]
    1.98 +  (pprint-logical-block :prefix "{" :suffix "}"
    1.99 +    (loop [aseq (seq amap)]
   1.100 +      (when aseq
   1.101 +	(pprint-logical-block 
   1.102 +          (write-out (ffirst aseq))
   1.103 +          (.write ^java.io.Writer *out* " ")
   1.104 +          (pprint-newline :linear)
   1.105 +          (write-out (fnext (first aseq))))
   1.106 +        (when (next aseq)
   1.107 +          (.write ^java.io.Writer *out* ", ")
   1.108 +          (pprint-newline :linear)
   1.109 +          (recur (next aseq)))))))
   1.110 +
   1.111 +(def ^{:private true} pprint-set (formatter-out "~<#{~;~@{~w~^ ~:_~}~;}~:>"))
   1.112 +
   1.113 +;;; TODO: don't block on promise (currently impossible)
   1.114 +
   1.115 +(def ^{:private true} 
   1.116 +     type-map {"core$future_call" "Future",
   1.117 +               "core$promise" "Promise"})
   1.118 +
   1.119 +(defn- map-ref-type 
   1.120 +  "Map ugly type names to something simpler"
   1.121 +  [name]
   1.122 +  (or (when-let [match (re-find #"^[^$]+\$[^$]+" name)]
   1.123 +        (type-map match))
   1.124 +      name))
   1.125 +
   1.126 +(defn- pprint-ideref [o]
   1.127 +  (let [prefix (format "#<%s@%x%s: "
   1.128 +                       (map-ref-type (.getSimpleName (class o)))
   1.129 +                       (System/identityHashCode o)
   1.130 +                       (if (and (instance? clojure.lang.Agent o)
   1.131 +                                (agent-error o))
   1.132 +                         " FAILED"
   1.133 +                         ""))]
   1.134 +    (pprint-logical-block  :prefix prefix :suffix ">"
   1.135 +                           (pprint-indent :block (-> (count prefix) (- 2) -))
   1.136 +                           (pprint-newline :linear)
   1.137 +                           (write-out (cond 
   1.138 +                                       (and (future? o) (not (future-done? o))) :pending
   1.139 +                                       :else @o)))))
   1.140 +
   1.141 +(def ^{:private true} pprint-pqueue (formatter-out "~<<-(~;~@{~w~^ ~_~}~;)-<~:>"))
   1.142 +
   1.143 +(defn- pprint-simple-default [obj]
   1.144 +  (cond 
   1.145 +    (.isArray (class obj)) (pprint-array obj)
   1.146 +    (and *print-suppress-namespaces* (symbol? obj)) (print (name obj))
   1.147 +    :else (pr obj)))
   1.148 +
   1.149 +
   1.150 +(defmulti 
   1.151 +  simple-dispatch
   1.152 +  "The pretty print dispatch function for simple data structure format."
   1.153 +  {:added "1.2" :arglists '[[object]]} 
   1.154 +  class)
   1.155 +
   1.156 +(use-method simple-dispatch clojure.lang.ISeq pprint-list)
   1.157 +(use-method simple-dispatch clojure.lang.IPersistentVector pprint-vector)
   1.158 +(use-method simple-dispatch clojure.lang.IPersistentMap pprint-map)
   1.159 +(use-method simple-dispatch clojure.lang.IPersistentSet pprint-set)
   1.160 +(use-method simple-dispatch clojure.lang.PersistentQueue pprint-pqueue)
   1.161 +(use-method simple-dispatch clojure.lang.IDeref pprint-ideref)
   1.162 +(use-method simple-dispatch nil pr)
   1.163 +(use-method simple-dispatch :default pprint-simple-default)
   1.164 +
   1.165 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.166 +;;; Dispatch for the code table
   1.167 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.168 +
   1.169 +(declare pprint-simple-code-list)
   1.170 +
   1.171 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.172 +;;; Format something that looks like a simple def (sans metadata, since the reader
   1.173 +;;; won't give it to us now).
   1.174 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.175 +
   1.176 +(def ^{:private true} pprint-hold-first (formatter-out "~:<~w~^ ~@_~w~^ ~_~@{~w~^ ~_~}~:>"))
   1.177 +
   1.178 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.179 +;;; Format something that looks like a defn or defmacro
   1.180 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.181 +
   1.182 +;;; Format the params and body of a defn with a single arity
   1.183 +(defn- single-defn [alis has-doc-str?]
   1.184 +  (if (seq alis)
   1.185 +    (do
   1.186 +      (if has-doc-str?
   1.187 +        ((formatter-out " ~_"))
   1.188 +        ((formatter-out " ~@_")))
   1.189 +      ((formatter-out "~{~w~^ ~_~}") alis))))
   1.190 +
   1.191 +;;; Format the param and body sublists of a defn with multiple arities
   1.192 +(defn- multi-defn [alis has-doc-str?]
   1.193 +  (if (seq alis)
   1.194 +    ((formatter-out " ~_~{~w~^ ~_~}") alis)))
   1.195 +
   1.196 +;;; TODO: figure out how to support capturing metadata in defns (we might need a 
   1.197 +;;; special reader)
   1.198 +(defn- pprint-defn [alis]
   1.199 +  (if (next alis) 
   1.200 +    (let [[defn-sym defn-name & stuff] alis
   1.201 +          [doc-str stuff] (if (string? (first stuff))
   1.202 +                            [(first stuff) (next stuff)]
   1.203 +                            [nil stuff])
   1.204 +          [attr-map stuff] (if (map? (first stuff))
   1.205 +                             [(first stuff) (next stuff)]
   1.206 +                             [nil stuff])]
   1.207 +      (pprint-logical-block :prefix "(" :suffix ")"
   1.208 +        ((formatter-out "~w ~1I~@_~w") defn-sym defn-name)
   1.209 +        (if doc-str
   1.210 +          ((formatter-out " ~_~w") doc-str))
   1.211 +        (if attr-map
   1.212 +          ((formatter-out " ~_~w") attr-map))
   1.213 +        ;; Note: the multi-defn case will work OK for malformed defns too
   1.214 +        (cond
   1.215 +         (vector? (first stuff)) (single-defn stuff (or doc-str attr-map))
   1.216 +         :else (multi-defn stuff (or doc-str attr-map)))))
   1.217 +    (pprint-simple-code-list alis)))
   1.218 +
   1.219 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.220 +;;; Format something with a binding form
   1.221 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.222 +
   1.223 +(defn- pprint-binding-form [binding-vec]
   1.224 +  (pprint-logical-block :prefix "[" :suffix "]"
   1.225 +    (loop [binding binding-vec]
   1.226 +      (when (seq binding)
   1.227 +        (pprint-logical-block binding
   1.228 +          (write-out (first binding))
   1.229 +          (when (next binding)
   1.230 +            (.write ^java.io.Writer *out* " ")
   1.231 +            (pprint-newline :miser)
   1.232 +            (write-out (second binding))))
   1.233 +        (when (next (rest binding))
   1.234 +          (.write ^java.io.Writer *out* " ")
   1.235 +          (pprint-newline :linear)
   1.236 +          (recur (next (rest binding))))))))
   1.237 +
   1.238 +(defn- pprint-let [alis]
   1.239 +  (let [base-sym (first alis)]
   1.240 +    (pprint-logical-block :prefix "(" :suffix ")"
   1.241 +      (if (and (next alis) (vector? (second alis)))
   1.242 +        (do
   1.243 +          ((formatter-out "~w ~1I~@_") base-sym)
   1.244 +          (pprint-binding-form (second alis))
   1.245 +          ((formatter-out " ~_~{~w~^ ~_~}") (next (rest alis))))
   1.246 +        (pprint-simple-code-list alis)))))
   1.247 +
   1.248 +
   1.249 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.250 +;;; Format something that looks like "if"
   1.251 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.252 +
   1.253 +(def ^{:private true} pprint-if (formatter-out "~:<~1I~w~^ ~@_~w~@{ ~_~w~}~:>"))
   1.254 +
   1.255 +(defn- pprint-cond [alis]
   1.256 +  (pprint-logical-block :prefix "(" :suffix ")"
   1.257 +    (pprint-indent :block 1)
   1.258 +    (write-out (first alis))
   1.259 +    (when (next alis)
   1.260 +      (.write ^java.io.Writer *out* " ")
   1.261 +      (pprint-newline :linear)
   1.262 +     (loop [alis (next alis)]
   1.263 +       (when alis
   1.264 +         (pprint-logical-block alis
   1.265 +          (write-out (first alis))
   1.266 +          (when (next alis)
   1.267 +            (.write ^java.io.Writer *out* " ")
   1.268 +            (pprint-newline :miser)
   1.269 +            (write-out (second alis))))
   1.270 +         (when (next (rest alis))
   1.271 +           (.write ^java.io.Writer *out* " ")
   1.272 +           (pprint-newline :linear)
   1.273 +           (recur (next (rest alis)))))))))
   1.274 +
   1.275 +(defn- pprint-condp [alis]
   1.276 +  (if (> (count alis) 3) 
   1.277 +    (pprint-logical-block :prefix "(" :suffix ")"
   1.278 +      (pprint-indent :block 1)
   1.279 +      (apply (formatter-out "~w ~@_~w ~@_~w ~_") alis)
   1.280 +      (loop [alis (seq (drop 3 alis))]
   1.281 +        (when alis
   1.282 +          (pprint-logical-block alis
   1.283 +            (write-out (first alis))
   1.284 +            (when (next alis)
   1.285 +              (.write ^java.io.Writer *out* " ")
   1.286 +              (pprint-newline :miser)
   1.287 +              (write-out (second alis))))
   1.288 +          (when (next (rest alis))
   1.289 +            (.write ^java.io.Writer *out* " ")
   1.290 +            (pprint-newline :linear)
   1.291 +            (recur (next (rest alis)))))))
   1.292 +    (pprint-simple-code-list alis)))
   1.293 +
   1.294 +;;; The map of symbols that are defined in an enclosing #() anonymous function
   1.295 +(def ^{:private true} *symbol-map* {})
   1.296 +
   1.297 +(defn- pprint-anon-func [alis]
   1.298 +  (let [args (second alis)
   1.299 +        nlis (first (rest (rest alis)))]
   1.300 +    (if (vector? args)
   1.301 +      (binding [*symbol-map* (if (= 1 (count args)) 
   1.302 +                               {(first args) "%"}
   1.303 +                               (into {} 
   1.304 +                                     (map 
   1.305 +                                      #(vector %1 (str \% %2)) 
   1.306 +                                      args 
   1.307 +                                      (range 1 (inc (count args))))))]
   1.308 +        ((formatter-out "~<#(~;~@{~w~^ ~_~}~;)~:>") nlis))
   1.309 +      (pprint-simple-code-list alis))))
   1.310 +
   1.311 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.312 +;;; The master definitions for formatting lists in code (that is, (fn args...) or
   1.313 +;;; special forms).
   1.314 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.315 +
   1.316 +;;; This is the equivalent of (formatter-out "~:<~1I~@{~w~^ ~_~}~:>"), but is
   1.317 +;;; easier on the stack.
   1.318 +
   1.319 +(defn- pprint-simple-code-list [alis]
   1.320 +  (pprint-logical-block :prefix "(" :suffix ")"
   1.321 +    (pprint-indent :block 1)
   1.322 +    (loop [alis (seq alis)]
   1.323 +      (when alis
   1.324 +	(write-out (first alis))
   1.325 +	(when (next alis)
   1.326 +	  (.write ^java.io.Writer *out* " ")
   1.327 +	  (pprint-newline :linear)
   1.328 +	  (recur (next alis)))))))
   1.329 +
   1.330 +;;; Take a map with symbols as keys and add versions with no namespace.
   1.331 +;;; That is, if ns/sym->val is in the map, add sym->val to the result.
   1.332 +(defn- two-forms [amap]
   1.333 +  (into {} 
   1.334 +        (mapcat 
   1.335 +         identity 
   1.336 +         (for [x amap] 
   1.337 +           [x [(symbol (name (first x))) (second x)]]))))
   1.338 +
   1.339 +(defn- add-core-ns [amap]
   1.340 +  (let [core "clojure.core"]
   1.341 +    (into {}
   1.342 +          (map #(let [[s f] %] 
   1.343 +                  (if (not (or (namespace s) (special-symbol? s)))
   1.344 +                    [(symbol core (name s)) f]
   1.345 +                    %))
   1.346 +               amap))))
   1.347 +
   1.348 +(def ^{:private true} *code-table*
   1.349 +     (two-forms
   1.350 +      (add-core-ns
   1.351 +       {'def pprint-hold-first, 'defonce pprint-hold-first, 
   1.352 +	'defn pprint-defn, 'defn- pprint-defn, 'defmacro pprint-defn, 'fn pprint-defn,
   1.353 +        'let pprint-let, 'loop pprint-let, 'binding pprint-let,
   1.354 +        'with-local-vars pprint-let, 'with-open pprint-let, 'when-let pprint-let,
   1.355 +	'if-let pprint-let, 'doseq pprint-let, 'dotimes pprint-let,
   1.356 +	'when-first pprint-let,
   1.357 +        'if pprint-if, 'if-not pprint-if, 'when pprint-if, 'when-not pprint-if,
   1.358 +        'cond pprint-cond, 'condp pprint-condp,
   1.359 +        'fn* pprint-anon-func,
   1.360 +        '. pprint-hold-first, '.. pprint-hold-first, '-> pprint-hold-first,
   1.361 +        'locking pprint-hold-first, 'struct pprint-hold-first,
   1.362 +        'struct-map pprint-hold-first, 
   1.363 +        })))
   1.364 +
   1.365 +(defn- pprint-code-list [alis]
   1.366 +  (if-not (pprint-reader-macro alis) 
   1.367 +    (if-let [special-form (*code-table* (first alis))]
   1.368 +      (special-form alis)
   1.369 +      (pprint-simple-code-list alis))))
   1.370 +
   1.371 +(defn- pprint-code-symbol [sym] 
   1.372 +  (if-let [arg-num (sym *symbol-map*)]
   1.373 +    (print arg-num)
   1.374 +    (if *print-suppress-namespaces* 
   1.375 +      (print (name sym))
   1.376 +      (pr sym))))
   1.377 +
   1.378 +(defmulti 
   1.379 +  code-dispatch
   1.380 +  "The pretty print dispatch function for pretty printing Clojure code."
   1.381 +  {:added "1.2" :arglists '[[object]]} 
   1.382 +  class)
   1.383 +
   1.384 +(use-method code-dispatch clojure.lang.ISeq pprint-code-list)
   1.385 +(use-method code-dispatch clojure.lang.Symbol pprint-code-symbol)
   1.386 +
   1.387 +;; The following are all exact copies of simple-dispatch
   1.388 +(use-method code-dispatch clojure.lang.IPersistentVector pprint-vector)
   1.389 +(use-method code-dispatch clojure.lang.IPersistentMap pprint-map)
   1.390 +(use-method code-dispatch clojure.lang.IPersistentSet pprint-set)
   1.391 +(use-method code-dispatch clojure.lang.PersistentQueue pprint-pqueue)
   1.392 +(use-method code-dispatch clojure.lang.IDeref pprint-ideref)
   1.393 +(use-method code-dispatch nil pr)
   1.394 +(use-method code-dispatch :default pprint-simple-default)
   1.395 +
   1.396 +(set-pprint-dispatch simple-dispatch)
   1.397 +
   1.398 +
   1.399 +;;; For testing
   1.400 +(comment
   1.401 +
   1.402 +(with-pprint-dispatch code-dispatch 
   1.403 +  (pprint 
   1.404 +   '(defn cl-format 
   1.405 +      "An implementation of a Common Lisp compatible format function"
   1.406 +      [stream format-in & args]
   1.407 +      (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)
   1.408 +            navigator (init-navigator args)]
   1.409 +        (execute-format stream compiled-format navigator)))))
   1.410 +
   1.411 +(with-pprint-dispatch code-dispatch 
   1.412 +  (pprint 
   1.413 +   '(defn cl-format 
   1.414 +      [stream format-in & args]
   1.415 +      (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)
   1.416 +            navigator (init-navigator args)]
   1.417 +        (execute-format stream compiled-format navigator)))))
   1.418 +
   1.419 +(with-pprint-dispatch code-dispatch 
   1.420 +  (pprint
   1.421 +   '(defn- -write 
   1.422 +      ([this x]
   1.423 +         (condp = (class x)
   1.424 +           String 
   1.425 +           (let [s0 (write-initial-lines this x)
   1.426 +                 s (.replaceFirst s0 "\\s+$" "")
   1.427 +                 white-space (.substring s0 (count s))
   1.428 +                 mode (getf :mode)]
   1.429 +             (if (= mode :writing)
   1.430 +               (dosync
   1.431 +                (write-white-space this)
   1.432 +                (.col_write this s)
   1.433 +                (setf :trailing-white-space white-space))
   1.434 +               (add-to-buffer this (make-buffer-blob s white-space))))
   1.435 +
   1.436 +           Integer
   1.437 +           (let [c ^Character x]
   1.438 +             (if (= (getf :mode) :writing)
   1.439 +               (do 
   1.440 +                 (write-white-space this)
   1.441 +                 (.col_write this x))
   1.442 +               (if (= c (int \newline))
   1.443 +                 (write-initial-lines this "\n")
   1.444 +                 (add-to-buffer this (make-buffer-blob (str (char c)) nil))))))))))
   1.445 +
   1.446 +(with-pprint-dispatch code-dispatch 
   1.447 +  (pprint 
   1.448 +   '(defn pprint-defn [writer alis]
   1.449 +      (if (next alis) 
   1.450 +        (let [[defn-sym defn-name & stuff] alis
   1.451 +              [doc-str stuff] (if (string? (first stuff))
   1.452 +                                [(first stuff) (next stuff)]
   1.453 +                                [nil stuff])
   1.454 +              [attr-map stuff] (if (map? (first stuff))
   1.455 +                                 [(first stuff) (next stuff)]
   1.456 +                                 [nil stuff])]
   1.457 +          (pprint-logical-block writer :prefix "(" :suffix ")"
   1.458 +                                (cl-format true "~w ~1I~@_~w" defn-sym defn-name)
   1.459 +                                (if doc-str
   1.460 +                                  (cl-format true " ~_~w" doc-str))
   1.461 +                                (if attr-map
   1.462 +                                  (cl-format true " ~_~w" attr-map))
   1.463 +                                ;; Note: the multi-defn case will work OK for malformed defns too
   1.464 +                                (cond
   1.465 +                                  (vector? (first stuff)) (single-defn stuff (or doc-str attr-map))
   1.466 +                                  :else (multi-defn stuff (or doc-str attr-map)))))
   1.467 +        (pprint-simple-code-list writer alis)))))
   1.468 +)
   1.469 +nil
   1.470 +