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