\f
;;;; routines to print objects
+\f
+;;; keyword variables shared by WRITE and WRITE-TO-STRING, and
+;;; the bindings they map to.
+(eval-when (:compile-toplevel :load-toplevel)
+ (defvar *printer-keyword-variables*
+ '(:escape *print-escape*
+ :radix *print-radix*
+ :base *print-base*
+ :circle *print-circle*
+ :pretty *print-pretty*
+ :level *print-level*
+ :length *print-length*
+ :case *print-case*
+ :array *print-array*
+ :gensym *print-gensym*
+ :readably *print-readably*
+ :right-margin *print-right-margin*
+ :miser-width *print-miser-width*
+ :lines *print-lines*
+ :pprint-dispatch *print-pprint-dispatch*)))
+
(defun write (object &key
((:stream stream) *standard-output*)
((:escape *print-escape*) *print-escape*)
(output-object object (out-synonym-of stream))
object)
+;;; Optimize common case of constant keyword arguments
+(define-compiler-macro write (&whole form object &rest keys)
+ (let (bind ignore)
+ (do ()
+ ((not (cdr keys))
+ ;; Odd number of keys, punt
+ (when keys
+ (return-from write form)))
+ (let* ((key (pop keys))
+ (value (pop keys))
+ (variable (or (getf *printer-keyword-variables* key)
+ (when (eq :stream key)
+ 'stream)
+ (return-from write form))))
+ (when (assoc variable bind)
+ ;; First key has precedence, but we still need to execute the
+ ;; argument, and in the right order.
+ (setf variable (gensym "IGNORE"))
+ (push variable ignore))
+ (push (list variable value) bind)))
+ (unless (assoc 'stream bind)
+ (push (list 'stream '*standard-output*) bind))
+ `(let ,(nreverse bind)
+ ,@(when ignore `((declare (ignore ,@ignore))))
+ (output-object ,object stream))))
+
(defun prin1 (object &optional stream)
#!+sb-doc
"Output a mostly READable printed representation of OBJECT on the specified
(values))
(defun write-to-string
- (object &key
- ((:escape *print-escape*) *print-escape*)
- ((:radix *print-radix*) *print-radix*)
- ((:base *print-base*) *print-base*)
- ((:circle *print-circle*) *print-circle*)
- ((:pretty *print-pretty*) *print-pretty*)
- ((:level *print-level*) *print-level*)
- ((:length *print-length*) *print-length*)
- ((:case *print-case*) *print-case*)
- ((:array *print-array*) *print-array*)
- ((:gensym *print-gensym*) *print-gensym*)
- ((:readably *print-readably*) *print-readably*)
- ((:right-margin *print-right-margin*) *print-right-margin*)
- ((:miser-width *print-miser-width*) *print-miser-width*)
- ((:lines *print-lines*) *print-lines*)
- ((:pprint-dispatch *print-pprint-dispatch*)
- *print-pprint-dispatch*))
+ (object &key
+ ((:escape *print-escape*) *print-escape*)
+ ((:radix *print-radix*) *print-radix*)
+ ((:base *print-base*) *print-base*)
+ ((:circle *print-circle*) *print-circle*)
+ ((:pretty *print-pretty*) *print-pretty*)
+ ((:level *print-level*) *print-level*)
+ ((:length *print-length*) *print-length*)
+ ((:case *print-case*) *print-case*)
+ ((:array *print-array*) *print-array*)
+ ((:gensym *print-gensym*) *print-gensym*)
+ ((:readably *print-readably*) *print-readably*)
+ ((:right-margin *print-right-margin*) *print-right-margin*)
+ ((:miser-width *print-miser-width*) *print-miser-width*)
+ ((:lines *print-lines*) *print-lines*)
+ ((:pprint-dispatch *print-pprint-dispatch*)
+ *print-pprint-dispatch*))
#!+sb-doc
"Return the printed representation of OBJECT as a string."
(stringify-object object))
+;;; Optimize common case of constant keyword arguments
+(define-compiler-macro write-to-string (&whole form object &rest keys)
+ (let (bind ignore)
+ (do ()
+ ((not (cdr keys))
+ ;; Odd number of keys, punt
+ (when keys
+ (return-from write-to-string form)))
+ (let* ((key (pop keys))
+ (value (pop keys))
+ (variable (or (getf *printer-keyword-variables* key)
+ (return-from write-to-string form))))
+ (when (assoc variable bind)
+ ;; First key has precedence, but we still need to execute the
+ ;; argument, and in the right order.
+ (setf variable (gensym "IGNORE"))
+ (push variable ignore))
+ (push (list variable value) bind)))
+ (if bind
+ `(let ,(nreverse bind)
+ ,@(when ignore `((declare (ignore ,@ignore))))
+ (stringify-object ,object))
+ `(stringify-object ,object))))
+
(defun prin1-to-string (object)
#!+sb-doc
"Return the printed representation of OBJECT as a string with
(output-float object stream))
(ratio
(output-ratio object stream))
- (ratio
- (output-ratio object stream))
(complex
(output-complex object stream))))
(character
;; this for now. [noted by anonymous long ago] -- WHN 19991130
`(or (char= ,char #\\)
(char= ,char #\"))))
- (with-array-data ((data string) (start) (end (length string)))
+ (with-array-data ((data string) (start) (end)
+ :check-fill-pointer t)
(do ((index start (1+ index)))
((>= index end))
(let ((char (schar data index)))
(2 #\b)
(8 #\o)
(16 #\x)
- (t (%output-fixnum-in-base base 10 stream)
+ (t (%output-reasonable-integer-in-base base 10 stream)
#\r))
stream))
-(defun %output-fixnum-in-base (n base stream)
+(defun %output-reasonable-integer-in-base (n base stream)
(multiple-value-bind (q r)
(truncate n base)
;; Recurse until you have all the digits pushed on
;; the stack.
(unless (zerop q)
- (%output-fixnum-in-base q base stream))
+ (%output-reasonable-integer-in-base q base stream))
;; Then as each recursive call unwinds, turn the
;; digit (in remainder) into a character and output
;; the character.
(schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r)
stream)))
+;;; *POWER-CACHE* is an alist mapping bases to power-vectors. It is
+;;; filled and probed by POWERS-FOR-BASE. SCRUB-POWER-CACHE is called
+;;; always prior a GC to drop overly large bignums from the cache.
+;;;
+;;; It doesn't need a lock, but if you work on SCRUB-POWER-CACHE or
+;;; POWERS-FOR-BASE, see that you don't break the assumptions!
+(defvar *power-cache* nil)
+
+(defconstant +power-cache-integer-length-limit+ 2048)
+
+(defun scrub-power-cache ()
+ (let ((cache *power-cache*))
+ (dolist (cell cache)
+ (let ((powers (cdr cell)))
+ (declare (simple-vector powers))
+ (let ((too-big (position-if
+ (lambda (x)
+ (>= (integer-length x)
+ +power-cache-integer-length-limit+))
+ powers)))
+ (when too-big
+ (setf (cdr cell) (subseq powers 0 too-big))))))
+ ;; Since base 10 is overwhelmingly common, make sure it's at head.
+ ;; Try to keep other bases in a hopefully sensible order as well.
+ (if (eql 10 (caar cache))
+ (setf *power-cache* cache)
+ ;; If we modify the list destructively we need to copy it, otherwise
+ ;; an alist lookup in progress might be screwed.
+ (setf *power-cache* (sort (copy-list cache)
+ (lambda (a b)
+ (declare (fixnum a b))
+ (cond ((= 10 a) t)
+ ((= 10 b) nil)
+ ((= 16 a) t)
+ ((= 16 b) nil)
+ ((= 2 a) t)
+ ((= 2 b) nil)
+ (t (< a b))))
+ :key #'car)))))
+
+;;; Compute (and cache) a power vector for a BASE and LIMIT:
+;;; the vector holds integers for which
+;;; (aref powers k) == (expt base (expt 2 k))
+;;; holds.
+(defun powers-for-base (base limit)
+ (flet ((compute-powers (from)
+ (let (powers)
+ (do ((p from (* p p)))
+ ((> p limit)
+ ;; We don't actually need this, but we also
+ ;; prefer not to cons it up a second time...
+ (push p powers))
+ (push p powers))
+ (nreverse powers))))
+ ;; Grab a local reference so that we won't stuff consed at the
+ ;; head by other threads -- or sorting by SCRUB-POWER-CACHE.
+ (let ((cache *power-cache*))
+ (let ((cell (assoc base cache)))
+ (if cell
+ (let* ((powers (cdr cell))
+ (len (length powers))
+ (max (svref powers (1- len))))
+ (if (> max limit)
+ powers
+ (let ((new
+ (concatenate 'vector powers
+ (compute-powers (* max max)))))
+ (setf (cdr cell) new)
+ new)))
+ (let ((powers (coerce (compute-powers base) 'vector)))
+ ;; Add new base to head: SCRUB-POWER-CACHE will later
+ ;; put it to a better place.
+ (setf *power-cache* (acons base powers cache))
+ powers))))))
+
;; Algorithm by Harald Hanche-Olsen, sbcl-devel 2005-02-05
-(defun %output-bignum-in-base (n base stream)
+(defun %output-huge-integer-in-base (n base stream)
(declare (type bignum n) (type fixnum base))
- (let ((power (make-array 10 :adjustable t :fill-pointer 0)))
- ;; Here there be the bottleneck for big bignums, in the (* p p).
- ;; A special purpose SQUARE-BIGNUM might help a bit. See eg: Dan
- ;; Zuras, "On Squaring and Multiplying Large Integers", ARITH-11:
- ;; IEEE Symposium on Computer Arithmetic, 1993, pp. 260 to 271.
- ;; Reprinted as "More on Multiplying and Squaring Large Integers",
- ;; IEEE Transactions on Computers, volume 43, number 8, August
- ;; 1994, pp. 899-908.
- (do ((p base (* p p)))
- ((> p n))
- (vector-push-extend p power))
- ;; (aref power k) == (expt base (expt 2 k))
+ ;; POWER is a vector for which the following holds:
+ ;; (aref power k) == (expt base (expt 2 k))
+ (let* ((power (powers-for-base base n))
+ (k-start (or (position-if (lambda (x) (> x n)) power)
+ (bug "power-vector too short"))))
(labels ((bisect (n k exactp)
(declare (fixnum k))
;; N is the number to bisect
;; doesn't get any leading zeros.
(bisect q k exactp)
(bisect r k (or exactp (plusp q))))))))
- (bisect n (fill-pointer power) nil))))
+ (bisect n k-start nil))))
(defun %output-integer-in-base (integer base stream)
(when (minusp integer)
(write-char #\- stream)
(setf integer (- integer)))
- (if (fixnump integer)
- (%output-fixnum-in-base integer base stream)
- (%output-bignum-in-base integer base stream)))
+ ;; The ideal cutoff point between these two algorithms is almost
+ ;; certainly quite platform dependent: this gives 87 for 32 bit
+ ;; SBCL, which is about right at least for x86/Darwin.
+ (if (or (fixnump integer)
+ (< (integer-length integer) (* 3 sb!vm:n-positive-fixnum-bits)))
+ (%output-reasonable-integer-in-base integer base stream)
+ (%output-huge-integer-in-base integer base stream)))
(defun output-integer (integer stream)
(let ((base *print-base*))