0.8.20.1: fun-name fun, debugger debugged

[sbcl.git] / src / code / print.lisp

diff --git a/src/code/print.lisp b/src/code/print.lisp
index d327a3d..011d575 100644 (file)
--- 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))))
 \f
 ;;;; catch-all for unknown things