0.pre7.124:
[sbcl.git] / src / code / print.lisp
index 92d66f9..ad0e294 100644 (file)
@@ -94,7 +94,7 @@
        *READ-EVAL*                     T
        *READ-SUPPRESS*                 NIL
        *READTABLE*                     the standard readtable"
-  `(%with-standard-io-syntax #'(lambda () ,@body)))
+  `(%with-standard-io-syntax (lambda () ,@body)))
 
 (defun %with-standard-io-syntax (function)
   (let ((*package* (find-package "COMMON-LISP-USER"))
 ;;; 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 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.
+;;; 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)
   (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)
 
 ;;; Output OBJECT to STREAM observing all printer control variables.
 (defun output-object (object stream)
-  (/show0 "entering OUTPUT-OBJECT")
   (labels ((print-it (stream)
-            (/show0 "entering PRINT-IT in OUTPUT-OBJECT")
             (if *print-pretty*
                 (if *pretty-printer*
                     (funcall *pretty-printer* object stream)
                       (output-ugly-object object stream)))
                 (output-ugly-object object stream)))
           (check-it (stream)
-            (/show0 "entering CHECK-IT")
-            (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)))))))
+                   (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))
-          (/show0 "in obviously-don't-bother case")
           (print-it stream))
          (;; If we have already started circularity detection, this
           ;; object might be a shared reference. If we have not, then
           ;; reference to itself or multiple shared references.
           (or *circularity-hash-table*
               (compound-object-p object))
-          (/show0 "in CHECK-IT case")
           (check-it stream))
          (t
-          (/show0 "in don't-bother-after-all case")
           (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)
-  (/show0 "entering OUTPUT-UGLY-OBJECT")
   (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
-     (/show0 "in PRINT-OBJECT case")
-     (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))
     (fdefn
      (output-fdefn object stream))
     (t
-     (/show0 "in OUTPUT-RANDOM case")
      (output-random 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)
 
        (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))
 ;;; use until CLOS is set up (at which time it will be replaced with
 ;;; the real generic function implementation)
 (defun print-object (instance stream)
-  (/show0 "in pre-CLOS PRINT-OBJECT placeholder")
   (default-structure-print instance stream *current-level*))
 \f
 ;;;; integer, ratio, and complex printing (i.e. everything but floats)