aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/clojure/contrib/pprint/cl-format.clj22
-rw-r--r--src/clojure/contrib/pprint/pprint_base.clj63
-rw-r--r--src/clojure/contrib/test_contrib/pprint/cl_format.clj25
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"
generated by cgit v1.2.3-18-g5258 (git 2.32.0) at 2025-04-25 07:33:53 +0000