0.pre7.124:
[sbcl.git] / src / code / print.lisp
index 22281e5..ad0e294 100644 (file)
   *PRINT-ESCAPE*.")
 (defvar *print-escape* T
   #!+sb-doc
-  "Flag which indicates that slashification is on. See the manual")
+  "Should we print in a reasonably machine-readable way? (possibly
+  overridden by *PRINT-READABLY*)")
 (defvar *print-pretty* nil ; (set later when pretty-printer is initialized)
   #!+sb-doc
-  "Flag which indicates that pretty printing is to be used")
+  "Should pretty printing be used?")
 (defvar *print-base* 10.
   #!+sb-doc
-  "The output base for integers and rationals.")
+  "the output base for RATIONALs (including integers)")
 (defvar *print-radix* nil
   #!+sb-doc
-  "This flag requests to verify base when printing rationals.")
+  "Should base be verified when printing RATIONALs?")
 (defvar *print-level* nil
   #!+sb-doc
-  "How many levels deep to print. Unlimited if null.")
+  "How many levels should be printed before abbreviating with \"#\"?")
 (defvar *print-length* nil
   #!+sb-doc
-  "How many elements to print on each level. Unlimited if null.")
+  "How many elements at any level should be printed before abbreviating
+  with \"...\"?")
 (defvar *print-circle* nil
   #!+sb-doc
-  "Whether to worry about circular list structures. See the manual.")
+  "Should we use #n= and #n# notation to preserve uniqueness in general (and
+  circularity in particular) when printing?")
 (defvar *print-case* :upcase
   #!+sb-doc
-  "What kind of case the printer should use by default")
+  "What case should the printer should use default?")
 (defvar *print-array* t
   #!+sb-doc
-  "Whether the array should print its guts out")
+  "Should the contents of arrays be printed?")
 (defvar *print-gensym* t
   #!+sb-doc
-  "If true, symbols with no home package are printed with a #: prefix.
-  If false, no prefix is printed.")
+  "Should #: prefixes be used when printing symbols with null SYMBOL-PACKAGE?")
 (defvar *print-lines* nil
   #!+sb-doc
-  "The maximum number of lines to print. If NIL, unlimited.")
+  "the maximum number of lines to print per object")
 (defvar *print-right-margin* nil
   #!+sb-doc
-  "The position of the right margin in ems. If NIL, try to determine this
-   from the stream in use.")
+  "the position of the right margin in ems (for pretty-printing)")
 (defvar *print-miser-width* nil
   #!+sb-doc
   "If the remaining space between the current column and the right margin
@@ -67,8 +68,7 @@
    turned off. If NIL, never use miser mode.")
 (defvar *print-pprint-dispatch* nil
   #!+sb-doc
-  "The pprint-dispatch-table that controls how to pretty print objects. See
-   COPY-PPRINT-DISPATH, PPRINT-DISPATCH, and SET-PPRINT-DISPATCH.")
+  "the pprint-dispatch-table that controls how to pretty-print objects")
 
 (defmacro with-standard-io-syntax (&body body)
   #!+sb-doc
@@ -93,8 +93,8 @@
        *READ-DEFAULT-FLOAT-FORMAT*     SINGLE-FLOAT
        *READ-EVAL*                     T
        *READ-SUPPRESS*                 NIL
-       *READTABLE*                     the standard readtable."
-  `(%with-standard-io-syntax #'(lambda () ,@body)))
+       *READTABLE*                     the standard readtable"
+  `(%with-standard-io-syntax (lambda () ,@body)))
 
 (defun %with-standard-io-syntax (function)
   (let ((*package* (find-package "COMMON-LISP-USER"))
                     ((: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
-  "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)))
 
 (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))
 
 (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)
 
 (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)))
               ((: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
-  "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
-  "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))
 
             (write-char #\> stream))))
   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
 
 ;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that
 ;;; marker, it is incremented.
 (defvar *circularity-counter* nil)
 
+;;; Check to see whether OBJECT is a circular reference, and return
+;;; something non-NIL if it is. If ASSIGN is T, then the number to use
+;;; in the #n= and #n# noise is assigned at this time.
+;;; If ASSIGN is true, reference bookkeeping will only be done for
+;;; existing entries, no new references will be recorded!
+;;;
+;;; Note: CHECK-FOR-CIRCULARITY must be called *exactly* once with
+;;; ASSIGN true, or the circularity detection noise will get confused
+;;; about when to use #n= and when to use #n#. If this returns non-NIL
+;;; when ASSIGN is true, then you must call HANDLE-CIRCULARITY on it.
+;;; If CHECK-FOR-CIRCULARITY returns :INITIATE as the second value,
+;;; you need to initiate the circularity detection noise, e.g. bind
+;;; *CIRCULARITY-HASH-TABLE* and *CIRCULARITY-COUNTER* to suitable values
+;;; (see #'OUTPUT-OBJECT for an example).
 (defun check-for-circularity (object &optional assign)
-  #!+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)
        ((null *circularity-hash-table*)
-        :initiate)
+          (values nil :initiate))
        ((null *circularity-counter*)
         (ecase (gethash object *circularity-hash-table*)
           ((nil)
-           ;; First encounter.
+           ;; first encounter
            (setf (gethash object *circularity-hash-table*) t)
            ;; We need to keep looking.
            nil)
           ((t)
-           ;; Second encounter.
+           ;; second encounter
            (setf (gethash object *circularity-hash-table*) 0)
            ;; It's a circular reference.
            t)
         (let ((value (gethash object *circularity-hash-table*)))
           (case value
             ((nil t)
-             ;; If NIL, we found an object that wasn't there the first time
-             ;; around. If T, exactly one occurance of this object appears.
-             ;; Either way, just print the thing without any special
-             ;; processing. Note: you might argue that finding a new object
-             ;; means that something is broken, but this can happen. If
-             ;; someone uses the ~@<...~:> format directive, it conses a
-             ;; new list each time though format (i.e. the &REST list), so
-             ;; we will have different cdrs.
+             ;; If NIL, we found an object that wasn't there the
+             ;; first time around. If T, this object appears exactly
+             ;; once. Either way, just print the thing without any
+             ;; special processing. Note: you might argue that
+             ;; finding a new object means that something is broken,
+             ;; but this can happen. If someone uses the ~@<...~:>
+             ;; format directive, it conses a new list each time
+             ;; though format (i.e. the &REST list), so we will have
+             ;; different cdrs.
              nil)
             (0
              (if assign
                  (let ((value (incf *circularity-counter*)))
-                   ;; First occurance of this object. Set the counter.
+                   ;; first occurrence of this object: Set the counter.
                    (setf (gethash object *circularity-hash-table*) value)
                    value)
                  t))
             (t
-             ;; Second or later occurance.
+             ;; second or later occurrence
              (- value)))))))
 
+;;; Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then
+;;; you should go ahead and print the object. If it returns NIL, then
+;;; you should blow it off.
 (defun handle-circularity (marker stream)
-  #!+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.
 \f
 ;;;; OUTPUT-OBJECT -- the main entry point
 
-(defvar *pretty-printer* nil
-  #!+sb-doc
-  "The current pretty printer. Should be either a function that takes two
-   arguments (the object and the stream) or NIL to indicate that there is
-   no pretty printer installed.")
+;;; the current pretty printer. This should be either a function that
+;;; takes two arguments (the object and the stream) or NIL to indicate
+;;; that there is no pretty printer installed.
+(defvar *pretty-printer* nil)
 
+;;; Objects whose print representation identifies them EQLly don't
+;;; need to be checked for circularity.
+(defun uniquely-identified-by-print-p (x)
+  (or (numberp x)
+      (characterp x)
+      (and (symbolp x)
+          (symbol-package x))))
+
+;;; Output OBJECT to STREAM observing all printer control variables.
 (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*
                       (output-ugly-object object stream)))
                 (output-ugly-object object stream)))
           (check-it (stream)
-            (let ((marker (check-for-circularity object t)))
-              (case marker
-                (:initiate
-                 (let ((*circularity-hash-table*
+             (multiple-value-bind (marker initiate)
+                 (check-for-circularity object t)
+               ;; initialization of the circulation detect noise ...
+              (if (eq initiate :initiate)
+                 (let ((*circularity-hash-table*
                         (make-hash-table :test 'eq)))
-                   (check-it (make-broadcast-stream))
-                   (let ((*circularity-counter* 0))
-                     (check-it stream))))
-                ((nil)
-                 (print-it stream))
-                (t
-                 (when (handle-circularity marker stream)
-                   (print-it stream)))))))
-    (cond ((or (not *print-circle*)
-              (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.
+                   (check-it (make-broadcast-stream))
+                   (let ((*circularity-counter* 0))
+                     (check-it stream)))
+                 ;; otherwise
+                 (if marker
+                   (when (handle-circularity marker stream)
+                     (print-it stream))
+                   (print-it stream))))))
+    (cond (;; Maybe we don't need to bother with circularity detection.
+          (or (not *print-circle*)
+              (uniquely-identified-by-print-p object))
           (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 shared reference. If we have not, then
+          ;; if it is a compound object it might contain a circular
+          ;; reference to itself or multiple shared references.
+          (or *circularity-hash-table*
+              (compound-object-p object))
           (check-it stream))
          (t
           (print-it stream)))))
 
+;;; a hack to work around recurring gotchas with printing while
+;;; DEFGENERIC PRINT-OBJECT is being built
+;;;
+;;; (hopefully will go away naturally when CLOS moves into cold init)
+(defvar *print-object-is-disabled-p*)
+
+;;; 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)
-  #!+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
     ;;       a method on an external symbol in the CL package which is
     ;;       applicable to arg lists containing only direct instances of
     ;;       standardized classes.
-    ;; Thus, in order for the user to detect our sleaziness, he has to do
-    ;; something relatively obscure like
+    ;; Thus, in order for the user to detect our sleaziness in conforming
+    ;; code, he has to do something relatively obscure like
     ;;   (1) actually use tools like FIND-METHOD to look for PRINT-OBJECT
     ;;       methods, or
     ;;   (2) define a PRINT-OBJECT method which is specialized on the stream
     ;;       value (e.g. a Gray stream object).
     ;; 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 20000121
+    ;; priority. -- WHN 2001-11-25
     (fixnum
      (output-integer object stream))
     (list
         (output-symbol object stream)
         (output-list object stream)))
     (instance
-     (print-object object stream))
+     (cond ((not (and (boundp '*print-object-is-disabled-p*)
+                     *print-object-is-disabled-p*))
+           (print-object object stream))
+          ((typep object 'structure-object)
+           (default-structure-print object stream *current-level*))
+          (t
+           (write-string "#<INSTANCE but not STRUCTURE-OBJECT>" stream))))
     (function
      (unless (and (funcallable-instance-p object)
                  (printed-as-funcallable-standard-class object stream))
 \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)
 
 (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.
       (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)
 
-     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)
 
        (output-object (pop list) stream)
        (unless list
          (return))
-       (when (or (atom list) (check-for-circularity list))
+       (when (or (atom list)
+                  (check-for-circularity list))
          (write-string " . " stream)
          (output-object list stream)
          (return))
         (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*
                    (not (eq (array-element-type vector) t)))
                       (write-string ")" stream)))))
 
 ;;; This function outputs a string quoting characters sufficiently
-;;; that so someone can read it in again. Basically, put a slash in
+;;; 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)
          (when (needs-slash-p char) (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)
-  #!+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)))
 
-;;; 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))))
 
-;;; 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-function (object stream)
   (let* ((*print-length* 3) ; in case we have to..
         (*print-level* 3)  ; ..print an interpreted function definition
-        (name (cond ((find (function-subtype object)
-                           #(#.sb!vm:closure-header-type
-                             #.sb!vm:byte-code-closure-type))
-                     "CLOSURE")
-                    ((sb!eval::interpreted-function-p object)
-                     (or (sb!eval::interpreted-function-%name object)
-                         (sb!eval:interpreted-function-lambda-expression
-                          object)))
-                    ((find (function-subtype object)
-                           #(#.sb!vm:function-header-type
-                             #.sb!vm:closure-function-header-type))
-                     (%function-name object))
-                    (t 'no-name-available)))
+        ;; FIXME: This find-the-function-name idiom ought to be
+        ;; encapsulated in a function somewhere.
+        (name (case (function-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))))
 
 (defun output-random (object stream)
   (print-unreadable-object (object stream :identity t)
-    (let ((lowtag (get-lowtag object)))
+    (let ((lowtag (lowtag-of object)))
       (case lowtag
-       (#.sb!vm:other-pointer-type
-         (let ((type (get-type object)))
-           (case type
-             (#.sb!vm:value-cell-header-type
+       (#.sb!vm:other-pointer-lowtag
+         (let ((widetag (widetag-of object)))
+           (case widetag
+             (#.sb!vm:value-cell-header-widetag
               (write-string "value cell " stream)
-              (output-object (sb!c:value-cell-ref object) stream))
+              (output-object (value-cell-ref object) stream))
              (t
-              (write-string "unknown pointer object, type=" stream)
+              (write-string "unknown pointer object, widetag=" stream)
               (let ((*print-base* 16) (*print-radix* t))
-                (output-integer type stream))))))
-       ((#.sb!vm:function-pointer-type
-         #.sb!vm:instance-pointer-type
-         #.sb!vm:list-pointer-type)
-        (write-string "unknown pointer object, type=" stream))
+                (output-integer widetag stream))))))
+       ((#.sb!vm:fun-pointer-lowtag
+         #.sb!vm:instance-pointer-lowtag
+         #.sb!vm:list-pointer-lowtag)
+        (write-string "unknown pointer object, lowtag=" stream)
+        (let ((*print-base* 16) (*print-radix* t))
+          (output-integer lowtag stream)))
        (t
-        (case (get-type object)
-          (#.sb!vm:unbound-marker-type
+        (case (widetag-of object)
+          (#.sb!vm:unbound-marker-widetag
            (write-string "unbound marker" stream))
           (t
            (write-string "unknown immediate object, lowtag=" stream)
            (let ((*print-base* 2) (*print-radix* t))
              (output-integer lowtag stream))
-           (write-string ", type=" stream)
+           (write-string ", widetag=" stream)
            (let ((*print-base* 16) (*print-radix* t))
-             (output-integer (get-type object) stream)))))))))
+             (output-integer (widetag-of object) stream)))))))))