0.pre7.90:

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

diff --git a/src/code/print.lisp b/src/code/print.lisp
index 9cb85d1..b3a74a5 100644 (file)
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -378,6 +378,14 @@
 ;;; 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)
   (labels ((print-it (stream)
@@ -401,27 +409,26 @@
                 (t
                  (when (handle-circularity marker stream)
                    (print-it stream)))))))
-    (cond ((or (not *print-circle*)
-              (numberp object)
-              (characterp object)
-              (and (symbolp object)
-                   (symbol-package object)))
-          ;; If it's a number, character, or interned symbol, we
-          ;; don't want to check for circularity/sharing.
+    (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
+         (;; If we have already started circularity detection, this
           ;; object might be a shared reference. If we have not, then
-          ;; if it is a cons, an instance, or an array of element
-          ;; type T it might contain a circular reference to itself
-          ;; or multiple shared references.
+          ;; 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,
@@ -439,15 +446,15 @@
     ;;       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
@@ -455,7 +462,13 @@
         (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))
@@ -495,8 +508,8 @@
 \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)