X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fprint.lisp;h=011d57505770253c4fdd5c22660022fd9c71d7df;hb=69ef68ba7393e3492c1b4a756d1140f71c2922bc;hp=d327a3d9ae290479ea1862e936d455f22f558adc;hpb=cd0975b46e46cf6edcbec977616a475df9768bf9;p=sbcl.git

diff --git a/src/code/print.lisp b/src/code/print.lisp
index d327a3d..011d575 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -1104,18 +1104,43 @@
      (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r) 
      stream)))
 
+;; Algorithm by Harald Hanche-Olsen, sbcl-devel 2005-02-05
 (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)))))
+  (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))
+    (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 (fill-pointer power) nil))))
 
 (defun %output-integer-in-base (integer base stream)
   (when (minusp integer)
@@ -1605,23 +1630,15 @@
   nil)
 
 (defun output-fun (object stream)
-  (let* ((*print-length* 3) ; in case we have to..
-	 (*print-level* 3)  ; ..print an interpreted function definition
-	 ;; FIXME: This find-the-function-name idiom ought to be
-	 ;; encapsulated in a function somewhere.
-	 (name (case (fun-subtype object)
-		 (#.sb!vm:closure-header-widetag "CLOSURE")
-		 (#.sb!vm:simple-fun-header-widetag (%simple-fun-name object))
-		 (t 'no-name-available)))
-	 (identified-by-name-p (and (symbolp name)
-				    (fboundp name)
-				    (eq (fdefinition name) object))))
-      (print-unreadable-object (object
-				stream
-				:identity (not identified-by-name-p))
-	(prin1 'function stream)
-	(unless (eq name 'no-name-available)
-	  (format stream " ~S" name)))))
+    (let* ((*print-length* 3)  ; in case we have to..
+           (*print-level* 3)  ; ..print an interpreted function definition
+           (name (%fun-name object))
+           (proper-name-p (and (legal-fun-name-p name) (fboundp name)
+                               (eq (fdefinition name) object))))
+      (print-unreadable-object (object stream :identity (not proper-name-p))
+        (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]" 
+                (closurep object)
+                name))))
 
 ;;;; catch-all for unknown things