Support for *print-base* and *print-radix* in cl-format, pprint and write.

3 files changed, 91 insertions, 19 deletions

diff --git a/src/clojure/contrib/pprint/cl-format.clj b/src/clojure/contrib/pprint/cl-format.clj
index de547e43..64fc4f30 100644
--- a/src/clojure/contrib/pprint/cl-format.clj
+++ b/src/clojure/contrib/pprint/cl-format.clj
@@ -158,9 +158,29 @@ http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm
 ;;; Common handling code for ~A and ~S
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(declare *print-base* *print-radix*)
+(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 (print-func arg)
+         #^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)) 
diff --git a/src/clojure/contrib/pprint/pprint_base.clj b/src/clojure/contrib/pprint/pprint_base.clj
index 3c5c7375..eec1326d 100644
--- a/src/clojure/contrib/pprint/pprint_base.clj
+++ b/src/clojure/contrib/pprint/pprint_base.clj
@@ -67,6 +67,20 @@ levels of nesting."}
 pretty printing the results of macro expansions"}
  *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* "}
+ *print-radix* nil)
+
+(def
+ #^{ :doc "The base to use for printing integers and rationals."}
+ *print-base* 10)
+
+
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Internal variables that keep track of where we are in the 
 ;; structure
@@ -82,9 +96,18 @@ pretty printing the results of macro expansions"}
 ;; 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             *print-base*,
+      :base             'clojure.contrib.pprint/*print-base*,
       ;;:case             *print-case*,
       :circle           'clojure.contrib.pprint/*print-circle*,
       ;;:escape           *print-escape*,
@@ -95,7 +118,7 @@ pretty printing the results of macro expansions"}
       :miser-width      'clojure.contrib.pprint/*print-miser-width*,
       :dispatch         'clojure.contrib.pprint/*print-pprint-dispatch*,
       :pretty           'clojure.contrib.pprint/*print-pretty*,
-      ;;:radix            *print-radix*,
+      :radix            'clojure.contrib.pprint/*print-radix*,
       :readably         'clojure.core/*print-readably*,
       :right-margin     'clojure.contrib.pprint/*print-right-margin*,
       :suppress-namespaces 'clojure.contrib.pprint/*print-suppress-namespaces*})
@@ -133,6 +156,8 @@ pretty printing the results of macro expansions"}
        ~@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 
@@ -166,6 +191,7 @@ 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*
@@ -173,6 +199,7 @@ The following keyword arguments can be passed with values:
   :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*
@@ -182,20 +209,21 @@ The following keyword arguments can be passed with values:
   [object & kw-args]
   (let [options (merge {:stream true} (apply hash-map kw-args))]
     (binding-map (table-ize write-option-table options) 
-      (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))))))
+      (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 
@@ -205,7 +233,8 @@ print the object to the currently bound value of *out*."
   ([object writer]
      (with-pretty-writer writer
        (binding [*print-pretty* true]
-         (write-out object))
+         (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {}) 
+           (write-out object)))
        (if (not (= 0 (.getColumn #^PrettyWriter *out*)))
          (.write *out* (int \newline))))))
 
diff --git a/src/clojure/contrib/test_contrib/pprint/cl_format.clj b/src/clojure/contrib/test_contrib/pprint/cl_format.clj
index 2ddaff76..81d64c78 100644
--- a/src/clojure/contrib/test_contrib/pprint/cl_format.clj
+++ b/src/clojure/contrib/test_contrib/pprint/cl_format.clj
@@ -35,7 +35,30 @@
 
 (simple-tests base-tests
   (cl-format nil "~{~2r~^ ~}~%" (range 10))
-  "0 1 10 11 100 101 110 111 1000 1001\n")
+  "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"