X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=018cf57f29c9eae3f5de04761994faf2bcbed2e3;hb=ad3beba970fab6e451a461c9f9b14faf4ef17718;hp=057df860ef44939d9a3fbc87d47f9fcd1667c483;hpb=069ca63d16c8de8742fc78b927dfa7b79a27c96d;p=sbcl.git

diff --git a/src/code/print.lisp b/src/code/print.lisp
index 057df86..018cf57 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -21,7 +21,7 @@
   "If true, all objects will printed readably. If readable printing is
   impossible, an error will be signalled. This overrides the value of
   *PRINT-ESCAPE*.")
-(defvar *print-escape* T
+(defvar *print-escape* t
   #!+sb-doc
   "Should we print in a reasonably machine-readable way? (possibly
   overridden by *PRINT-READABLY*)")
@@ -230,16 +230,11 @@
 
 ;;; This produces the printed representation of an object as a string.
 ;;; The few ...-TO-STRING functions above call this.
-(defvar *string-output-streams* ())
 (defun stringify-object (object)
-  (let ((stream (if *string-output-streams*
-		    (pop *string-output-streams*)
-		    (make-string-output-stream))))
+  (let ((stream (make-string-output-stream)))
     (setup-printer-state)
     (output-object object stream)
-    (prog1
-	(get-output-stream-string stream)
-      (push stream *string-output-streams*))))
+    (get-output-stream-string stream)))
 
 ;;;; support for the PRINT-UNREADABLE-OBJECT macro
 
@@ -275,108 +270,6 @@
             (write-char #\> stream))))
   nil)
 
-;;;; circularity detection stuff
-
-;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that
-;;; (eventually) ends up with entries for every object printed. When
-;;; we are initially looking for circularities, we enter a T when we
-;;; find an object for the first time, and a 0 when we encounter an
-;;; object a second time around. When we are actually printing, the 0
-;;; entries get changed to the actual marker value when they are first
-;;; printed.
-(defvar *circularity-hash-table* nil)
-
-;;; When NIL, we are just looking for circularities. After we have
-;;; found them all, this gets bound to 0. Then whenever we need a new
-;;; marker, it is incremented.
-(defvar *circularity-counter* nil)
-
-;;; Check to see whether OBJECT is a circular reference, and return
-;;; something non-NIL if it is. If ASSIGN is T, then the number to use
-;;; in the #n= and #n# noise is assigned at this time.
-;;; If ASSIGN is true, reference bookkeeping will only be done for
-;;; existing entries, no new references will be recorded!
-;;;
-;;; Note: CHECK-FOR-CIRCULARITY must be called *exactly* once with
-;;; ASSIGN true, or the circularity detection noise will get confused
-;;; about when to use #n= and when to use #n#. If this returns non-NIL
-;;; when ASSIGN is true, then you must call HANDLE-CIRCULARITY on it.
-;;; If CHECK-FOR-CIRCULARITY returns :INITIATE as the second value,
-;;; you need to initiate the circularity detection noise, e.g. bind
-;;; *CIRCULARITY-HASH-TABLE* and *CIRCULARITY-COUNTER* to suitable values
-;;; (see #'OUTPUT-OBJECT for an example).
-(defun check-for-circularity (object &optional assign)
-  (cond ((null *print-circle*)
-	 ;; Don't bother, nobody cares.
-	 nil)
-	((null *circularity-hash-table*)
-          (values nil :initiate))
-	((null *circularity-counter*)
-	 (ecase (gethash object *circularity-hash-table*)
-	   ((nil)
-	    ;; first encounter
-	    (setf (gethash object *circularity-hash-table*) t)
-	    ;; We need to keep looking.
-	    nil)
-	   ((t)
-	    ;; second encounter
-	    (setf (gethash object *circularity-hash-table*) 0)
-	    ;; It's a circular reference.
-	    t)
-	   (0
-	    ;; It's a circular reference.
-	    t)))
-	(t
-	 (let ((value (gethash object *circularity-hash-table*)))
-	   (case value
-	     ((nil t)
-	      ;; If NIL, we found an object that wasn't there the
-	      ;; first time around. If T, this object appears exactly
-	      ;; once. Either way, just print the thing without any
-	      ;; special processing. Note: you might argue that
-	      ;; finding a new object means that something is broken,
-	      ;; but this can happen. If someone uses the ~@<...~:>
-	      ;; format directive, it conses a new list each time
-	      ;; though format (i.e. the &REST list), so we will have
-	      ;; different cdrs.
-	      nil)
-	     (0
-	      (if assign
-		  (let ((value (incf *circularity-counter*)))
-		    ;; first occurrence of this object: Set the counter.
-		    (setf (gethash object *circularity-hash-table*) value)
-		    value)
-		  t))
-	     (t
-	      ;; second or later occurrence
-	      (- value)))))))
-
-;;; Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then
-;;; you should go ahead and print the object. If it returns NIL, then
-;;; you should blow it off.
-(defun handle-circularity (marker stream)
-  (case marker
-    (:initiate
-     ;; Someone forgot to initiate circularity detection.
-     (let ((*print-circle* nil))
-       (error "trying to use CHECK-FOR-CIRCULARITY when ~
-               circularity checking isn't initiated")))
-    ((t)
-     ;; It's a second (or later) reference to the object while we are
-     ;; just looking. So don't bother groveling it again.
-     nil)
-    (t
-     (write-char #\# stream)
-     (let ((*print-base* 10) (*print-radix* nil))
-       (cond ((minusp marker)
-	      (output-integer (- marker) stream)
-	      (write-char #\# stream)
-	      nil)
-	     (t
-	      (output-integer marker stream)
-	      (write-char #\= stream)
-	      t))))))
-
 ;;;; OUTPUT-OBJECT -- the main entry point
 
 ;;; Objects whose print representation identifies them EQLly don't
@@ -394,9 +287,8 @@
 		 (sb!pretty:output-pretty-object object stream)
 		 (output-ugly-object object stream)))
 	   (check-it (stream)
-             (multiple-value-bind (marker initiate)
-                 (check-for-circularity object t)
-               ;; initialization of the circulation detect noise ...
+	     (multiple-value-bind (marker initiate)
+		 (check-for-circularity object t)
 	       (if (eq initiate :initiate)
 		   (let ((*circularity-hash-table*
 			  (make-hash-table :test 'eq)))
@@ -454,8 +346,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 +972,95 @@
 
 ;;;; 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)))
+
+;; Algorithm by Harald Hanche-Olsen, sbcl-devel 2005-02-05
+(defun %output-bignum-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))
+    (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)
+    (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)
@@ -1199,10 +1069,10 @@
 ;;;; float printing
 
 ;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does
-;;; most of the work for all printing of floating point numbers in the
-;;; printer and in FORMAT. It converts a floating point number to a
-;;; string in a free or fixed format with no exponent. The
-;;; interpretation of the arguments is as follows:
+;;; most of the work for all printing of floating point numbers in
+;;; FORMAT.  It converts a floating point number to a string in a free
+;;; or fixed format with no exponent. The interpretation of the
+;;; arguments is as follows:
 ;;;
 ;;;     X	- The floating point number to convert, which must not be
 ;;;		negative.
@@ -1228,9 +1098,6 @@
 ;;;		significance in the printed value due to a bogus choice of
 ;;;		scale factor.
 ;;;
-;;; Most of the optional arguments are for the benefit for FORMAT and are not
-;;; used by the printer.
-;;;
 ;;; Returns:
 ;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT)
 ;;; where the results have the following interpretation:
@@ -1255,17 +1122,14 @@
 ;;; representation. Furthermore, only as many digits as necessary to
 ;;; satisfy this condition will be printed.
 ;;;
-;;; FLOAT-STRING actually generates the digits for positive numbers.
-;;; The algorithm is essentially that of algorithm Dragon4 in "How to
-;;; Print Floating-Point Numbers Accurately" by Steele and White. The
-;;; current (draft) version of this paper may be found in
-;;; [CMUC]<steele>tradix.press. DO NOT EVEN THINK OF ATTEMPTING TO
-;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER!
-
-(declaim (type (simple-array character (10)) *digits*))
-(defvar *digits* "0123456789")
+;;; FLOAT-DIGITS actually generates the digits for positive numbers;
+;;; see below for comments.
 
 (defun flonum-to-string (x &optional width fdigits scale fmin)
+  (declare (type float x))
+  ;; FIXME: I think only FORMAT-DOLLARS calls FLONUM-TO-STRING with
+  ;; possibly-negative X.
+  (setf x (abs x))
   (cond ((zerop x)
 	 ;; Zero is a special case which FLOAT-STRING cannot handle.
 	 (if fdigits
@@ -1274,147 +1138,56 @@
 	       (values s (length s) t (zerop fdigits) 0))
 	     (values "." 1 t t 0)))
 	(t
-	 (multiple-value-bind (sig exp) (integer-decode-float x)
-	   (let* ((precision (float-precision x))
-		  (digits (float-digits x))
-		  (fudge (- digits precision))
-		  (width (if width (max width 1) nil)))
-	   (float-string (ash sig (- fudge)) (+ exp fudge) precision width
-			 fdigits scale fmin))))))
-
-(defun float-string (fraction exponent precision width fdigits scale fmin)
-  (let ((r fraction) (s 1) (m- 1) (m+ 1) (k 0)
-	(digits 0) (decpnt 0) (cutoff nil) (roundup nil) u low high
-	(digit-string (make-array 50
-				  :element-type 'base-char
-				  :fill-pointer 0
-				  :adjustable t)))
-    ;; Represent fraction as r/s, error bounds as m+/s and m-/s.
-    ;; Rational arithmetic avoids loss of precision in subsequent
-    ;; calculations.
-    (cond ((> exponent 0)
-	   (setq r (ash fraction exponent))
-	   (setq m- (ash 1 exponent))
-	   (setq m+ m-))
-	  ((< exponent 0)
-	   (setq s (ash 1 (- exponent)))))
-    ;; Adjust the error bounds m+ and m- for unequal gaps.
-    (when (= fraction (ash 1 precision))
-      (setq m+ (ash m+ 1))
-      (setq r (ash r 1))
-      (setq s (ash s 1)))
-    ;; Scale value by requested amount, and update error bounds.
-    (when scale
-      (if (minusp scale)
-	  (let ((scale-factor (expt 10 (- scale))))
-	    (setq s (* s scale-factor)))
-	  (let ((scale-factor (expt 10 scale)))
-	    (setq r (* r scale-factor))
-	    (setq m+ (* m+ scale-factor))
-	    (setq m- (* m- scale-factor)))))
-    ;; Scale r and s and compute initial k, the base 10 logarithm of r.
-    (do ()
-	((>= r (ceiling s 10)))
-      (decf k)
-      (setq r (* r 10))
-      (setq m- (* m- 10))
-      (setq m+ (* m+ 10)))
-    (do ()(nil)
-      (do ()
-	  ((< (+ (ash r 1) m+) (ash s 1)))
-	(setq s (* s 10))
-	(incf k))
-      ;; Determine number of fraction digits to generate.
-      (cond (fdigits
-	     ;; Use specified number of fraction digits.
-	     (setq cutoff (- fdigits))
-	     ;;don't allow less than fmin fraction digits
-	     (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin))))
-	    (width
-	     ;; Use as many fraction digits as width will permit but
-	     ;; force at least fmin digits even if width will be
-	     ;; exceeded.
-	     (if (< k 0)
-		 (setq cutoff (- 1 width))
-		 (setq cutoff (1+ (- k width))))
-	     (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin)))))
-      ;; If we decided to cut off digit generation before precision
-      ;; has been exhausted, rounding the last digit may cause a carry
-      ;; propagation. We can prevent this, preserving left-to-right
-      ;; digit generation, with a few magical adjustments to m- and
-      ;; m+. Of course, correct rounding is also preserved.
-      (when (or fdigits width)
-	(let ((a (- cutoff k))
-	      (y s))
-	  (if (>= a 0)
-	      (dotimes (i a) (setq y (* y 10)))
-	      (dotimes (i (- a)) (setq y (ceiling y 10))))
-	  (setq m- (max y m-))
-	  (setq m+ (max y m+))
-	  (when (= m+ y) (setq roundup t))))
-      (when (< (+ (ash r 1) m+) (ash s 1)) (return)))
-    ;; Zero-fill before fraction if no integer part.
-    (when (< k 0)
-      (setq decpnt digits)
-      (vector-push-extend #\. digit-string)
-      (dotimes (i (- k))
-	(incf digits) (vector-push-extend #\0 digit-string)))
-    ;; Generate the significant digits.
-    (do ()(nil)
-      (decf k)
-      (when (= k -1)
-	(vector-push-extend #\. digit-string)
-	(setq decpnt digits))
-      (multiple-value-setq (u r) (truncate (* r 10) s))
-      (setq m- (* m- 10))
-      (setq m+ (* m+ 10))
-      (setq low (< (ash r 1) m-))
-      (if roundup
-	  (setq high (>= (ash r 1) (- (ash s 1) m+)))
-	  (setq high (> (ash r 1) (- (ash s 1) m+))))
-      ;; Stop when either precision is exhausted or we have printed as
-      ;; many fraction digits as permitted.
-      (when (or low high (and cutoff (<= k cutoff))) (return))
-      (vector-push-extend (char *digits* u) digit-string)
-      (incf digits))
-    ;; If cutoff occurred before first digit, then no digits are
-    ;; generated at all.
-    (when (or (not cutoff) (>= k cutoff))
-      ;; Last digit may need rounding
-      (vector-push-extend (char *digits*
-				(cond ((and low (not high)) u)
-				      ((and high (not low)) (1+ u))
-				      (t (if (<= (ash r 1) s) u (1+ u)))))
-			  digit-string)
-      (incf digits))
-    ;; Zero-fill after integer part if no fraction.
-    (when (>= k 0)
-      (dotimes (i k) (incf digits) (vector-push-extend #\0 digit-string))
-      (vector-push-extend #\. digit-string)
-      (setq decpnt digits))
-    ;; Add trailing zeroes to pad fraction if fdigits specified.
-    (when fdigits
-      (dotimes (i (- fdigits (- digits decpnt)))
-	(incf digits)
-	(vector-push-extend #\0 digit-string)))
-    ;; all done
-    (values digit-string (1+ digits) (= decpnt 0) (= decpnt digits) decpnt)))
+	 (multiple-value-bind (e string)
+	     (if fdigits
+		 (flonum-to-digits x (min (- fdigits) (- (or fmin 0))))
+		 (if (and width (> width 1))
+		     (let ((w (multiple-value-list (flonum-to-digits x (1- width) t)))
+			   (f (multiple-value-list (flonum-to-digits x (- (or fmin 0))))))
+		       (cond
+			 ((>= (length (cadr w)) (length (cadr f)))
+			  (values-list w))
+			 (t (values-list f))))
+		     (flonum-to-digits x)))
+	   (let ((e (+ e (or scale 0)))
+		 (stream (make-string-output-stream)))
+	     (if (plusp e)
+		 (progn
+		   (write-string string stream :end (min (length string) e))
+		   (dotimes (i (- e (length string)))
+		     (write-char #\0 stream))
+		   (write-char #\. stream)
+		   (write-string string stream :start (min (length string) e))
+		   (when fdigits
+		     (dotimes (i (- fdigits
+				    (- (length string) 
+				       (min (length string) e))))
+		       (write-char #\0 stream))))
+		 (progn
+		   (write-string "." stream)
+		   (dotimes (i (- e))
+		     (write-char #\0 stream))
+		   (write-string string stream)
+		   (when fdigits
+		     (dotimes (i (+ fdigits e (- (length string))))
+		       (write-char #\0 stream)))))
+	     (let ((string (get-output-stream-string stream)))
+	       (values string (length string)
+		       (char= (char string 0) #\.)
+		       (char= (char string (1- (length string))) #\.)
+		       (position #\. string))))))))
 
 ;;; implementation of figure 1 from Burger and Dybvig, 1996.  As the
-;;; implementation of the Dragon from Classic CMUCL (and above,
-;;; FLONUM-TO-STRING) says: "DO NOT EVEN THINK OF ATTEMPTING TO
-;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER!", and in this case
-;;; we have to add that even reading the paper might not bring
-;;; immediate illumination as CSR has attempted to turn idiomatic
-;;; Scheme into idiomatic Lisp.
+;;; implementation of the Dragon from Classic CMUCL (and previously in
+;;; SBCL above FLONUM-TO-STRING) says: "DO NOT EVEN THINK OF
+;;; ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING THE PAPER!",
+;;; and in this case we have to add that even reading the paper might
+;;; not bring immediate illumination as CSR has attempted to turn
+;;; idiomatic Scheme into idiomatic Lisp.
 ;;;
 ;;; FIXME: figure 1 from Burger and Dybvig is the unoptimized
 ;;; algorithm, noticeably slow at finding the exponent.  Figure 2 has
-;;; an improved algorithm, but CSR ran out of energy
-;;;
-;;; FIXME: Burger and Dybvig also provide an algorithm for
-;;; fixed-format floating point printing.  If it were implemented,
-;;; then we could delete the Dragon altogether (see FLONUM-TO-STRING).
+;;; an improved algorithm, but CSR ran out of energy.
 ;;;
 ;;; possible extension for the enthusiastic: printing floats in bases
 ;;; other than base 10.
@@ -1426,10 +1199,11 @@
 (defconstant long-float-min-e
   (nth-value 1 (decode-float least-positive-long-float)))
 
-(defun flonum-to-digits (v)
+(defun flonum-to-digits (v &optional position relativep)
   (let ((print-base 10) ; B
 	(float-radix 2) ; b
 	(float-digits (float-digits v)) ; p
+        (digit-characters "0123456789")
 	(min-e
 	 (etypecase v
 	   (single-float single-float-min-e)
@@ -1454,7 +1228,8 @@
 			     (m+ m+ (* m+ print-base))
 			     (m- m- (* m- print-base)))
 			    ((not (or (< (* (+ r m+) print-base) s)
-				      (and high-ok (= (* (+ r m+) print-base) s))))
+				      (and (not high-ok)
+                                           (= (* (+ r m+) print-base) s))))
 			     (values k (generate r s m+ m-)))))))
 		 (generate (r s m+ m-)
 		   (let (d tc1 tc2)
@@ -1468,7 +1243,7 @@
 				      (and high-ok (= (+ r m+) s))))
 			(when (or tc1 tc2)
 			  (go end))
-			(vector-push-extend (char *digits* d) result)
+			(vector-push-extend (char digit-characters d) result)
 			(go loop)
 		      end
 			(let ((d (cond
@@ -1476,19 +1251,55 @@
 				   ((and tc1 (not tc2)) d)
 				   (t ; (and tc1 tc2)
 				    (if (< (* r 2) s) d (1+ d))))))
-			  (vector-push-extend (char *digits* d) result)
-			  (return-from generate result))))))
-	  (if (>= e 0)
-	      (if (/= f (expt float-radix (1- float-digits)))
-		  (let ((be (expt float-radix e)))
-		    (scale (* f be 2) 2 be be))
-		  (let* ((be (expt float-radix e))
-			 (be1 (* be float-radix)))
-		    (scale (* f be1 2) (* float-radix 2) be1 be)))
-	      (if (or (= e min-e) (/= f (expt float-radix (1- float-digits))))
-		  (scale (* f 2) (* (expt float-radix (- e)) 2) 1 1)
-		  (scale (* f float-radix 2)
-			 (* (expt float-radix (- 1 e)) 2) float-radix 1))))))))
+			  (vector-push-extend (char digit-characters d) result)
+			  (return-from generate result)))))
+		 (initialize ()
+		   (let (r s m+ m-)
+		     (if (>= e 0)
+			 (let* ((be (expt float-radix e))
+				(be1 (* be float-radix)))
+			   (if (/= f (expt float-radix (1- float-digits)))
+			       (setf r (* f be 2)
+				     s 2
+				     m+ be
+				     m- be)
+			       (setf r (* f be1 2)
+				     s (* float-radix 2)
+				     m+ be1
+				     m- be)))
+			 (if (or (= e min-e) 
+				 (/= f (expt float-radix (1- float-digits))))
+			     (setf r (* f 2)
+				   s (* (expt float-radix (- e)) 2)
+				   m+ 1
+				   m- 1)
+			     (setf r (* f float-radix 2)
+				   s (* (expt float-radix (- 1 e)) 2)
+				   m+ float-radix
+				   m- 1)))
+		     (when position
+		       (when relativep
+			 (aver (> position 0))
+			 (do ((k 0 (1+ k))
+			      ;; running out of letters here
+			      (l 1 (* l print-base)))
+			     ((>= (* s l) (+ r m+))
+			      ;; k is now \hat{k}
+			      (if (< (+ r (* s (/ (expt print-base (- k position)) 2)))
+				     (* s (expt print-base k)))
+				  (setf position (- k position))
+				  (setf position (- k position 1))))))
+		       (let ((low (max m- (/ (* s (expt print-base position)) 2)))
+			     (high (max m+ (/ (* s (expt print-base position)) 2))))
+			 (when (<= m- low)
+			   (setf m- low)
+			   (setf low-ok t))
+			 (when (<= m+ high)
+			   (setf m+ high)
+			   (setf high-ok t))))
+		     (values r s m+ m-))))
+	  (multiple-value-bind (r s m+ m-) (initialize)
+	    (scale r s m+ m-)))))))
 
 ;;; Given a non-negative floating point number, SCALE-EXPONENT returns
 ;;; a new floating point number Z in the range (0.1, 1.0] and an
@@ -1711,23 +1522,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