1 ;;;; pretty 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!PRETTY")
16 (defmacro with-pretty-stream ((stream-var
17 &optional (stream-expression stream-var))
19 (let ((flet-name (gensym "WITH-PRETTY-STREAM-")))
20 `(flet ((,flet-name (,stream-var)
22 (let ((stream ,stream-expression))
23 (if (pretty-stream-p stream)
25 (catch 'line-limit-abbreviation-happened
26 (let ((stream (make-pretty-stream stream)))
28 (force-pretty-output stream)))))
31 ;;;; user interface to the pretty printer
33 (defmacro pprint-logical-block ((stream-symbol
37 (per-line-prefix nil per-line-prefix-p)
42 "Group some output into a logical block. STREAM-SYMBOL should be either a
43 stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer
44 control variable *PRINT-LEVEL* is automatically handled."
45 (when (and prefixp per-line-prefix-p)
46 (error "cannot specify values for both PREFIX and PER-LINE-PREFIX."))
47 (multiple-value-bind (stream-var stream-expression)
50 (values '*standard-output* '*standard-output*))
52 (values '*terminal-io* '*terminal-io*))
55 (once-only ((stream stream-symbol))
57 ((nil) *standard-output*)
60 (let* ((object-var (if object (gensym) nil))
61 (block-name (gensym "PPRINT-LOGICAL-BLOCK-"))
62 (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
63 (pp-pop-name (gensym "PPRINT-POP-"))
65 ;; FIXME: It looks as though PPRINT-LOGICAL-BLOCK might
66 ;; expand into a boatload of code, since DESCEND-INTO is a
67 ;; macro too. It might be worth looking at this to make
68 ;; sure it's not too bloated, since PPRINT-LOGICAL-BLOCK
69 ;; is called many times from system pretty-printing code.
71 ;; FIXME: I think pprint-logical-block is broken wrt
72 ;; argument order, multiple evaluation, etc. of its
73 ;; keyword (:PREFIX, :PER-LINE-PREFIX and :SUFFIX)
74 ;; arguments. Dunno if that's legal.
75 `(descend-into (,stream-var)
76 (let ((,count-name 0))
77 (declare (type index ,count-name) (ignorable ,count-name))
78 ,@(when (and (or prefixp per-line-prefix-p)
79 (not (sb!int:constant-typep
80 (or prefix per-line-prefix)
83 `((unless (typep ,(or prefix per-line-prefix) 'string)
85 :datum ,(or prefix per-line-prefix)
86 :expected-type 'string))))
88 (not (sb!int:constant-typep suffix 'string env)))
89 `((unless (typep ,suffix 'string)
92 :expected-type 'string))))
93 (start-logical-block ,stream-var
94 ,(if (or prefixp per-line-prefix-p)
95 (or prefix per-line-prefix)
97 ,(if per-line-prefix-p t nil)
100 (flet ((,pp-pop-name ()
102 `((unless (listp ,object-var)
103 (write-string ". " ,stream-var)
104 (output-object ,object-var ,stream-var)
105 (return-from ,block-name nil))))
106 (when (and (not *print-readably*)
107 (eql ,count-name *print-length*))
108 (write-string "..." ,stream-var)
109 (return-from ,block-name nil))
111 `((when (and ,object-var
113 (check-for-circularity
117 (write-string ". " ,stream-var)
118 (output-object ,object-var ,stream-var)
119 (return-from ,block-name nil))))
124 (declare (ignorable (function ,pp-pop-name)))
126 (declare (disable-package-locks
127 pprint-pop pprint-exit-if-list-exhausted))
128 (macrolet ((pprint-pop ()
130 (pprint-exit-if-list-exhausted ()
132 `'(when (null ,object-var)
133 (return-from ,block-name nil))
134 `'(return-from ,block-name nil))))
135 (declare (enable-package-locks
136 pprint-pop pprint-exit-if-list-exhausted))
138 ;; FIXME: Don't we need UNWIND-PROTECT to ensure this
139 ;; always gets executed?
140 (end-logical-block ,stream-var)))))
143 `(let ((,object-var ,object))
144 (if (listp ,object-var)
145 (with-circularity-detection (,object-var ,stream-var)
147 (output-object ,object-var ,stream-var)))))
148 `(with-pretty-stream (,stream-var ,stream-expression)
151 (defmacro pprint-exit-if-list-exhausted ()
153 "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
154 if its list argument is exhausted. Can only be used inside
155 PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
156 PPRINT-LOGICAL-BLOCK is supplied."
157 (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
158 PPRINT-LOGICAL-BLOCK."))
160 (defmacro pprint-pop ()
162 "Return the next element from LIST argument to the closest enclosing
163 use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
164 and *PRINT-CIRCLE*. Can only be used inside PPRINT-LOGICAL-BLOCK.
165 If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
166 is popped, but the *PRINT-LENGTH* testing still happens."
167 (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))