0.9.5.58:
[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 nil prefixp)
37                                  (per-line-prefix nil per-line-prefix-p)
38                                  (suffix "" suffixp))
39                                 &body body
40                                 &environment env)
41   #!+sb-doc
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)
48       (case stream-symbol
49         ((nil)
50          (values '*standard-output* '*standard-output*))
51         ((t)
52          (values '*terminal-io* '*terminal-io*))
53         (t
54          (values stream-symbol
55                  (once-only ((stream stream-symbol))
56                    `(case ,stream
57                       ((nil) *standard-output*)
58                       ((t) *terminal-io*)
59                       (t ,stream))))))
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-"))
64            (body
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.
70             ;;
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 (and (sb!xc:constantp (or prefix per-line-prefix) env)
80                                         ;; KLUDGE: EVAL-IN-ENV would
81                                         ;; be useful here.
82                                         (typep (eval (or prefix per-line-prefix)) 'string))))
83                      `((unless (typep ,(or prefix per-line-prefix) 'string)
84                          (error 'type-error
85                                 :datum ,(or prefix per-line-prefix)
86                                 :expected-type 'string))))
87                  ,@(when (and suffixp
88                               (not (and (sb!xc:constantp suffix env)
89                                         (typep (eval suffix) 'string))))
90                      `((unless (typep ,suffix 'string)
91                          (error 'type-error
92                                 :datum ,suffix
93                                 :expected-type 'string))))
94                  (start-logical-block ,stream-var
95                                       ,(if (or prefixp per-line-prefix-p)
96                                            (or prefix per-line-prefix)
97                                            nil)
98                                       ,(if per-line-prefix-p t nil)
99                                       ,suffix)
100                  (block ,block-name
101                    (flet ((,pp-pop-name ()
102                             ,@(when object
103                                 `((unless (listp ,object-var)
104                                     (write-string ". " ,stream-var)
105                                     (output-object ,object-var ,stream-var)
106                                     (return-from ,block-name nil))))
107                             (when (and (not *print-readably*)
108                                        (eql ,count-name *print-length*))
109                               (write-string "..." ,stream-var)
110                               (return-from ,block-name nil))
111                             ,@(when object
112                                 `((when (and ,object-var
113                                              (plusp ,count-name)
114                                              (check-for-circularity
115                                               ,object-var
116                                               nil
117                                               :logical-block))
118                                     (write-string ". " ,stream-var)
119                                     (output-object ,object-var ,stream-var)
120                                     (return-from ,block-name nil))))
121                             (incf ,count-name)
122                             ,@(if object
123                                   `((pop ,object-var))
124                                   `(nil))))
125                      (declare (ignorable (function ,pp-pop-name)))
126                      (locally
127                          (declare (disable-package-locks
128                                    pprint-pop pprint-exit-if-list-exhausted))
129                        (macrolet ((pprint-pop ()
130                                     '(,pp-pop-name))
131                                   (pprint-exit-if-list-exhausted ()
132                                     ,(if object
133                                          `'(when (null ,object-var)
134                                             (return-from ,block-name nil))
135                                          `'(return-from ,block-name nil))))
136                          (declare (enable-package-locks
137                                    pprint-pop pprint-exit-if-list-exhausted))
138                          ,@body))))
139                  ;; FIXME: Don't we need UNWIND-PROTECT to ensure this
140                  ;; always gets executed?
141                  (end-logical-block ,stream-var)))))
142       (when object
143         (setf body
144               `(let ((,object-var ,object))
145                  (if (listp ,object-var)
146                      (with-circularity-detection (,object-var ,stream-var)
147                        ,body)
148                      (output-object ,object-var ,stream-var)))))
149       `(with-pretty-stream (,stream-var ,stream-expression)
150          ,body))))
151
152 (defmacro pprint-exit-if-list-exhausted ()
153   #!+sb-doc
154   "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
155    if its list argument is exhausted. Can only be used inside
156    PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
157    PPRINT-LOGICAL-BLOCK is supplied."
158   (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
159           PPRINT-LOGICAL-BLOCK."))
160
161 (defmacro pprint-pop ()
162   #!+sb-doc
163   "Return the next element from LIST argument to the closest enclosing
164    use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
165    and *PRINT-CIRCLE*. Can only be used inside PPRINT-LOGICAL-BLOCK.
166    If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
167    is popped, but the *PRINT-LENGTH* testing still happens."
168   (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))