X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=011d57505770253c4fdd5c22660022fd9c71d7df;hb=bea5b384106a6734a4b280a76e8ebdd4d51b5323;hp=4981c77f2e0a32f9b8354b5fb5531509e9b7e04b;hpb=b420873de742dd0e9ff0d2231d2cc37cf6aba3f8;p=sbcl.git

diff --git a/src/code/print.lisp b/src/code/print.lisp
index 4981c77..011d575 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -75,26 +75,26 @@
   #!+sb-doc
   "Bind the reader and printer control variables to values that enable READ
    to reliably read the results of PRINT. These values are:
-       *PACKAGE*			the COMMON-LISP-USER package
-       *PRINT-ARRAY*			T
-       *PRINT-BASE*			10
-       *PRINT-CASE*			:UPCASE
-       *PRINT-CIRCLE*			NIL
-       *PRINT-ESCAPE*			T
-       *PRINT-GENSYM*			T
-       *PRINT-LENGTH*			NIL
-       *PRINT-LEVEL*			NIL
-       *PRINT-LINES*			NIL
-       *PRINT-MISER-WIDTH*		NIL
-       *PRINT-PRETTY*			NIL
-       *PRINT-RADIX*			NIL
-       *PRINT-READABLY*			T
-       *PRINT-RIGHT-MARGIN*		NIL
-       *READ-BASE*			10
-       *READ-DEFAULT-FLOAT-FORMAT* 	SINGLE-FLOAT
-       *READ-EVAL*			T
-       *READ-SUPPRESS*			NIL
-       *READTABLE*			the standard readtable"
+       *PACKAGE*                        the COMMON-LISP-USER package
+       *PRINT-ARRAY*                    T
+       *PRINT-BASE*                     10
+       *PRINT-CASE*                     :UPCASE
+       *PRINT-CIRCLE*                   NIL
+       *PRINT-ESCAPE*                   T
+       *PRINT-GENSYM*                   T
+       *PRINT-LENGTH*                   NIL
+       *PRINT-LEVEL*                    NIL
+       *PRINT-LINES*                    NIL
+       *PRINT-MISER-WIDTH*              NIL
+       *PRINT-PRETTY*                   NIL
+       *PRINT-RADIX*                    NIL
+       *PRINT-READABLY*                 T
+       *PRINT-RIGHT-MARGIN*             NIL
+       *READ-BASE*                      10
+       *READ-DEFAULT-FLOAT-FORMAT*      SINGLE-FLOAT
+       *READ-EVAL*                      T
+       *READ-SUPPRESS*                  NIL
+       *READTABLE*                      the standard readtable"
   `(%with-standard-io-syntax (lambda () ,@body)))
 
 (defun %with-standard-io-syntax (function)
@@ -158,7 +158,7 @@
   #!+sb-doc
   "Output a mostly READable printed representation of OBJECT on the specified
   STREAM."
-  (let ((*print-escape* T))
+  (let ((*print-escape* t))
     (output-object object (out-synonym-of stream)))
   object)
 
@@ -166,8 +166,8 @@
   #!+sb-doc
   "Output an aesthetic but not necessarily READable printed representation
   of OBJECT on the specified STREAM."
-  (let ((*print-escape* NIL)
-	(*print-readably* NIL))
+  (let ((*print-escape* nil)
+	(*print-readably* nil))
     (output-object object (out-synonym-of stream)))
   object)
 
@@ -217,18 +217,21 @@
   #!+sb-doc
   "Return the printed representation of OBJECT as a string with
    slashification on."
-  (stringify-object object t))
+  (let ((*print-escape* t))
+    (stringify-object object)))
 
 (defun princ-to-string (object)
   #!+sb-doc
   "Return the printed representation of OBJECT as a string with
   slashification off."
-  (stringify-object object nil))
+  (let ((*print-escape* nil)
+	(*print-readably* nil))
+    (stringify-object object)))
 
 ;;; 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 &optional (*print-escape* *print-escape*))
+(defun stringify-object (object)
   (let ((stream (if *string-output-streams*
 		    (pop *string-output-streams*)
 		    (make-string-output-stream))))
@@ -249,15 +252,12 @@
 	   (when type
 	     (write (type-of object) :stream stream :circle nil
 		    :level nil :length nil)
-	     (when (or body identity)
-	       (write-char #\space stream)
-	       (pprint-newline :fill stream)))
+	     (write-char #\space stream))
 	   (when body
 	     (funcall body))
 	   (when identity
-	     (when body
-	       (write-char #\space stream)
-	       (pprint-newline :fill stream))
+	     (when (or body (not type))
+	       (write-char #\space stream))
 	     (write-char #\{ stream)
 	     (write (get-lisp-obj-address object) :stream stream
 		    :radix nil :base 16)
@@ -360,7 +360,7 @@
      ;; Someone forgot to initiate circularity detection.
      (let ((*print-circle* nil))
        (error "trying to use CHECK-FOR-CIRCULARITY when ~
-	       circularity checking isn't initiated")))
+               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.
@@ -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)
@@ -615,10 +613,10 @@
 ;;; character has. At characters have at least one bit set, so we can
 ;;; search for any character with a positive test.
 (defvar *character-attributes*
-  (make-array char-code-limit
+  (make-array 160 ; FIXME
 	      :element-type '(unsigned-byte 16)
 	      :initial-element 0))
-(declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit))
+(declaim (type (simple-array (unsigned-byte 16) (#.160)) ; FIXME
 	       *character-attributes*))
 
 ;;; constants which are a bit-mask for each interesting character attribute
@@ -672,17 +670,17 @@
   (set-bit #\/ slash-attribute)
 
   ;; Mark anything not explicitly allowed as funny.
-  (dotimes (i char-code-limit)
+  (dotimes (i 160) ; FIXME
     (when (zerop (aref *character-attributes* i))
       (setf (aref *character-attributes* i) funny-attribute))))
 
 ;;; For each character, the value of the corresponding element is the
 ;;; lowest base in which that character is a digit.
 (defvar *digit-bases*
-  (make-array char-code-limit
+  (make-array 128 ; FIXME
 	      :element-type '(unsigned-byte 8)
 	      :initial-element 36))
-(declaim (type (simple-array (unsigned-byte 8) (#.char-code-limit))
+(declaim (type (simple-array (unsigned-byte 8) (#.128)) ; FIXME
 	       *digit-bases*))
 (dotimes (i 36)
   (let ((char (digit-char i 36)))
@@ -698,7 +696,11 @@
 		   ,(if at-end '(go TEST-SIGN) '(return nil)))
 		 (setq current (schar name index)
 		       code (char-code current)
-		       bits (aref attributes code))
+		       bits (cond ; FIXME
+                              ((< code 160) (aref attributes code))
+                              ((upper-case-p current) uppercase-attribute)
+                              ((lower-case-p current) lowercase-attribute)
+                              (t other-attribute)))
 		 (incf index)
 		 (go ,tag)))
 	     (test (&rest attributes)
@@ -713,7 +715,8 @@
 					attributes))
 			     bits)))))
 	     (digitp ()
-	       `(< (the fixnum (aref bases code)) base)))
+               `(and (< code 128) ; FIXME
+                     (< (the fixnum (aref bases code)) base))))
 
     (prog ((len (length name))
 	   (attributes *character-attributes*)
@@ -740,7 +743,13 @@
 			  letter-attribute)))
 	(do ((i (1- index) (1+ i)))
 	    ((= i len) (return-from symbol-quotep nil))
-	  (unless (zerop (logand (aref attributes (char-code (schar name i)))
+	  (unless (zerop (logand (let* ((char (schar name i))
+					(code (char-code char)))
+				   (cond 
+				     ((< code 160) (aref attributes code))
+				     ((upper-case-p char) uppercase-attribute)
+				     ((lower-case-p char) lowercase-attribute)
+				     (t other-attribute)))
 				 mask))
 	    (return-from symbol-quotep t))))
 
@@ -961,7 +970,13 @@
 (defun output-vector (vector stream)
   (declare (vector vector))
   (cond ((stringp vector)
-	 (cond ((or *print-escape* *print-readably*)
+	 (cond ((and *print-readably*
+		     (not (eq (array-element-type vector)
+			      (load-time-value
+			       (array-element-type
+				(make-array 0 :element-type 'character))))))
+		(error 'print-not-readable :object vector))
+	       ((or *print-escape* *print-readably*)
 		(write-char #\" stream)
 		(quote-string vector stream)
 		(write-char #\" stream))
@@ -1031,7 +1046,8 @@
 	     (not (array-readably-printable-p array)))
     (error 'print-not-readable :object array))
   (write-char #\# stream)
-  (let ((*print-base* 10))
+  (let ((*print-base* 10)
+	(*print-radix* nil))
     (output-integer (array-rank array) stream))
   (write-char #\A stream)
   (with-array-data ((data array) (start) (end))
@@ -1064,115 +1080,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)
@@ -1181,10 +1177,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.
@@ -1210,9 +1206,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:
@@ -1237,16 +1230,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!
-
-(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
@@ -1255,132 +1246,169 @@
 	       (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 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.
+;;;
+;;; possible extension for the enthusiastic: printing floats in bases
+;;; other than base 10.
+(defconstant single-float-min-e
+  (nth-value 1 (decode-float least-positive-single-float)))
+(defconstant double-float-min-e
+  (nth-value 1 (decode-float least-positive-double-float)))
+#!+long-float
+(defconstant long-float-min-e
+  (nth-value 1 (decode-float least-positive-long-float)))
+
+(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)
+	   (double-float double-float-min-e)
+	   #!+long-float
+	   (long-float long-float-min-e))))
+    (multiple-value-bind (f e)
+	(integer-decode-float v)
+      (let (;; FIXME: these even tests assume normal IEEE rounding
+	    ;; mode.  I wonder if we should cater for non-normal?
+	    (high-ok (evenp f))
+	    (low-ok (evenp f))
+	    (result (make-array 50 :element-type 'base-char
+				:fill-pointer 0 :adjustable t)))
+	(labels ((scale (r s m+ m-)
+		   (do ((k 0 (1+ k))
+			(s s (* s print-base)))
+		       ((not (or (> (+ r m+) s)
+				 (and high-ok (= (+ r m+) s))))
+			(do ((k k (1- k))
+			     (r r (* r print-base))
+			     (m+ m+ (* m+ print-base))
+			     (m- m- (* m- print-base)))
+			    ((not (or (< (* (+ 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)
+		     (tagbody
+		      loop
+			(setf (values d r) (truncate (* r print-base) s))
+			(setf m+ (* m+ print-base))
+			(setf m- (* m- print-base))
+			(setf tc1 (or (< r m-) (and low-ok (= r m-))))
+			(setf tc2 (or (> (+ r m+) s)
+				      (and high-ok (= (+ r m+) s))))
+			(when (or tc1 tc2)
+			  (go end))
+			(vector-push-extend (char digit-characters d) result)
+			(go loop)
+		      end
+			(let ((d (cond
+				   ((and (not tc1) tc2) (1+ d))
+				   ((and tc1 (not tc2)) d)
+				   (t ; (and tc1 tc2)
+				    (if (< (* r 2) s) d (1+ d))))))
+			  (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
 ;;; exponent E such that Z * 10^E is (approximately) equal to the
@@ -1445,6 +1473,12 @@
 ;;; attractive to handle exponential notation with the same accuracy
 ;;; as non-exponential notation, using the method described in the
 ;;; Steele and White paper.
+;;;
+;;; NOTE II: this has been bypassed slightly by implementing Burger
+;;; and Dybvig, 1996.  When someone has time (KLUDGE) they can
+;;; probably (a) implement the optimizations suggested by Burger and
+;;; Dyvbig, and (b) remove all vestiges of Dragon4, including from
+;;; fixed-format printing.
 
 ;;; Print the appropriate exponent marker for X and the specified exponent.
 (defun print-float-exponent (x exp stream)
@@ -1502,26 +1536,34 @@
 	(write-string "0.0" stream)
 	(print-float-exponent x 0 stream))
        (t
-	(output-float-aux x stream (float 1/1000 x) (float 10000000 x))))))))
+	(output-float-aux x stream -3 8)))))))
 (defun output-float-aux (x stream e-min e-max)
-  (if (and (>= x e-min) (< x e-max))
-      ;; free format
-      (multiple-value-bind (str len lpoint tpoint) (flonum-to-string x)
-	(declare (ignore len))
-	(when lpoint (write-char #\0 stream))
-	(write-string str stream)
-	(when tpoint (write-char #\0 stream))
-	(print-float-exponent x 0 stream))
-      ;; exponential format
-      (multiple-value-bind (f ex) (scale-exponent x)
-	(multiple-value-bind (str len lpoint tpoint)
-	    (flonum-to-string f nil nil 1)
-	  (declare (ignore len))
-	  (when lpoint (write-char #\0 stream))
-	  (write-string str stream)
-	  (when tpoint (write-char #\0 stream))
-	  ;; Subtract out scale factor of 1 passed to FLONUM-TO-STRING.
-	  (print-float-exponent x (1- ex) stream)))))
+  (multiple-value-bind (e string)
+      (flonum-to-digits x)
+    (cond
+      ((< e-min e e-max)
+       (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 (<= (length string) e)
+	       (write-char #\0 stream))
+	     (print-float-exponent x 0 stream))
+	   (progn
+	     (write-string "0." stream)
+	     (dotimes (i (- e))
+	       (write-char #\0 stream))
+	     (write-string string stream)
+	     (print-float-exponent x 0 stream))))
+      (t (write-string string stream :end 1)
+	 (write-char #\. stream)
+	 (write-string string stream :start 1)
+	 (when (= (length string) 1)
+	   (write-char #\0 stream))
+	 (print-float-exponent x (1- e) stream)))))
 
 ;;;; other leaf objects
 
@@ -1588,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