0.pre7.11:

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

diff --git a/src/code/print.lisp b/src/code/print.lisp
index 7b4d3fe..ba9bb3b 100644 (file)
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -117,9 +117,11 @@
        (*read-eval* t)
        (*read-suppress* nil)
        ;; FIXME: It doesn't seem like a good idea to expose our
        (*read-eval* t)
        (*read-suppress* nil)
        ;; FIXME: It doesn't seem like a good idea to expose our

-       ;; disaster-recovery *STANDARD-READTABLE* here. Perhaps we
-       ;; should do a COPY-READTABLE? The consing would be unfortunate,
-       ;; though.
+       ;; disaster-recovery *STANDARD-READTABLE* here. What if some
+       ;; enterprising user corrupts the disaster-recovery readtable
+       ;; by doing destructive readtable operations within
+       ;; WITH-STANDARD-IO-SYNTAX? Perhaps we should do a
+       ;; COPY-READTABLE? The consing would be unfortunate, though.

        (*readtable* *standard-readtable*))
     (funcall function)))
 \f
        (*readtable* *standard-readtable*))
     (funcall function)))
 \f

@@ -146,13 +148,13 @@
                     ((:pprint-dispatch *print-pprint-dispatch*)
                      *print-pprint-dispatch*))
   #!+sb-doc
                     ((:pprint-dispatch *print-pprint-dispatch*)
                      *print-pprint-dispatch*))
   #!+sb-doc

-  "Outputs OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*"
+  "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*"

   (output-object object (out-synonym-of stream))
   object)
 
 (defun prin1 (object &optional stream)
   #!+sb-doc
   (output-object object (out-synonym-of stream))
   object)
 
 (defun prin1 (object &optional stream)
   #!+sb-doc

-  "Outputs a mostly READable printed representation of OBJECT on the specified
+  "Output a mostly READable printed representation of OBJECT on the specified

   STREAM."
   (let ((*print-escape* T))
     (output-object object (out-synonym-of stream)))
   STREAM."
   (let ((*print-escape* T))
     (output-object object (out-synonym-of stream)))

@@ -160,7 +162,7 @@
 
 (defun princ (object &optional stream)
   #!+sb-doc
 
 (defun princ (object &optional stream)
   #!+sb-doc

-  "Outputs an aesthetic but not necessarily READable printed representation
+  "Output an aesthetic but not necessarily READable printed representation

   of OBJECT on the specified STREAM."
   (let ((*print-escape* NIL)
        (*print-readably* NIL))
   of OBJECT on the specified STREAM."
   (let ((*print-escape* NIL)
        (*print-readably* NIL))

@@ -169,7 +171,7 @@
 
 (defun print (object &optional stream)
   #!+sb-doc
 
 (defun print (object &optional stream)
   #!+sb-doc

-  "Outputs a terpri, the mostly READable printed represenation of OBJECT, and
+  "Output a newline, the mostly READable printed representation of OBJECT, and

   space to the specified STREAM."
   (let ((stream (out-synonym-of stream)))
     (terpri stream)
   space to the specified STREAM."
   (let ((stream (out-synonym-of stream)))
     (terpri stream)

@@ -179,7 +181,7 @@
 
 (defun pprint (object &optional stream)
   #!+sb-doc
 
 (defun pprint (object &optional stream)
   #!+sb-doc

-  "Prettily outputs OBJECT preceded by a newline."
+  "Prettily output OBJECT preceded by a newline."

   (let ((*print-pretty* t)
        (*print-escape* t)
        (stream (out-synonym-of stream)))
   (let ((*print-pretty* t)
        (*print-escape* t)
        (stream (out-synonym-of stream)))

@@ -206,23 +208,23 @@
               ((:pprint-dispatch *print-pprint-dispatch*)
                *print-pprint-dispatch*))
   #!+sb-doc
               ((:pprint-dispatch *print-pprint-dispatch*)
                *print-pprint-dispatch*))
   #!+sb-doc

-  "Returns the printed representation of OBJECT as a string."
+  "Return the printed representation of OBJECT as a string."

   (stringify-object object))
 
 (defun prin1-to-string (object)
   #!+sb-doc
   (stringify-object object))
 
 (defun prin1-to-string (object)
   #!+sb-doc

-  "Returns the printed representation of OBJECT as a string with
+  "Return the printed representation of OBJECT as a string with

    slashification on."
   (stringify-object object t))
 
 (defun princ-to-string (object)
   #!+sb-doc
    slashification on."
   (stringify-object object t))
 
 (defun princ-to-string (object)
   #!+sb-doc

-  "Returns the printed representation of OBJECT as a string with
+  "Return the printed representation of OBJECT as a string with

   slashification off."
   (stringify-object object nil))
 
   slashification off."
   (stringify-object object nil))
 

-;;; This produces the printed representation of an object as a string. The
-;;; few ...-TO-STRING functions above call this.
+;;; 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*))
   (let ((stream (if *string-output-streams*
 (defvar *string-output-streams* ())
 (defun stringify-object (object &optional (*print-escape* *print-escape*))
   (let ((stream (if *string-output-streams*

@@ -236,65 +238,67 @@
 \f
 ;;;; support for the PRINT-UNREADABLE-OBJECT macro
 
 \f
 ;;;; support for the PRINT-UNREADABLE-OBJECT macro
 

+;;; guts of PRINT-UNREADABLE-OBJECT

 (defun %print-unreadable-object (object stream type identity body)
   (when *print-readably*
     (error 'print-not-readable :object object))
 (defun %print-unreadable-object (object stream type identity body)
   (when *print-readably*
     (error 'print-not-readable :object object))

-  (write-string "#<" stream)
-  (when type
-    (write (type-of object) :stream stream :circle nil
-          :level nil :length nil)
-    (write-char #\space stream))
-  (when body
-    (funcall body))
-  (when identity
-    (unless (and type (null body))
-      (write-char #\space stream))
-    (write-char #\{ stream)
-    (write (get-lisp-obj-address object) :stream stream
-          :radix nil :base 16)
-    (write-char #\} stream))
-  (write-char #\> stream)
+  (flet ((print-description ()
+          (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)))
+          (when body
+            (funcall body))
+          (when identity
+            (when body
+              (write-char #\space stream)
+              (pprint-newline :fill stream))
+            (write-char #\{ stream)
+            (write (get-lisp-obj-address object) :stream stream
+                   :radix nil :base 16)
+            (write-char #\} stream))))
+    (cond ((print-pretty-on-stream-p stream)
+          ;; Since we're printing prettily on STREAM, format the
+          ;; object within a logical block. PPRINT-LOGICAL-BLOCK does
+          ;; not rebind the stream when it is already a pretty stream,
+          ;; so output from the body will go to the same stream.
+          (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
+            (print-description)))
+         (t
+            (write-string "#<" stream)
+            (print-description)
+            (write-char #\> stream))))

   nil)
 \f
   nil)
 \f

-;;;; WHITESPACE-CHAR-P
-
-;;; This is used in other files, but is defined in this one for some reason.
-
-(defun whitespace-char-p (char)
-  #!+sb-doc
-  "Determines whether or not the character is considered whitespace."
-  (or (char= char #\space)
-      (char= char (code-char tab-char-code))
-      (char= char (code-char return-char-code))
-      (char= char #\linefeed)))
-\f

 ;;;; circularity detection stuff
 
 ;;;; 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.
+;;; 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)
 
 (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.
+;;; 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)
 
 (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. Note: CHECK-FOR-CIRCULARITY must
+;;; be called *EXACTLY* once with ASSIGN T, 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 T, then you must call HANDLE-CIRCULARITY
+;;; on it. If you are not using this inside a WITH-CIRCULARITY-DETECTION,
+;;; then you have to be prepared to handle a return value of :INITIATE which
+;;; means it needs to initiate the circularity detection noise. See the
+;;; source for info on how to do that.

 (defun check-for-circularity (object &optional assign)
 (defun check-for-circularity (object &optional assign)

-  #!+sb-doc
-  "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. Note: CHECK-FOR-CIRCULARITY must
-   be called *EXACTLY* once with ASSIGN T, 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 T, then you must call HANDLE-CIRCULARITY
-   on it. If you are not using this inside a WITH-CIRCULARITY-DETECTION,
-   then you have to be prepared to handle a return value of :INITIATE which
-   means it needs to initiate the circularity detection noise. See the
-   source for info on how to do that."

   (cond ((null *print-circle*)
         ;; Don't bother, nobody cares.
         nil)
   (cond ((null *print-circle*)
         ;; Don't bother, nobody cares.
         nil)

@@ -339,11 +343,10 @@
              ;; Second or later occurance.
              (- value)))))))
 
              ;; Second or later occurance.
              (- 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)
 (defun handle-circularity (marker stream)

-  #!+sb-doc
-  "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."

   (case marker
     (:initiate
      ;; Someone forgot to initiate circularity detection.
   (case marker
     (:initiate
      ;; Someone forgot to initiate circularity detection.

@@ -374,9 +377,8 @@
    arguments (the object and the stream) or NIL to indicate that there is
    no pretty printer installed.")
 
    arguments (the object and the stream) or NIL to indicate that there is
    no pretty printer installed.")
 

+;;; Output OBJECT to STREAM observing all printer control variables.

 (defun output-object (object stream)
 (defun output-object (object stream)

-  #!+sb-doc
-  "Output OBJECT to STREAM observing all printer control variables."

   (labels ((print-it (stream)
             (if *print-pretty*
                 (if *pretty-printer*
   (labels ((print-it (stream)
             (if *print-pretty*
                 (if *pretty-printer*

@@ -402,28 +404,27 @@
               (numberp object)
               (characterp object)
               (and (symbolp object) (symbol-package object) t))
               (numberp object)
               (characterp object)
               (and (symbolp object) (symbol-package object) t))

-          ;; If it a number, character, or interned symbol, we do not want
-          ;; to check for circularity/sharing.
+          ;; If it a number, character, or interned symbol, we do not
+          ;; want to check for circularity/sharing.

           (print-it stream))
          ((or *circularity-hash-table*
               (consp object)
               (typep object 'instance)
               (typep object '(array t *)))
           (print-it stream))
          ((or *circularity-hash-table*
               (consp object)
               (typep object 'instance)
               (typep object '(array t *)))

-          ;; If we have already started circularity detection, this object
-          ;; might be a sharded reference. If we have not, then if it is
-          ;; a cons, a instance, or an array of element type t it might
-          ;; contain a circular reference to itself or multiple shared
-          ;; references.
+          ;; If we have already started circularity detection, this
+          ;; object might be a sharded reference. If we have not,
+          ;; then if it is a cons, a instance, or an array of element
+          ;; type t it might contain a circular reference to itself
+          ;; or multiple shared references.

           (check-it stream))
          (t
           (print-it stream)))))
 
           (check-it stream))
          (t
           (print-it stream)))))
 

+;;; Output OBJECT to STREAM observing all printer control variables
+;;; except for *PRINT-PRETTY*. Note: if *PRINT-PRETTY* is non-NIL,
+;;; then the pretty printer will be used for any components of OBJECT,
+;;; just not for OBJECT itself.

 (defun output-ugly-object (object stream)
 (defun output-ugly-object (object stream)

-  #!+sb-doc
-  "Output OBJECT to STREAM observing all printer control variables except
-   for *PRINT-PRETTY*. Note: if *PRINT-PRETTY* is non-NIL, then the pretty
-   printer will be used for any components of OBJECT, just not for OBJECT
-   itself."

   (typecase object
     ;; KLUDGE: The TYPECASE approach here is non-ANSI; the ANSI definition of
     ;; PRINT-OBJECT says it provides printing and we're supposed to provide
   (typecase object
     ;; KLUDGE: The TYPECASE approach here is non-ANSI; the ANSI definition of
     ;; PRINT-OBJECT says it provides printing and we're supposed to provide

@@ -492,13 +493,13 @@
 \f
 ;;;; symbols
 
 \f
 ;;;; symbols
 

-;;; Values of *PRINT-CASE* and (READTABLE-CASE *READTABLE*) the last time the
-;;; printer was called.
+;;; Values of *PRINT-CASE* and (READTABLE-CASE *READTABLE*) the last
+;;; time the printer was called.

 (defvar *previous-case* nil)
 (defvar *previous-readtable-case* nil)
 
 (defvar *previous-case* nil)
 (defvar *previous-readtable-case* nil)
 

-;;; This variable contains the current definition of one of three symbol
-;;; printers. SETUP-PRINTER-STATE sets this variable.
+;;; This variable contains the current definition of one of three
+;;; symbol printers. SETUP-PRINTER-STATE sets this variable.

 (defvar *internal-symbol-output-function* nil)
 
 ;;; This function sets the internal global symbol
 (defvar *internal-symbol-output-function* nil)
 
 ;;; This function sets the internal global symbol

@@ -578,8 +579,9 @@
        (output-symbol-name name stream))
       (output-symbol-name (symbol-name object) stream nil)))
 
        (output-symbol-name name stream))
       (output-symbol-name (symbol-name object) stream nil)))
 

-;;; Output the string NAME as if it were a symbol name. In other words,
-;;; diddle its case according to *PRINT-CASE* and READTABLE-CASE.
+;;; Output the string NAME as if it were a symbol name. In other
+;;; words, diddle its case according to *PRINT-CASE* and
+;;; READTABLE-CASE.

 (defun output-symbol-name (name stream &optional (maybe-quote t))
   (declare (type simple-base-string name))
   (setup-printer-state)
 (defun output-symbol-name (name stream &optional (maybe-quote t))
   (declare (type simple-base-string name))
   (setup-printer-state)

@@ -598,12 +600,13 @@
 ;;; character has. At characters have at least one bit set, so we can
 ;;; search for any character with a positive test.
 (defvar *character-attributes*
 ;;; 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 :element-type '(unsigned-byte 16)
+  (make-array char-code-limit
+             :element-type '(unsigned-byte 16)

              :initial-element 0))
 (declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit))
               *character-attributes*))
 
              :initial-element 0))
 (declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit))
               *character-attributes*))
 

-;;; Constants which are a bit-mask for each interesting character attribute.
+;;; constants which are a bit-mask for each interesting character attribute

 (defconstant other-attribute           (ash 1 0)) ; Anything else legal.
 (defconstant number-attribute          (ash 1 1)) ; A numeric digit.
 (defconstant uppercase-attribute       (ash 1 2)) ; An uppercase letter.
 (defconstant other-attribute           (ash 1 0)) ; Anything else legal.
 (defconstant number-attribute          (ash 1 1)) ; A numeric digit.
 (defconstant uppercase-attribute       (ash 1 2)) ; An uppercase letter.

@@ -658,8 +661,8 @@
     (when (zerop (aref *character-attributes* i))
       (setf (aref *character-attributes* i) funny-attribute))))
 
     (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.
+;;; 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
              :element-type '(unsigned-byte 8)
 (defvar *digit-bases*
   (make-array char-code-limit
              :element-type '(unsigned-byte 8)

@@ -717,7 +720,7 @@
      TEST-SIGN ; At end, see whether it is a sign...
       (return (not (test sign)))
 
      TEST-SIGN ; At end, see whether it is a sign...
       (return (not (test sign)))
 

-     OTHER ; Not potential number, see whether funny chars...
+     OTHER ; not potential number, see whether funny chars...

       (let ((mask (logxor (logior lowercase-attribute uppercase-attribute
                                  funny-attribute)
                          letter-attribute)))
       (let ((mask (logxor (logior lowercase-attribute uppercase-attribute
                                  funny-attribute)
                          letter-attribute)))

@@ -737,7 +740,7 @@
       (when (test sign extension) (advance START-STUFF nil))
       (return t)
 
       (when (test sign extension) (advance START-STUFF nil))
       (return t)
 

-     DOT-FOUND ; Leading dots...
+     DOT-FOUND ; leading dots...

       (when (test letter) (advance START-DOT-MARKER nil))
       (when (digitp) (advance DOT-DIGIT))
       (when (test number other) (advance OTHER nil))
       (when (test letter) (advance START-DOT-MARKER nil))
       (when (digitp) (advance DOT-DIGIT))
       (when (test number other) (advance OTHER nil))

@@ -745,7 +748,7 @@
       (when (char= current #\.) (advance DOT-FOUND))
       (return t)
 
       (when (char= current #\.) (advance DOT-FOUND))
       (return t)
 

-     START-STUFF ; Leading stuff before any dot or digit.
+     START-STUFF ; leading stuff before any dot or digit

       (when (digitp)
        (if (test letter)
            (advance LAST-DIGIT-ALPHA)
       (when (digitp)
        (if (test letter)
            (advance LAST-DIGIT-ALPHA)

@@ -756,40 +759,40 @@
       (when (test sign extension slash) (advance START-STUFF nil))
       (return t)
 
       (when (test sign extension slash) (advance START-STUFF nil))
       (return t)
 

-     START-MARKER ; Number marker in leading stuff...
+     START-MARKER ; number marker in leading stuff...

       (when (test letter) (advance OTHER nil))
       (go START-STUFF)
 
       (when (test letter) (advance OTHER nil))
       (go START-STUFF)
 

-     START-DOT-STUFF ; Leading stuff containing dot w/o digit...
+     START-DOT-STUFF ; leading stuff containing dot without digit...

       (when (test letter) (advance START-DOT-STUFF nil))
       (when (digitp) (advance DOT-DIGIT))
       (when (test sign extension dot slash) (advance START-DOT-STUFF nil))
       (when (test number other) (advance OTHER nil))
       (return t)
 
       (when (test letter) (advance START-DOT-STUFF nil))
       (when (digitp) (advance DOT-DIGIT))
       (when (test sign extension dot slash) (advance START-DOT-STUFF nil))
       (when (test number other) (advance OTHER nil))
       (return t)
 

-     START-DOT-MARKER ; Number marker in leading stuff w/ dot..
-      ;; Leading stuff containing dot w/o digit followed by letter...
+     START-DOT-MARKER ; number marker in leading stuff with dot..
+      ;; leading stuff containing dot without digit followed by letter...

       (when (test letter) (advance OTHER nil))
       (go START-DOT-STUFF)
 
       (when (test letter) (advance OTHER nil))
       (go START-DOT-STUFF)
 

-     DOT-DIGIT ; In a thing with dots...
+     DOT-DIGIT ; in a thing with dots...

       (when (test letter) (advance DOT-MARKER))
       (when (digitp) (advance DOT-DIGIT))
       (when (test number other) (advance OTHER nil))
       (when (test sign extension dot slash) (advance DOT-DIGIT))
       (return t)
 
       (when (test letter) (advance DOT-MARKER))
       (when (digitp) (advance DOT-DIGIT))
       (when (test number other) (advance OTHER nil))
       (when (test sign extension dot slash) (advance DOT-DIGIT))
       (return t)
 

-     DOT-MARKER ; Number maker in number with dot...
+     DOT-MARKER ; number marker in number with dot...

       (when (test letter) (advance OTHER nil))
       (go DOT-DIGIT)
 
       (when (test letter) (advance OTHER nil))
       (go DOT-DIGIT)
 

-     LAST-DIGIT-ALPHA ; Previous char is a letter digit...
+     LAST-DIGIT-ALPHA ; previous char is a letter digit...

       (when (or (digitp) (test sign slash))
        (advance ALPHA-DIGIT))
       (when (test letter number other dot) (advance OTHER nil))
       (return t)
 
       (when (or (digitp) (test sign slash))
        (advance ALPHA-DIGIT))
       (when (test letter number other dot) (advance OTHER nil))
       (return t)
 

-     ALPHA-DIGIT ; Seen a digit which is a letter...
+     ALPHA-DIGIT ; seen a digit which is a letter...

       (when (or (digitp) (test sign slash))
        (if (test letter)
            (advance LAST-DIGIT-ALPHA)
       (when (or (digitp) (test sign slash))
        (if (test letter)
            (advance LAST-DIGIT-ALPHA)

@@ -798,11 +801,11 @@
       (when (test number other dot) (advance OTHER nil))
       (return t)
 
       (when (test number other dot) (advance OTHER nil))
       (return t)
 

-     ALPHA-MARKER ; Number marker in number with alpha digit...
+     ALPHA-MARKER ; number marker in number with alpha digit...

       (when (test letter) (advance OTHER nil))
       (go ALPHA-DIGIT)
 
       (when (test letter) (advance OTHER nil))
       (go ALPHA-DIGIT)
 

-     DIGIT ; Seen only real numeric digits...
+     DIGIT ; seen only ordinary (non-alphabetic) numeric digits...

       (when (digitp)
        (if (test letter)
            (advance ALPHA-DIGIT)
       (when (digitp)
        (if (test letter)
            (advance ALPHA-DIGIT)

@@ -813,47 +816,47 @@
       (when (char= current #\.) (advance DOT-DIGIT))
       (return t)
 
       (when (char= current #\.) (advance DOT-DIGIT))
       (return t)
 

-     MARKER ; Number marker in a numeric number...
+     MARKER ; number marker in a numeric number...

       (when (test letter) (advance OTHER nil))
       (go DIGIT))))
 \f
 ;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION*
 ;;;;
 ;;;; Case hackery. These functions are stored in
       (when (test letter) (advance OTHER nil))
       (go DIGIT))))
 \f
 ;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION*
 ;;;;
 ;;;; Case hackery. These functions are stored in

-;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* according to the values of *PRINT-CASE*
-;;;; and READTABLE-CASE.
-
-;; Called when:
-;; READTABLE-CASE      *PRINT-CASE*
-;; :UPCASE             :UPCASE
-;; :DOWNCASE           :DOWNCASE
-;; :PRESERVE           any
+;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* according to the values of
+;;;; *PRINT-CASE* and READTABLE-CASE.
+
+;;; called when:
+;;; READTABLE-CASE     *PRINT-CASE*
+;;; :UPCASE            :UPCASE
+;;; :DOWNCASE          :DOWNCASE
+;;; :PRESERVE          any

 (defun output-preserve-symbol (pname stream)
   (declare (simple-string pname))
   (write-string pname stream))
 
 (defun output-preserve-symbol (pname stream)
   (declare (simple-string pname))
   (write-string pname stream))
 

-;; Called when:
-;; READTABLE-CASE      *PRINT-CASE*
-;; :UPCASE             :DOWNCASE
+;;; called when:
+;;; READTABLE-CASE     *PRINT-CASE*
+;;; :UPCASE            :DOWNCASE

 (defun output-lowercase-symbol (pname stream)
   (declare (simple-string pname))
   (dotimes (index (length pname))
     (let ((char (schar pname index)))
       (write-char (char-downcase char) stream))))
 
 (defun output-lowercase-symbol (pname stream)
   (declare (simple-string pname))
   (dotimes (index (length pname))
     (let ((char (schar pname index)))
       (write-char (char-downcase char) stream))))
 

-;; Called when:
-;; READTABLE-CASE      *PRINT-CASE*
-;; :DOWNCASE           :UPCASE
+;;; called when:
+;;; READTABLE-CASE     *PRINT-CASE*
+;;; :DOWNCASE          :UPCASE

 (defun output-uppercase-symbol (pname stream)
   (declare (simple-string pname))
   (dotimes (index (length pname))
     (let ((char (schar pname index)))
       (write-char (char-upcase char) stream))))
 
 (defun output-uppercase-symbol (pname stream)
   (declare (simple-string pname))
   (dotimes (index (length pname))
     (let ((char (schar pname index)))
       (write-char (char-upcase char) stream))))
 

-;; Called when:
-;; READTABLE-CASE      *PRINT-CASE*
-;; :UPCASE             :CAPITALIZE
-;; :DOWNCASE           :CAPITALIZE
+;;; called when:
+;;; READTABLE-CASE     *PRINT-CASE*
+;;; :UPCASE            :CAPITALIZE
+;;; :DOWNCASE          :CAPITALIZE

 (defun output-capitalize-symbol (pname stream)
   (declare (simple-string pname))
   (let ((prev-not-alpha t)
 (defun output-capitalize-symbol (pname stream)
   (declare (simple-string pname))
   (let ((prev-not-alpha t)

@@ -870,9 +873,9 @@
                    stream)
        (setq prev-not-alpha (not (alpha-char-p char)))))))
 
                    stream)
        (setq prev-not-alpha (not (alpha-char-p char)))))))
 

-;; Called when:
-;; READTABLE-CASE      *PRINT-CASE*
-;; :INVERT             any
+;;; called when:
+;;; READTABLE-CASE     *PRINT-CASE*
+;;; :INVERT            any

 (defun output-invert-symbol (pname stream)
   (declare (simple-string pname))
   (let ((all-upper t)
 (defun output-invert-symbol (pname stream)
   (declare (simple-string pname))
   (let ((all-upper t)

@@ -925,7 +928,7 @@
     (let ((length 0)
          (list list))
       (loop
     (let ((length 0)
          (list list))
       (loop

-       (punt-if-too-long length stream)
+       (punt-print-if-too-long length stream)

        (output-object (pop list) stream)
        (unless list
          (return))
        (output-object (pop list) stream)
        (unless list
          (return))

@@ -940,61 +943,63 @@
 (defun output-vector (vector stream)
   (declare (vector vector))
   (cond ((stringp vector)
 (defun output-vector (vector stream)
   (declare (vector vector))
   (cond ((stringp vector)

-        (if (or *print-escape* *print-readably*)
-            (quote-string vector stream)
-            (write-string vector stream)))
+        (cond ((or *print-escape* *print-readably*)
+               (write-char #\" stream)
+               (quote-string vector stream)
+               (write-char #\" stream))
+              (t
+               (write-string vector stream))))

        ((not (or *print-array* *print-readably*))
         (output-terse-array vector stream))
        ((bit-vector-p vector)
         (write-string "#*" stream)
        ((not (or *print-array* *print-readably*))
         (output-terse-array vector stream))
        ((bit-vector-p vector)
         (write-string "#*" stream)

-        (dotimes (i (length vector))
-          (output-object (aref vector i) stream)))
+        (dovector (bit vector)
+          ;; (Don't use OUTPUT-OBJECT here, since this code
+          ;; has to work for all possible *PRINT-BASE* values.)
+          (write-char (if (zerop bit) #\0 #\1) stream)))

        (t
         (when (and *print-readably*
        (t
         (when (and *print-readably*

-                   (not (eq (array-element-type vector) 't)))
+                   (not (eq (array-element-type vector) t)))

           (error 'print-not-readable :object vector))
         (descend-into (stream)
           (error 'print-not-readable :object vector))
         (descend-into (stream)

-          (write-string "#(" stream)
-          (dotimes (i (length vector))
-            (unless (zerop i)
-              (write-char #\space stream))
-            (punt-if-too-long i stream)
-            (output-object (aref vector i) stream))
-          (write-string ")" stream)))))
-
-;;; This function outputs a string quoting characters sufficiently that so
-;;; someone can read it in again. Basically, put a slash in front of an
-;;; character satisfying NEEDS-SLASH-P
+                      (write-string "#(" stream)
+                      (dotimes (i (length vector))
+                        (unless (zerop i)
+                          (write-char #\space stream))
+                        (punt-print-if-too-long i stream)
+                        (output-object (aref vector i) stream))
+                      (write-string ")" stream)))))
+
+;;; This function outputs a string quoting characters sufficiently
+;;; so that someone can read it in again. Basically, put a slash in
+;;; front of an character satisfying NEEDS-SLASH-P.

 (defun quote-string (string stream)
   (macrolet ((needs-slash-p (char)
               ;; KLUDGE: We probably should look at the readtable, but just do
               ;; this for now. [noted by anonymous long ago] -- WHN 19991130
               `(or (char= ,char #\\)
 (defun quote-string (string stream)
   (macrolet ((needs-slash-p (char)
               ;; KLUDGE: We probably should look at the readtable, but just do
               ;; this for now. [noted by anonymous long ago] -- WHN 19991130
               `(or (char= ,char #\\)

-                   (char= ,char #\"))))
-    (write-char #\" stream)
+                 (char= ,char #\"))))

     (with-array-data ((data string) (start) (end (length string)))
       (do ((index start (1+ index)))
          ((>= index end))
        (let ((char (schar data index)))
          (when (needs-slash-p char) (write-char #\\ stream))
     (with-array-data ((data string) (start) (end (length string)))
       (do ((index start (1+ index)))
          ((>= index end))
        (let ((char (schar data index)))
          (when (needs-slash-p char) (write-char #\\ stream))

-         (write-char char stream))))
-    (write-char #\" stream)))
+         (write-char char stream))))))

 
 

+;;; Output the printed representation of any array in either the #< or #A
+;;; form.

 (defun output-array (array stream)
 (defun output-array (array stream)

-  #!+sb-doc
-  "Outputs the printed representation of any array in either the #< or #A
-   form."

   (if (or *print-array* *print-readably*)
       (output-array-guts array stream)
       (output-terse-array array stream)))
 
   (if (or *print-array* *print-readably*)
       (output-array-guts array stream)
       (output-terse-array array stream)))
 

-;;; to output the abbreviated #< form of an array
+;;; Output the abbreviated #< form of an array.

 (defun output-terse-array (array stream)
   (let ((*print-level* nil)
        (*print-length* nil))
     (print-unreadable-object (array stream :type t :identity t))))
 
 (defun output-terse-array (array stream)
   (let ((*print-level* nil)
        (*print-length* nil))
     (print-unreadable-object (array stream :type t :identity t))))
 

-;;; to output the readable #A form of an array
+;;; Output the readable #A form of an array.

 (defun output-array-guts (array stream)
   (when (and *print-readably*
             (not (eq (array-element-type array) t)))
 (defun output-array-guts (array stream)
   (when (and *print-readably*
             (not (eq (array-element-type array) t)))

@@ -1020,13 +1025,13 @@
             (dotimes (i dimension)
               (unless (zerop i)
                 (write-char #\space stream))
             (dotimes (i dimension)
               (unless (zerop i)
                 (write-char #\space stream))

-              (punt-if-too-long i stream)
+              (punt-print-if-too-long i stream)

               (sub-output-array-guts array dimensions stream index)
               (incf index count)))
           (write-char #\) stream)))))
 
               (sub-output-array-guts array dimensions stream index)
               (incf index count)))
           (write-char #\) stream)))))
 

-;;; a trivial non-generic-function placeholder for PRINT-OBJECT, for use
-;;; until CLOS is set up (at which time it will be replaced with
+;;; a trivial non-generic-function placeholder for PRINT-OBJECT, for
+;;; use until CLOS is set up (at which time it will be replaced with

 ;;; the real generic function implementation)
 (defun print-object (instance stream)
   (default-structure-print instance stream *current-level*))
 ;;; the real generic function implementation)
 (defun print-object (instance stream)
   (default-structure-print instance stream *current-level*))

@@ -1084,24 +1089,20 @@
                stream)))
 \f
 ;;;; bignum printing
                stream)))
 \f
 ;;;; bignum printing

-;;;;
-;;;; written by Steven Handerson (based on Skef's idea)
-;;;;
-;;;; rewritten to remove assumptions about the length of fixnums for the
-;;;; MIPS port by William Lott

 
 

-;;; *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*)).
+;;; *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))
 
 (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*.
+;;; *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))
 
 (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.
+;;; 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))
 (defun print-bignum (big stream)
   (unless (aref *base-power* *print-base*)
     (do ((power-1 -1 (1+ power-1))

@@ -1152,14 +1153,12 @@
   (write-char #\) stream))
 \f
 ;;;; float printing
   (write-char #\) stream))
 \f
 ;;;; float printing

-;;;;
-;;;; written by Bill Maddox

 
 

-;;; 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:
+;;; 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:

 ;;;
 ;;;     X      - The floating point number to convert, which must not be
 ;;;            negative.
 ;;;
 ;;;     X      - The floating point number to convert, which must not be
 ;;;            negative.

@@ -1201,22 +1200,23 @@
 ;;;     POINT-POS       - The position of the digit preceding the decimal
 ;;;                   point. Zero indicates point before first digit.
 ;;;
 ;;;     POINT-POS       - The position of the digit preceding the decimal
 ;;;                   point. Zero indicates point before first digit.
 ;;;

-;;; NOTE:  FLONUM-TO-STRING goes to a lot of trouble to guarantee accuracy.
-;;; Specifically, the decimal number printed is the closest possible
-;;; approximation to the true value of the binary number to be printed from
-;;; among all decimal representations  with the same number of digits. In
-;;; free-format output, i.e. with the number of digits unconstrained, it is
-;;; guaranteed that all the information is preserved, so that a properly-
-;;; rounding reader can reconstruct the original binary number, bit-for-bit,
-;;; from its printed decimal representation. Furthermore, only as many digits
-;;; as necessary to satisfy this condition will be printed.
+;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee
+;;; accuracy. Specifically, the decimal number printed is the closest
+;;; possible approximation to the true value of the binary number to
+;;; be printed from among all decimal representations with the same
+;;; number of digits. In free-format output, i.e. with the number of
+;;; digits unconstrained, it is guaranteed that all the information is
+;;; preserved, so that a properly- rounding reader can reconstruct the
+;;; original binary number, bit-for-bit, from its printed decimal
+;;; 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!
+;;; 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")
 
 
 (defvar *digits* "0123456789")
 

@@ -1245,19 +1245,20 @@
                                  :fill-pointer 0
                                  :adjustable t)))
     ;; Represent fraction as r/s, error bounds as m+/s and m-/s.
                                  :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.
+    ;; 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)))))
     (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
+    ;; 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)))
     (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
+    ;; Scale value by requested amount, and update error bounds.

     (when scale
       (if (minusp scale)
          (let ((scale-factor (expt 10 (- scale))))
     (when scale
       (if (minusp scale)
          (let ((scale-factor (expt 10 (- scale))))

@@ -1266,7 +1267,7 @@
            (setq r (* r scale-factor))
            (setq m+ (* m+ scale-factor))
            (setq m- (* m- scale-factor)))))
            (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
+    ;; Scale r and s and compute initial k, the base 10 logarithm of r.

     (do ()
        ((>= r (ceiling s 10)))
       (decf k)
     (do ()
        ((>= r (ceiling s 10)))
       (decf k)

@@ -1278,24 +1279,25 @@
          ((< (+ (ash r 1) m+) (ash s 1)))
        (setq s (* s 10))
        (incf k))
          ((< (+ (ash r 1) m+) (ash s 1)))
        (setq s (* s 10))
        (incf k))

-      ;;determine number of fraction digits to generate
+      ;; Determine number of fraction digits to generate.

       (cond (fdigits
       (cond (fdigits

-            ;;use specified number of fraction digits
+            ;; 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
             (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
+            ;; 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 (< 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.
+      ;; 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))
       (when (or fdigits width)
        (let ((a (- cutoff k))
              (y s))

@@ -1306,13 +1308,13 @@
          (setq m+ (max y m+))
          (when (= m+ y) (setq roundup t))))
       (when (< (+ (ash r 1) m+) (ash s 1)) (return)))
          (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
+    ;; 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)))
     (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
+    ;; Generate the significant digits.

     (do ()(nil)
       (decf k)
       (when (= k -1)
     (do ()(nil)
       (decf k)
       (when (= k -1)

@@ -1325,45 +1327,46 @@
       (if roundup
          (setq high (>= (ash r 1) (- (ash s 1) m+)))
          (setq high (> (ash r 1) (- (ash s 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
+      ;; 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))
       (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
+      ;; 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))
       (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
+    ;; 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))
     (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
+    ;; Add trailing zeroes to pad fraction if fdigits specified.

     (when fdigits
       (dotimes (i (- fdigits (- digits decpnt)))
        (incf digits)
        (vector-push-extend #\0 digit-string)))
     (when fdigits
       (dotimes (i (- fdigits (- digits decpnt)))
        (incf digits)
        (vector-push-extend #\0 digit-string)))

-    ;;all done
+    ;; all done

     (values digit-string (1+ digits) (= decpnt 0) (= decpnt digits) decpnt)))
 
     (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 an 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.
+;;; 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
+;;; 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.
+;;; 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)
 (defun scale-exponent (original-x)
   (let* ((x (coerce original-x 'long-float)))
     (multiple-value-bind (sig exponent) (decode-float x)

@@ -1391,19 +1394,20 @@
 \f
 ;;;; entry point for the float printer
 
 \f
 ;;;; entry point for the float printer
 

-;;; Entry point for the float printer as called by PRINT, PRIN1, PRINC,
-;;; etc. The argument is printed free-format, in either exponential or
+;;; the float printer as called by PRINT, PRIN1, PRINC, etc. The
+;;; argument is printed free-format, in either exponential or

 ;;; non-exponential notation, depending on its magnitude.
 ;;;
 ;;; non-exponential notation, depending on its magnitude.
 ;;;

-;;; NOTE: When a number is to be printed in exponential format, it is scaled in
-;;; floating point. Since precision may be lost in this process, the
-;;; guaranteed accuracy properties of FLONUM-TO-STRING are lost. The
-;;; difficulty is that FLONUM-TO-STRING performs extensive computations with
-;;; integers of similar magnitude to that of the number being printed. For
-;;; large exponents, the bignums really get out of hand. If bignum arithmetic
-;;; becomes reasonably fast and the exponent range is not too large, then it
-;;; might become attractive to handle exponential notation with the same
-;;; accuracy as non-exponential notation, using the method described in the
+;;; NOTE: When a number is to be printed in exponential format, it is
+;;; scaled in floating point. Since precision may be lost in this
+;;; process, the guaranteed accuracy properties of FLONUM-TO-STRING
+;;; are lost. The difficulty is that FLONUM-TO-STRING performs
+;;; extensive computations with integers of similar magnitude to that
+;;; of the number being printed. For large exponents, the bignums
+;;; really get out of hand. If bignum arithmetic becomes reasonably
+;;; fast and the exponent range is not too large, then it might become
+;;; attractive to handle exponential notation with the same accuracy
+;;; as non-exponential notation, using the method described in the

 ;;; Steele and White paper.
 
 ;;; Print the appropriate exponent marker for X and the specified exponent.
 ;;; Steele and White paper.
 
 ;;; Print the appropriate exponent marker for X and the specified exponent.

@@ -1422,26 +1426,22 @@
                  (long-float #\L))
                plusp exp))))
 
                  (long-float #\L))
                plusp exp))))
 

-;;;    Write out an infinity using #. notation, or flame out if
-;;; *print-readably* is true and *read-eval* is false.
-#!+sb-infinities

 (defun output-float-infinity (x stream)
 (defun output-float-infinity (x stream)

-  (declare (type float x) (type stream stream))
+  (declare (float x) (stream stream))

   (cond (*read-eval*
   (cond (*read-eval*

-        (write-string "#." stream))
-       (*print-readably*
-        (error 'print-not-readable :object x))
-       (t
-        (write-string "#<" stream)))
-  (write-string "EXT:" stream)
-  (princ (float-format-name x) stream)
+         (write-string "#." stream))
+        (*print-readably*
+         (error 'print-not-readable :object x))
+        (t
+         (write-string "#<" stream)))
+  (write-string "SB-EXT:" stream)
+  (write-string (symbol-name (float-format-name x)) stream)

   (write-string (if (plusp x) "-POSITIVE-" "-NEGATIVE-")
   (write-string (if (plusp x) "-POSITIVE-" "-NEGATIVE-")

-               stream)
+                stream)

   (write-string "INFINITY" stream)
   (unless *read-eval*
     (write-string ">" stream)))
 
   (write-string "INFINITY" stream)
   (unless *read-eval*
     (write-string ">" stream)))
 

-;;; Output a #< NaN or die trying.

 (defun output-float-nan (x stream)
   (print-unreadable-object (x stream)
     (princ (float-format-name x) stream)
 (defun output-float-nan (x stream)
   (print-unreadable-object (x stream)
     (princ (float-format-name x) stream)

@@ -1489,14 +1489,14 @@
 \f
 ;;;; other leaf objects
 
 \f
 ;;;; other leaf objects
 

-;;; If *PRINT-ESCAPE* is false, just do a WRITE-CHAR, otherwise output the
-;;; character name or the character in the #\char format.
+;;; If *PRINT-ESCAPE* is false, just do a WRITE-CHAR, otherwise output
+;;; the character name or the character in the #\char format.

 (defun output-character (char stream)
   (if (or *print-escape* *print-readably*)
       (let ((name (char-name char)))
        (write-string "#\\" stream)
        (if name
 (defun output-character (char stream)
   (if (or *print-escape* *print-readably*)
       (let ((name (char-name char)))
        (write-string "#\\" stream)
        (if name

-           (write-string name stream)
+           (quote-string name stream)

            (write-char char stream)))
       (write-char char stream)))
 
            (write-char char stream)))
       (write-char char stream)))