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")
19 (defmacro with-pretty-stream ((stream-var
20 &optional (stream-expression stream-var))
22 (let ((flet-name (gensym "WITH-PRETTY-STREAM-")))
23 `(flet ((,flet-name (,stream-var)
25 (let ((stream ,stream-expression))
26 (if (pretty-stream-p stream)
28 (catch 'line-limit-abbreviation-happened
29 (let ((stream (make-pretty-stream stream)))
31 (force-pretty-output stream)))))
34 ;;;; user interface to the pretty printer
36 (defmacro pprint-logical-block ((stream-symbol
44 "Group some output into a logical block. STREAM-SYMBOL should be either a
45 stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer
46 control variable *PRINT-LEVEL* is automatically handled."
47 (when (and prefix per-line-prefix)
48 (error "cannot specify both PREFIX and a PER-LINE-PREFIX values"))
49 (multiple-value-bind (stream-var stream-expression)
52 (values '*standard-output* '*standard-output*))
54 (values '*terminal-io* '*terminal-io*))
57 (once-only ((stream stream-symbol))
59 ((nil) *standard-output*)
62 (let* ((object-var (if object (gensym) nil))
63 (block-name (gensym "PPRINT-LOGICAL-BLOCK-"))
64 (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
65 (pp-pop-name (gensym "PPRINT-POP-"))
67 ;; FIXME: It looks as though PPRINT-LOGICAL-BLOCK might
68 ;; expand into a boatload of code, since DESCEND-INTO is a
69 ;; macro too. It might be worth looking at this to make
70 ;; sure it's not too bloated, since PPRINT-LOGICAL-BLOCK
71 ;; is called many times from system pretty-printing code.
72 `(descend-into (,stream-var)
73 (let ((,count-name 0))
74 (declare (type index ,count-name) (ignorable ,count-name))
75 (start-logical-block ,stream-var
77 ,(or prefix per-line-prefix))
78 ,(if per-line-prefix t nil)
81 (flet ((,pp-pop-name ()
83 `((unless (listp ,object-var)
84 (write-string ". " ,stream-var)
85 (output-object ,object-var ,stream-var)
86 (return-from ,block-name nil))))
87 (when (and (not *print-readably*)
88 (eql ,count-name *print-length*))
89 (write-string "..." ,stream-var)
90 (return-from ,block-name nil))
92 `((when (and ,object-var
94 (check-for-circularity
96 (write-string ". " ,stream-var)
97 (output-object ,object-var ,stream-var)
98 (return-from ,block-name nil))))
101 `((pop ,object-var)))))
102 (declare (ignorable #',pp-pop-name))
103 (macrolet ((pprint-pop ()
105 (pprint-exit-if-list-exhausted ()
107 `'(when (null ,object-var)
108 (return-from ,block-name nil))
109 `'(return-from ,block-name nil))))
111 ;; FIXME: Don't we need UNWIND-PROTECT to ensure this
112 ;; always gets executed?
113 (end-logical-block ,stream-var)))))
116 `(let ((,object-var ,object))
117 (if (listp ,object-var)
119 (output-object ,object-var ,stream-var)))))
120 `(with-pretty-stream (,stream-var ,stream-expression)
123 (defmacro pprint-exit-if-list-exhausted ()
125 "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
126 if its list argument is exhausted. Can only be used inside
127 PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
128 PPRINT-LOGICAL-BLOCK is supplied."
129 (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
130 PPRINT-LOGICAL-BLOCK."))
132 (defmacro pprint-pop ()
134 "Return the next element from LIST argument to the closest enclosing
135 use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
136 and *PRINT-CIRCLE*. Can only be used inside PPRINT-LOGICAL-BLOCK.
137 If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
138 is popped, but the *PRINT-LENGTH* testing still happens."
139 (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))