diff --git a/code/print.lisp b/code/print.lisp
index b4b5e24fb756d281cd5db75f28dd14ccea16a7ab..efb41dda4eb7ca8fe1ac03564243127e59884348 100644
--- a/code/print.lisp
+++ b/code/print.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.11 1990/09/19 21:31:12 ram Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.12 1990/10/01 14:56:10 ram Exp $
 ;;;
 ;;; CMU Common Lisp printer.
 ;;;
@@ -44,6 +44,19 @@
   "If true, symbols with no home package are printed with a #: prefix.
   If false, no prefix is printed.")
 
+;;; These next two vars are *not* really fully implemented, but I added them
+;;; here so that I wouldn't be forced to write new code incorrectly.  
+;;;        -- Ram, 9/28/90
+;;;
+(defvar *print-readably* nil
+  "If true, all objects will printed readably.  If readably printing is
+  impossible, an error will be signalled.  This overrides the value of
+  *PRINT-ESCAPE*.  But this isn't really implemented yet.")
+
+(defvar *read-eval* t
+  "If false, then the #. read macro is disabled.  But this isn't really
+  implemented yet.")
+
 
 ;;; Imported from reader.
 ;;;
@@ -958,8 +971,11 @@
 	 (setf (fill-pointer *digit-string*) 0)
 	 (multiple-value-bind (sig exp)
 			      (integer-decode-float x)
-	   (float-string sig exp (float-digits x) width fdigits scale
-			 fmin)))))
+	   (let* ((precision (float-precision x))
+		  (digits (float-digits x))
+		  (fudge (- digits precision)))
+	   (float-string (ash sig (- fudge)) (+ exp fudge) precision width
+			 fdigits scale fmin))))))
 
 
 (defun float-string (fraction exponent precision width fdigits scale fmin)
@@ -1073,35 +1089,42 @@
     ;;all done
     (values *digit-string* (1+ digits) (= decpnt 0) (= decpnt digits) decpnt)))
 
-
-;;; Given a non-negative floating point number, SCALE-EXPONENT returns a
-;;; new floating point number Z in the range (0.1, 1.0] and and exponent
-;;; E such that Z * 10^E is (approximately) equal to the original number.
-;;; There may be some loss of precision due the floating point representation.
-
-(defun scale-exponent (x)
-  (let ((zero (float 0 x))
-	(one (float 1 x))
-	(ten (float 10 x))
-	(one-tenth (float 1/10 x))
-	(log10-of-2 (float (log 2l0 10) x)))
+;;; SCALE-EXPONENT  --  Internal
+;;;
+;;;    Given a non-negative floating point number, SCALE-EXPONENT returns a new
+;;; floating point number Z in the range (0.1, 1.0] and and exponent E such
+;;; that Z * 10^E is (approximately) equal to the original number.  There may
+;;; be some loss of precision due the floating point representation.  The
+;;; scaling is always done with long float arithmetic, which helps printing of
+;;; lesser precisions as well as avoiding generic arithmetic.
+;;;
+;;;    When computing our initial scale factor using EXPT, we pull out part of
+;;; the computation to avoid over/under flow.  When denormalized, we must pull
+;;; out a large factor, since there is more negative exponent range than
+;;; positive range.
+;;;
+(defun scale-exponent (original-x)
+  (let* ((x (coerce original-x 'long-float)))
     (multiple-value-bind (sig exponent)
 			 (decode-float x)
       (declare (ignore sig))
-      (if (= x zero)
-	  (values zero 1)
-	  (let* ((ex (round (* exponent log10-of-2)))
-		 (x (if (minusp ex)		;For the end ranges.
-			(* x ten (expt ten (- -1 ex)))
-			(/ x ten (expt ten (1- ex))))))
-	    (do ((d ten (* d ten))
+      (if (= x 0.0l0)
+	  (values (float 0.0l0 original-x) 1)
+	  (let* ((ex (round (* exponent (log 2l0 10))))
+		 (x (if (minusp ex)
+			(if (float-denormalized-p x)
+			    (* x 1.0l16 (expt 10.0l0 (- (- ex) 16)))
+			    (* x 10.0l0 (expt 10.0l0 (- (- ex) 1))))
+			(/ x 10.0l0 (expt 10.0l0 (1- ex))))))
+	    (do ((d 10.0l0 (* d 10.0l0))
 		 (y x (/ x d))
 		 (ex ex (1+ ex)))
-		((< y one)
-		 (do ((m ten (* m ten))
-		      (z y (* z m))
+		((< y 1.0l0)
+		 (do ((m 10.0l0 (* m 10.0l0))
+		      (z y (* y m))
 		      (ex ex (1- ex)))
-		     ((>= z one-tenth) (values z ex))))))))))
+		     ((>= z 0.1l0)
+		      (values (float z original-x) ex))))))))))
 
 
 ;;;; Entry point for the float printer.
@@ -1141,17 +1164,77 @@
 		  (long-float #\L))
 		plusp exp))))
 
+
+;;; FLOAT-FORMAT-NAME  --  Internal
+;;;
+;;;    Return the string name of X's float format.
+;;;
+(defun float-format-name (x)
+  (declare (float x))
+  (etypecase x
+    (single-float "SINGLE-FLOAT")
+    (double-float "DOUBLE-FLOAT")
+    (short-float "SHORT-FLOAT")
+    (long-float "LONG-FLOAT")))
+
+
+;;; OUTPUT-FLOAT-INFINITY  --  Internal
+;;;
+;;;    Write out an infinity using #. notation, or flame out if
+;;; *print-readably* is true and *read-eval* is false.
+;;;
+(defun output-float-infinity (x stream)
+  (declare (float x) (stream stream))
+  (cond (*read-eval*
+	 (write-string "#." stream))
+	(*print-readably*
+	 (error "Unable to print infinities readably without #."))
+	(t
+	 (write-string "#<" stream)))
+  (write-string "EXT:" stream)
+  (write-string (float-format-name x) stream)
+  (write-string (if (plusp x) "-POSITIVE-" "-NEGATIVE-")
+		stream)
+  (write-string "INFINITY" stream)
+  (unless *read-eval*
+    (write-string ">" stream)))
+
+
+;;; OUTPUT-FLOAT-NAN  --  Internal
+;;;
+;;;    Output a #< NaN or die trying.
+;;;
+(defun output-float-nan (x stream)
+  (when *print-readably*
+    (error "Can't print NaN's readably."))
+  (write-string "#<" stream)
+  (write-string (float-format-name x) stream)
+  (write-string (if (float-trapping-nan-p x) " Trapping" " Quiet") stream)
+  (write-string " NaN>" stream))
+
+
+;;; OUTPUT-FLOAT  --  Internal
+;;;
+;;;    Functioned called by OUTPUT-OBJECT to handle floats.
+;;;
 (defun output-float (x stream)
-  (let ((x (cond ((minusp (float-sign x))
-		  (write-char #\- stream)
-		  (- x))
-		 (t
-		  x))))
-    (cond ((zerop x)
-	   (write-string "0.0" stream)
-	   (print-float-exponent x 0 stream))
-	  (t
-	   (output-float-aux x stream (float 1/1000 x) (float 10000000 x))))))
+  (cond
+   ((float-infinity-p x)
+    (output-float-infinity x stream))
+   ((float-nan-p x)
+    (output-float-nan x stream))
+   (t
+    (let ((x (cond ((minusp (float-sign x))
+		    (write-char #\- stream)
+		    (- x))
+		   (t
+		    x))))
+      (cond
+       ((zerop x)
+	(write-string "0.0" stream)
+	(print-float-exponent x 0 stream))
+       (t
+	(output-float-aux x stream (float 1/1000 x) (float 10000000 x))))))))
 ;;;  
 (defun output-float-aux (x stream e-min e-max)
   (if (and (>= x e-min) (< x e-max))