;;; 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
(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 for debugging
-#!+sb-show
+;;; 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
;;; 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")
- #!-sb-show
- (print-object object stream)
-
- ;; After being bitten several times by the difficulty of
- ;; debugging problems around DEFGENERIC PRINT-OBJECT when the old
- ;; placeholder printer is disabled by FMAKUNBOUND 'PRINT-OBJECT
- ;; and/or DEFGENERIC has already executed but DEFMETHODs haven't,
- ;; I added this workaround to allow output during that
- ;; interval... -- WHN 2001-11-25
- #!+sb-show
(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>"))))
+ (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)
;;; 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)
(write-char #\space stream)
(pprint-newline :linear stream))))))))
(defun %default-structure-ugly-print (structure stream)
- (/show0 "entering %DEFAULT-STRUCTURE-UGLY-PRINT")
(let* ((layout (%instance-layout structure))
(name (sb!xc:class-name (layout-class layout)))
(dd (layout-info layout)))
- (/show0 "got LAYOUT, NAME, and DD")
(descend-into (stream)
(write-string "#S(" stream)
(prin1 name stream)
stream))))))
(defun default-structure-print (structure stream depth)
(declare (ignore depth))
- (/show0 "entering DEFAULT-STRUCTURE-PRINT")
(cond ((funcallable-instance-p structure)
- (/show0 "in FUNCALLABLE-INSTANCE-P case")
(print-unreadable-object (structure stream :identity t :type t)))
(*print-pretty*
- (/show0 "in *PRINT-PRETTY* case")
(%default-structure-pretty-print structure stream))
(t
- (/show0 "in ugly-print case")
(%default-structure-ugly-print structure stream))))
(def!method print-object ((x structure-object) stream)
(default-structure-print x stream *current-level*))
projects / sbcl.git / commitdiff