1.0.21.14: fix CHECK-FASL-HEADER buglet
[sbcl.git] / 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