From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Mon, 8 Nov 2004 14:14:35 +0000 (+0000)
Subject: 0.8.16.36: fixed #350
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=4c5a011ccc355e3653b9490de6a2b3df5777e55d;p=sbcl.git

0.8.16.36: fixed #350
            * Use a bisection algorithm based on suggestion by by Paul
               F. Dietz for printing bignums, and clean up integer
               printing a bit while at it.
---

diff --git a/NEWS b/NEWS
index 3c0cb1a..245e59f 100644
--- a/NEWS
+++ b/NEWS
@@ -16,6 +16,9 @@ changes in sbcl-0.8.17 relative to sbcl-0.8.16:
   * minor incompatible change: SB-C::*COMPILER-ERROR-PRINT-FOO* variables
     are no longer supported: use SB-EXT:*COMPILER-PRINT-VARIABLE-ALIST*
     instead. 
+  * fixed bug #350: bignum-printing is now more memory-efficient,
+    allowing printing of very large bignums, eg. (expt 2 10000000).
+    (reported by Bruno Haible)
   * fixed bug #302: better primitive-type selection for intersection
     types.
   * fixed bug #308: non-graphic characters now all have names, as
diff --git a/src/code/print.lisp b/src/code/print.lisp
index 02a3ca0..d4b0dd1 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -454,8 +454,6 @@
     ;; As long as no one comes up with a non-obscure way of detecting this
     ;; sleaziness, fixing this nonconformity will probably have a low
     ;; priority. -- WHN 2001-11-25
-    (fixnum
-     (output-integer object stream))
     (list
      (if (null object)
 	 (output-symbol object stream)
@@ -1082,115 +1080,70 @@
 
 ;;;; integer, ratio, and complex printing (i.e. everything but floats)
 
+(defun %output-radix (base stream)
+  (write-char #\# stream)
+  (write-char (case base
+                (2 #\b)
+                (8 #\o)
+                (16 #\x)
+                (t (%output-fixnum-in-base base 10 stream)
+                   #\r))
+              stream))
+
+(defun %output-fixnum-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))
+    ;; Then as each recursive call unwinds, turn the
+    ;; digit (in remainder) into a character and output
+    ;; the character.
+    (write-char 
+     (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r) 
+     stream)))
+
+(defun %output-bignum-in-base (n base stream)
+  (labels ((bisect (n power)
+             (if (fixnump n)
+                 (%output-fixnum-in-base n base stream)
+                 (let ((k (truncate power 2)))
+                   (multiple-value-bind (q r) (truncate n (expt base k))
+                     (bisect q (- power k))
+                     (let ((npower (if (zerop r) 0 (truncate (log r base)))))
+                       (dotimes (z (- k npower 1))
+                         (write-char #\0 stream))
+                       (bisect r npower)))))))
+    (bisect n (truncate (log n base)))))
+
+(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)))
+
 (defun output-integer (integer stream)
-  ;; FIXME: This UNLESS form should be pulled out into something like
-  ;; (SANE-PRINT-BASE), along the lines of (SANE-PACKAGE) for the
-  ;; *PACKAGE* variable.
-  (unless (and (fixnump *print-base*)
-	       (< 1 *print-base* 37))
-    (let ((obase *print-base*))
-      (setq *print-base* 10.)
-      (error "~A is not a reasonable value for *PRINT-BASE*." obase)))
-  (when (and (not (= *print-base* 10.))
-	     *print-radix*)
-    ;; First print leading base information, if any.
-    (write-char #\# stream)
-    (write-char (case *print-base*
-		  (2. #\b)
-		  (8. #\o)
-		  (16. #\x)
-		  (T (let ((fixbase *print-base*)
-			   (*print-base* 10.)
-			   (*print-radix* ()))
-		       (sub-output-integer fixbase stream))
-		     #\r))
-		stream))
-  ;; Then output a minus sign if the number is negative, then output
-  ;; the absolute value of the number.
-  (cond ((bignump integer) (print-bignum integer stream))
-	((< integer 0)
-	 (write-char #\- stream)
-	 (sub-output-integer (- integer) stream))
-	(t
-	 (sub-output-integer integer stream)))
-  ;; Print any trailing base information, if any.
-  (if (and (= *print-base* 10.) *print-radix*)
-      (write-char #\. stream)))
-
-(defun sub-output-integer (integer stream)
-  (let ((quotient ())
-	(remainder ()))
-    ;; Recurse until you have all the digits pushed on the stack.
-    (if (not (zerop (multiple-value-setq (quotient remainder)
-		      (truncate integer *print-base*))))
-	(sub-output-integer quotient stream))
-    ;; Then as each recursive call unwinds, turn the digit (in remainder)
-    ;; into a character and output the character.
-    (write-char (code-char (if (and (> remainder 9.)
-				    (> *print-base* 10.))
-			       (+ (char-code #\A) (- remainder 10.))
-			       (+ (char-code #\0) remainder)))
-		stream)))
-
-;;;; bignum printing
-
-;;; *BASE-POWER* holds the number that we keep dividing into the
-;;; bignum for each *print-base*. We want this number as close to
-;;; *most-positive-fixnum* as possible, i.e. (floor (log
-;;; most-positive-fixnum *print-base*)).
-(defparameter *base-power* (make-array 37 :initial-element nil))
-
-;;; *FIXNUM-POWER--1* holds the number of digits for each *PRINT-BASE*
-;;; that fit in the corresponding *base-power*.
-(defparameter *fixnum-power--1* (make-array 37 :initial-element nil))
-
-;;; Print the bignum to the stream. We first generate the correct
-;;; value for *base-power* and *fixnum-power--1* if we have not
-;;; already. Then we call bignum-print-aux to do the printing.
-(defun print-bignum (big stream)
-  (unless (aref *base-power* *print-base*)
-    (do ((power-1 -1 (1+ power-1))
-	 (new-divisor *print-base* (* new-divisor *print-base*))
-	 (divisor 1 new-divisor))
-	((not (fixnump new-divisor))
-	 (setf (aref *base-power* *print-base*) divisor)
-	 (setf (aref *fixnum-power--1* *print-base*) power-1))))
-  (bignum-print-aux (cond ((minusp big)
-			   (write-char #\- stream)
-			   (- big))
-			  (t big))
-		    (aref *base-power* *print-base*)
-		    (aref *fixnum-power--1* *print-base*)
-		    stream)
-  big)
-
-(defun bignum-print-aux (big divisor power-1 stream)
-  (multiple-value-bind (newbig fix) (truncate big divisor)
-    (if (fixnump newbig)
-	(sub-output-integer newbig stream)
-	(bignum-print-aux newbig divisor power-1 stream))
-    (do ((zeros power-1 (1- zeros))
-	 (base-power *print-base* (* base-power *print-base*)))
-	((> base-power fix)
-	 (dotimes (i zeros) (write-char #\0 stream))
-	 (sub-output-integer fix stream)))))
+  (let ((base *print-base*))
+    (when (and (/= base 10) *print-radix*)
+      (%output-radix base stream))
+    (%output-integer-in-base integer base stream)
+    (when (and *print-radix* (= base 10))
+      (write-char #\. stream))))
 
 (defun output-ratio (ratio stream)
-  (when *print-radix*
-    (write-char #\# stream)
-    (case *print-base*
-      (2 (write-char #\b stream))
-      (8 (write-char #\o stream))
-      (16 (write-char #\x stream))
-      (t (write *print-base* :stream stream :radix nil :base 10)
-	 (write-char #\r stream))))
-  (let ((*print-radix* nil))
-    (output-integer (numerator ratio) stream)
+  (let ((base *print-base*))
+    (when *print-radix*
+      (%output-radix base stream))
+    (%output-integer-in-base (numerator ratio) base stream)
     (write-char #\/ stream)
-    (output-integer (denominator ratio) stream)))
+    (%output-integer-in-base (denominator ratio) base stream)))
 
 (defun output-complex (complex stream)
   (write-string "#C(" stream)
+  ;; FIXME: Could this just be OUTPUT-NUMBER? 
   (output-object (realpart complex) stream)
   (write-char #\space stream)
   (output-object (imagpart complex) stream)
diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp
index 15feb43..9d9fd62 100644
--- a/tests/print.impure.lisp
+++ b/tests/print.impure.lisp
@@ -266,5 +266,37 @@
   (assert (format nil x nil))
   (assert (format nil (eval `(formatter ,x)) nil)))
 
+;;; bug 350: bignum printing so memory-hungry that heap runs out
+;;; -- just don't stall here forever on a slow box
+(handler-case
+    (with-timeout 10
+      (print (ash 1 1000000)))
+  (timeout ()
+    (print 'timeout!)))
+
+;;; a spot of random-testing for rational printing
+(defvar *seed-state* (make-random-state))
+(prin1 *seed-state*) ; so that we can reproduce errors
+(let ((seed (make-random-state *seed-state*)))
+  (loop repeat 42
+     do (let ((n (random (ash 1 1000) seed))
+              (d (random (ash 1 1000) seed)))
+          (when (zerop (random 2 seed))
+            (setf n (- n)))
+          (let ((r (/ n d)))
+            (loop for base from 2 to 36
+               do (let ((*print-base* base)
+                        (*read-base* base)
+                        (*print-radix* nil))
+                    (assert (= r (read-from-string (prin1-to-string r))))
+                    (if (= 36 base)
+                        (decf *read-base*)
+                        (incf *read-base*))
+                    (assert (not (eql r (read-from-string (prin1-to-string r)))))
+                    (let ((*print-radix* t))
+                      (assert (= r (read-from-string 
+                                    (princ-to-string r)))))))))
+       (write-char #\.)
+       (finish-output)))
 ;;; success
 (quit :unix-status 104)
diff --git a/version.lisp-expr b/version.lisp-expr
index ad5d22a..c7f4197 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.16.35"
+"0.8.16.36"