src/code/early-print.lisp

   1 ;;;; printer stuff which has to be defined early (e.g. DEFMACROs)
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!IMPL")
  13 \f
  14 ;;;; level and length abbreviations
  15
  16 ;;; The current level we are printing at, to be compared against
  17 ;;; *PRINT-LEVEL*. See the macro DESCEND-INTO for a handy interface to
  18 ;;; depth abbreviation.
  19 (declaim (index *current-level-in-print*))
  20 (!defvar *current-level-in-print* 0)
  21
  22 ;;; Automatically handle *PRINT-LEVEL* abbreviation. If we are too
  23 ;;; deep, then a #\# is printed to STREAM and BODY is ignored.
  24 (defmacro descend-into ((stream) &body body)
  25   (let ((flet-name (sb!xc:gensym "DESCEND")))
  26     `(flet ((,flet-name ()
  27               ,@body))
  28        (cond ((and (null *print-readably*)
  29                    (let ((level *print-level*))
  30                      (and level (>= *current-level-in-print* level))))
  31               (write-char #\# ,stream))
  32              (t
  33               (let ((*current-level-in-print* (1+ *current-level-in-print*)))
  34                 (,flet-name)))))))
  35
  36 ;;; Punt if INDEX is equal or larger then *PRINT-LENGTH* (and
  37 ;;; *PRINT-READABLY* is NIL) by outputting \"...\" and returning from
  38 ;;; the block named NIL.
  39 (defmacro punt-print-if-too-long (index stream)
  40   `(when (and (not *print-readably*)
  41               (let ((len *print-length*))
  42                 (and len (>= ,index len))))
  43      (write-string "..." ,stream)
  44      (return)))
  45
  46 \f
  47 ;;;; circularity detection stuff
  48
  49 ;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that
  50 ;;; (eventually) ends up with entries for every object printed. When
  51 ;;; we are initially looking for circularities, we enter a T when we
  52 ;;; find an object for the first time, and a 0 when we encounter an
  53 ;;; object a second time around. When we are actually printing, the 0
  54 ;;; entries get changed to the actual marker value when they are first
  55 ;;; printed.
  56 (defvar *circularity-hash-table* nil)
  57
  58 ;;; When NIL, we are just looking for circularities. After we have
  59 ;;; found them all, this gets bound to 0. Then whenever we need a new
  60 ;;; marker, it is incremented.
  61 (defvar *circularity-counter* nil)
  62
  63 ;;; Check to see whether OBJECT is a circular reference, and return
  64 ;;; something non-NIL if it is. If ASSIGN is true, reference
  65 ;;; bookkeeping will only be done for existing entries, no new
  66 ;;; references will be recorded. If ASSIGN is true, then the number to
  67 ;;; use in the #n= and #n# noise is assigned at this time.
  68 ;;;
  69 ;;; Note: CHECK-FOR-CIRCULARITY must be called *exactly* once with
  70 ;;; ASSIGN true, or the circularity detection noise will get confused
  71 ;;; about when to use #n= and when to use #n#. If this returns non-NIL
  72 ;;; when ASSIGN is true, then you must call HANDLE-CIRCULARITY on it.
  73 ;;; If CHECK-FOR-CIRCULARITY returns :INITIATE as the second value,
  74 ;;; you need to initiate the circularity detection noise, e.g. bind
  75 ;;; *CIRCULARITY-HASH-TABLE* and *CIRCULARITY-COUNTER* to suitable values
  76 ;;; (see #'OUTPUT-OBJECT for an example).
  77 ;;;
  78 ;;; Circularity detection is done in two places, OUTPUT-OBJECT and
  79 ;;; WITH-CIRCULARITY-DETECTION (which is used from PPRINT-LOGICAL-BLOCK).
  80 ;;; These checks aren't really redundant (at least I can't really see
  81 ;;; a clean way of getting by with the checks in only one of the places).
  82 ;;; This causes problems when mixed with pprint-dispatching; an object is
  83 ;;; marked as visited in OUTPUT-OBJECT, dispatched to a pretty printer
  84 ;;; that uses PPRINT-LOGICAL-BLOCK (directly or indirectly), leading to
  85 ;;; output like #1=#1#. The MODE parameter is used for detecting and
  86 ;;; correcting this problem.
  87 (defun check-for-circularity (object &optional assign (mode t))
  88   (when (null *print-circle*)
  89          ;; Don't bother, nobody cares.
  90     (return-from check-for-circularity nil))
  91   (let ((circularity-hash-table *circularity-hash-table*))
  92     (cond
  93         ((null circularity-hash-table)
  94           (values nil :initiate))
  95         ((null *circularity-counter*)
  96          (ecase (gethash object circularity-hash-table)
  97            ((nil)
  98             ;; first encounter
  99             (setf (gethash object circularity-hash-table) mode)
 100             ;; We need to keep looking.
 101             nil)
 102            ((:logical-block)
 103             (setf (gethash object circularity-hash-table)
 104                   :logical-block-circular)
 105             t)
 106            ((t)
 107             (cond ((eq mode :logical-block)
 108                    ;; We've seen the object before in output-object, and now
 109                    ;; a second time in a PPRINT-LOGICAL-BLOCK (for example
 110                    ;; via pprint-dispatch). Don't mark it as circular yet.
 111                    (setf (gethash object circularity-hash-table)
 112                          :logical-block)
 113                    nil)
 114                   (t
 115                    ;; second encounter
 116                    (setf (gethash object circularity-hash-table) 0)
 117                    ;; It's a circular reference.
 118                    t)))
 119            ((0 :logical-block-circular)
 120             ;; It's a circular reference.
 121             t)))
 122         (t
 123          (let ((value (gethash object circularity-hash-table)))
 124            (case value
 125              ((nil t :logical-block)
 126               ;; If NIL, we found an object that wasn't there the
 127               ;; first time around. If T or :LOGICAL-BLOCK, this
 128               ;; object appears exactly once. Either way, just print
 129               ;; the thing without any special processing. Note: you
 130               ;; might argue that finding a new object means that
 131               ;; something is broken, but this can happen. If someone
 132               ;; uses the ~@<...~:> format directive, it conses a new
 133               ;; list each time though format (i.e. the &REST list),
 134               ;; so we will have different cdrs.
 135               nil)
 136              ;; A circular reference to something that will be printed
 137              ;; as a logical block. Wait until we're called from
 138              ;; PPRINT-LOGICAL-BLOCK with ASSIGN true before assigning the
 139              ;; number.
 140              ;;
 141              ;; If mode is :LOGICAL-BLOCK and assign is false, return true
 142              ;; to indicate that this object is circular, but don't assign
 143              ;; it a number yet. This is neccessary for cases like
 144              ;; #1=(#2=(#2# . #3=(#1# . #3#))))).
 145              (:logical-block-circular
 146               (cond ((and (not assign)
 147                           (eq mode :logical-block))
 148                      t)
 149                     ((and assign
 150                           (eq mode :logical-block))
 151                      (let ((value (incf *circularity-counter*)))
 152                        ;; first occurrence of this object: Set the counter.
 153                        (setf (gethash object circularity-hash-table) value)
 154                        value))
 155                     (t
 156                      nil)))
 157              (0
 158               (if (eq assign t)
 159                   (let ((value (incf *circularity-counter*)))
 160                     ;; first occurrence of this object: Set the counter.
 161                     (setf (gethash object circularity-hash-table) value)
 162                     value)
 163                   t))
 164              (t
 165               ;; second or later occurrence
 166               (- value))))))))
 167
 168 ;;; Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then
 169 ;;; you should go ahead and print the object. If it returns NIL, then
 170 ;;; you should blow it off.
 171 (defun handle-circularity (marker stream)
 172   (case marker
 173     (:initiate
 174      ;; Someone forgot to initiate circularity detection.
 175      (let ((*print-circle* nil))
 176        (error "trying to use CHECK-FOR-CIRCULARITY when ~
 177                circularity checking isn't initiated")))
 178     ((t :logical-block)
 179      ;; It's a second (or later) reference to the object while we are
 180      ;; just looking. So don't bother groveling it again.
 181      nil)
 182     (t
 183      (write-char #\# stream)
 184      (output-integer (abs marker) stream 10 nil)
 185      (cond ((minusp marker)
 186             (write-char #\# stream)
 187             nil)
 188            (t
 189             (write-char #\= stream)
 190             t)))))
 191
 192 (defmacro with-circularity-detection ((object stream) &body body)
 193   (with-unique-names (marker body-name)
 194     `(labels ((,body-name ()
 195                ,@body))
 196       (cond ((not *print-circle*) (,body-name))
 197             (*circularity-hash-table*
 198              (let ((,marker (check-for-circularity ,object t :logical-block)))
 199                (if ,marker
 200                    (when (handle-circularity ,marker ,stream)
 201                     (,body-name))
 202                   (,body-name))))
 203             (t
 204              (let ((*circularity-hash-table* (make-hash-table :test 'eq)))
 205                (output-object ,object (make-broadcast-stream))
 206                (let ((*circularity-counter* 0))
 207                  (let ((,marker (check-for-circularity ,object t
 208                                                        :logical-block)))
 209                    (when ,marker
 210                      (handle-circularity ,marker ,stream)))
 211                 (,body-name))))))))