0.7.13.7:
[sbcl.git] / src / code / early-pprint.lisp
1 ;;;; pretty 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!PRETTY")
13 \f
14 ;;;; utilities
15
16 (defmacro with-pretty-stream ((stream-var
17                                &optional (stream-expression stream-var))
18                               &body body)
19   (let ((flet-name (gensym "WITH-PRETTY-STREAM-")))
20     `(flet ((,flet-name (,stream-var)
21               ,@body))
22        (let ((stream ,stream-expression))
23          (if (pretty-stream-p stream)
24              (,flet-name stream)
25              (catch 'line-limit-abbreviation-happened
26                (let ((stream (make-pretty-stream stream)))
27                  (,flet-name stream)
28                  (force-pretty-output stream)))))
29        nil)))
30 \f
31 ;;;; user interface to the pretty printer
32
33 (defmacro pprint-logical-block ((stream-symbol
34                                  object
35                                  &key
36                                  prefix
37                                  per-line-prefix
38                                  (suffix ""))
39                                 &body body)
40   #!+sb-doc
41   "Group some output into a logical block. STREAM-SYMBOL should be either a
42    stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer
43    control variable *PRINT-LEVEL* is automatically handled."
44   (when (and prefix per-line-prefix)
45     (error "cannot specify both PREFIX and a PER-LINE-PREFIX values"))
46   (multiple-value-bind (stream-var stream-expression)
47       (case stream-symbol
48         ((nil)
49          (values '*standard-output* '*standard-output*))
50         ((t)
51          (values '*terminal-io* '*terminal-io*))
52         (t
53          (values stream-symbol
54                  (once-only ((stream stream-symbol))
55                    `(case ,stream
56                       ((nil) *standard-output*)
57                       ((t) *terminal-io*)
58                       (t ,stream))))))
59     (let* ((object-var (if object (gensym) nil))
60            (block-name (gensym "PPRINT-LOGICAL-BLOCK-"))
61            (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
62            (pp-pop-name (gensym "PPRINT-POP-"))
63            (body
64             ;; FIXME: It looks as though PPRINT-LOGICAL-BLOCK might
65             ;; expand into a boatload of code, since DESCEND-INTO is a
66             ;; macro too. It might be worth looking at this to make
67             ;; sure it's not too bloated, since PPRINT-LOGICAL-BLOCK
68             ;; is called many times from system pretty-printing code.
69             `(descend-into (,stream-var)
70                (let ((,count-name 0))
71                  (declare (type index ,count-name) (ignorable ,count-name))
72                  (start-logical-block ,stream-var
73                                       (the (or null string)
74                                         ,(or prefix per-line-prefix))
75                                       ,(if per-line-prefix t nil)
76                                       (the string ,suffix))
77                  (block ,block-name
78                    (flet ((,pp-pop-name ()
79                             ,@(when object
80                                 `((unless (listp ,object-var)
81                                     (write-string ". " ,stream-var)
82                                     (output-object ,object-var ,stream-var)
83                                     (return-from ,block-name nil))))
84                             (when (and (not *print-readably*)
85                                        (eql ,count-name *print-length*))
86                               (write-string "..." ,stream-var)
87                               (return-from ,block-name nil))
88                             ,@(when object
89                                 `((when (and ,object-var
90                                              (plusp ,count-name)
91                                              (check-for-circularity
92                                               ,object-var))
93                                     (write-string ". " ,stream-var)
94                                     (output-object ,object-var ,stream-var)
95                                     (return-from ,block-name nil))))
96                             (incf ,count-name)
97                             ,@(when object
98                                 `((pop ,object-var)))))
99                      (declare (ignorable #',pp-pop-name))
100                      (macrolet ((pprint-pop ()
101                                   '(,pp-pop-name))
102                                 (pprint-exit-if-list-exhausted ()
103                                   ,(if object
104                                        `'(when (null ,object-var)
105                                            (return-from ,block-name nil))
106                                        `'(return-from ,block-name nil))))
107                        ,@body)))
108                  ;; FIXME: Don't we need UNWIND-PROTECT to ensure this
109                  ;; always gets executed?
110                  (end-logical-block ,stream-var)))))
111       (when object
112         (setf body
113               `(let ((,object-var ,object))
114                  (if (listp ,object-var)
115                      ,body
116                      (output-object ,object-var ,stream-var)))))
117       `(with-pretty-stream (,stream-var ,stream-expression)
118          ,body))))
119
120 (defmacro pprint-exit-if-list-exhausted ()
121   #!+sb-doc
122   "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
123    if its list argument is exhausted. Can only be used inside
124    PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
125    PPRINT-LOGICAL-BLOCK is supplied."
126   (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
127           PPRINT-LOGICAL-BLOCK."))
128
129 (defmacro pprint-pop ()
130   #!+sb-doc
131   "Return the next element from LIST argument to the closest enclosing
132    use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
133    and *PRINT-CIRCLE*. Can only be used inside PPRINT-LOGICAL-BLOCK.
134    If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
135    is popped, but the *PRINT-LENGTH* testing still happens."
136   (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))