+(defun %output-radix (base stream)
+ (write-char #\# stream)
+ (write-char (case base
+ (2 #\b)
+ (8 #\o)
+ (16 #\x)
+ (t (%output-reasonable-integer-in-base base 10 stream)
+ #\r))
+ 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-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.
+ (write-char
+ (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-huge-integer-in-base (n base stream)
+ (declare (type bignum n) (type fixnum base))
+ ;; 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
+ ;; K on initial entry BASE^(2^K) > N
+ ;; EXACTP is true if 2^K is the exact number of digits
+ (cond ((zerop n)
+ (when exactp
+ (loop repeat (ash 1 k) do (write-char #\0 stream))))
+ ((zerop k)
+ (write-char
+ (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" n)
+ stream))
+ (t
+ (setf k (1- k))
+ (multiple-value-bind (q r) (truncate n (aref power k))
+ ;; EXACTP is NIL only at the head of the
+ ;; initial number, as we don't know the number
+ ;; of digits there, but we do know that it
+ ;; doesn't get any leading zeros.
+ (bisect q k exactp)
+ (bisect r k (or exactp (plusp q))))))))
+ (bisect n k-start nil))))
+
+(defun %output-integer-in-base (integer base stream)
+ (when (minusp integer)
+ (write-char #\- stream)
+ (setf integer (- integer)))
+ ;; 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)))
+