1 ;;;; printer stuff which has to be defined early (e.g. DEFMACROs)
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!IMPL")
14 ;;;; level and length abbreviations
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)
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
()
28 (cond ((and (null *print-readably
*)
29 (let ((level *print-level
*))
30 (and level
(>= *current-level-in-print
* level
))))
31 (write-char #\
# ,stream
))
33 (let ((*current-level-in-print
* (1+ *current-level-in-print
*)))
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
)
47 ;;;; circularity detection stuff
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
56 (defvar *circularity-hash-table
* nil
)
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
)
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.
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).
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
*))
93 ((null circularity-hash-table
)
94 (values nil
:initiate
))
95 ((null *circularity-counter
*)
96 (ecase (gethash object circularity-hash-table
)
99 (setf (gethash object circularity-hash-table
) mode
)
100 ;; We need to keep looking.
103 (setf (gethash object circularity-hash-table
)
104 :logical-block-circular
)
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
)
116 (setf (gethash object circularity-hash-table
) 0)
117 ;; It's a circular reference.
119 ((0 :logical-block-circular
)
120 ;; It's a circular reference.
123 (let ((value (gethash object circularity-hash-table
)))
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.
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
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
))
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
)
159 (let ((value (incf *circularity-counter
*)))
160 ;; first occurrence of this object: Set the counter.
161 (setf (gethash object circularity-hash-table
) value
)
165 ;; second or later occurrence
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
)
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")))
179 ;; It's a second (or later) reference to the object while we are
180 ;; just looking. So don't bother groveling it again.
183 (write-char #\
# stream
)
184 (let ((*print-base
* 10) (*print-radix
* nil
))
185 (cond ((minusp marker
)
186 (output-integer (- marker
) stream
)
187 (write-char #\
# stream
)
190 (output-integer marker stream
)
191 (write-char #\
= stream
)
194 (defmacro with-circularity-detection
((object stream
) &body body
)
195 (with-unique-names (marker body-name
)
196 `(labels ((,body-name
()
198 (cond ((not *print-circle
*) (,body-name
))
199 (*circularity-hash-table
*
200 (let ((,marker
(check-for-circularity ,object t
:logical-block
)))
202 (when (handle-circularity ,marker
,stream
)
206 (let ((*circularity-hash-table
* (make-hash-table :test
'eq
)))
207 (output-object ,object
(make-broadcast-stream))
208 (let ((*circularity-counter
* 0))
209 (let ((,marker
(check-for-circularity ,object t
212 (handle-circularity ,marker
,stream
)))
215 ;; Helper for compiler-macro for WRITE[-TO-STRING]
216 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
217 (defun compiler-expand-write-mumble (fn form object keys
)
218 (do (streamvar bind ignore
)
221 form
; Odd number of keys, fail by returning the original form
222 (let* ((objvar (copy-symbol 'object
))
223 (bind `((,objvar
,object
) ,@(nreverse bind
)))
224 (ignore (when ignore
`((declare (ignore ,@ignore
))))))
228 (output-object ,objvar
230 `(out-synonym-of ,streamvar
)
235 `(let ,bind
,@ignore
(stringify-object ,objvar
))
236 `(stringify-object ,object
)))))))
237 (let* ((key (pop keys
))
240 (cond ((getf '(:escape
*print-escape
*
243 :circle
*print-circle
*
244 :pretty
*print-pretty
*
246 :length
*print-length
*
249 :gensym
*print-gensym
*
250 :readably
*print-readably
*
251 :right-margin
*print-right-margin
*
252 :miser-width
*print-miser-width
*
254 :pprint-dispatch
*print-pprint-dispatch
*
255 :suppress-errors
*suppress-print-errors
*)
257 ((and (eq key
:stream
) (eq fn
'write
))
258 (or streamvar
(setq streamvar
(copy-symbol 'stream
))))
261 (when (assoc variable bind
)
262 ;; First key has precedence, but we still need to execute the
263 ;; argument, and in the right order.
264 (setf variable
(gensym "IGNORE"))
265 (push variable ignore
))
266 (push (list variable value
) bind
)))))
268 ;;; Optimize common case of constant keyword arguments
269 (define-compiler-macro write
(&whole form object
&rest keys
)
270 (compiler-expand-write-mumble 'write form object keys
))
272 (define-compiler-macro write-to-string
(&whole form object
&rest keys
)
273 (compiler-expand-write-mumble 'write-to-string form object keys
))