0.9.5.58:
[sbcl.git] / src / code / pprint.lisp
1 ;;;; Common Lisp pretty printer
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 ;;;; pretty streams
15
16 ;;; There are three different units for measuring character positions:
17 ;;;  COLUMN - offset (if characters) from the start of the current line
18 ;;;  INDEX  - index into the output buffer
19 ;;;  POSN   - some position in the stream of characters cycling through
20 ;;;           the output buffer
21 (deftype column ()
22   '(and fixnum unsigned-byte))
23 ;;; The INDEX type is picked up from the kernel package.
24 (deftype posn ()
25   'fixnum)
26
27 (defconstant initial-buffer-size 128)
28
29 (defconstant default-line-length 80)
30
31 (defstruct (pretty-stream (:include sb!kernel:ansi-stream
32                                     (out #'pretty-out)
33                                     (sout #'pretty-sout)
34                                     (misc #'pretty-misc))
35                           (:constructor make-pretty-stream (target))
36                           (:copier nil))
37   ;; Where the output is going to finally go.
38   (target (missing-arg) :type stream)
39   ;; Line length we should format to. Cached here so we don't have to keep
40   ;; extracting it from the target stream.
41   (line-length (or *print-right-margin*
42                    (sb!impl::line-length target)
43                    default-line-length)
44                :type column)
45   ;; A simple string holding all the text that has been output but not yet
46   ;; printed.
47   (buffer (make-string initial-buffer-size) :type (simple-array character (*)))
48   ;; The index into BUFFER where more text should be put.
49   (buffer-fill-pointer 0 :type index)
50   ;; Whenever we output stuff from the buffer, we shift the remaining noise
51   ;; over. This makes it difficult to keep references to locations in
52   ;; the buffer. Therefore, we have to keep track of the total amount of
53   ;; stuff that has been shifted out of the buffer.
54   (buffer-offset 0 :type posn)
55   ;; The column the first character in the buffer will appear in. Normally
56   ;; zero, but if we end up with a very long line with no breaks in it we
57   ;; might have to output part of it. Then this will no longer be zero.
58   (buffer-start-column (or (sb!impl::charpos target) 0) :type column)
59   ;; The line number we are currently on. Used for *PRINT-LINES*
60   ;; abbreviations and to tell when sections have been split across
61   ;; multiple lines.
62   (line-number 0 :type index)
63   ;; the value of *PRINT-LINES* captured at object creation time. We
64   ;; use this, instead of the dynamic *PRINT-LINES*, to avoid
65   ;; weirdness like
66   ;;   (let ((*print-lines* 50))
67   ;;     (pprint-logical-block ..
68   ;;       (dotimes (i 10)
69   ;;         (let ((*print-lines* 8))
70   ;;           (print (aref possiblybigthings i) prettystream)))))
71   ;; terminating the output of the entire logical blockafter 8 lines.
72   (print-lines *print-lines* :type (or index null) :read-only t)
73   ;; Stack of logical blocks in effect at the buffer start.
74   (blocks (list (make-logical-block)) :type list)
75   ;; Buffer holding the per-line prefix active at the buffer start.
76   ;; Indentation is included in this. The length of this is stored
77   ;; in the logical block stack.
78   (prefix (make-string initial-buffer-size) :type (simple-array character (*)))
79   ;; Buffer holding the total remaining suffix active at the buffer start.
80   ;; The characters are right-justified in the buffer to make it easier
81   ;; to output the buffer. The length is stored in the logical block
82   ;; stack.
83   (suffix (make-string initial-buffer-size) :type (simple-array character (*)))
84   ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
85   ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
86   ;; cons. Adding things to the queue is basically (setf (cdr head) (list
87   ;; new)) and removing them is basically (pop tail) [except that care must
88   ;; be taken to handle the empty queue case correctly.]
89   (queue-tail nil :type list)
90   (queue-head nil :type list)
91   ;; Block-start queue entries in effect at the queue head.
92   (pending-blocks nil :type list))
93 (def!method print-object ((pstream pretty-stream) stream)
94   ;; FIXME: CMU CL had #+NIL'ed out this code and done a hand-written
95   ;; FORMAT hack instead. Make sure that this code actually works instead
96   ;; of falling into infinite regress or something.
97   (print-unreadable-object (pstream stream :type t :identity t)))
98
99 #!-sb-fluid (declaim (inline index-posn posn-index posn-column))
100 (defun index-posn (index stream)
101   (declare (type index index) (type pretty-stream stream)
102            (values posn))
103   (+ index (pretty-stream-buffer-offset stream)))
104 (defun posn-index (posn stream)
105   (declare (type posn posn) (type pretty-stream stream)
106            (values index))
107   (- posn (pretty-stream-buffer-offset stream)))
108 (defun posn-column (posn stream)
109   (declare (type posn posn) (type pretty-stream stream)
110            (values posn))
111   (index-column (posn-index posn stream) stream))
112
113 ;;; Is it OK to do pretty printing on this stream at this time?
114 (defun print-pretty-on-stream-p (stream)
115   (and (pretty-stream-p stream)
116        *print-pretty*))
117 \f
118 ;;;; stream interface routines
119
120 (defun pretty-out (stream char)
121   (declare (type pretty-stream stream)
122            (type character char))
123   (cond ((char= char #\newline)
124          (enqueue-newline stream :literal))
125         (t
126          (ensure-space-in-buffer stream 1)
127          (let ((fill-pointer (pretty-stream-buffer-fill-pointer stream)))
128            (setf (schar (pretty-stream-buffer stream) fill-pointer) char)
129            (setf (pretty-stream-buffer-fill-pointer stream)
130                  (1+ fill-pointer))))))
131
132 (defun pretty-sout (stream string start end)
133   (declare (type pretty-stream stream)
134            (type simple-string string)
135            (type index start)
136            (type (or index null) end))
137   (let* ((string (if (typep string '(simple-array character (*)))
138                      string
139                      (coerce string '(simple-array character (*)))))
140          (end (or end (length string))))
141     (unless (= start end)
142       (let ((newline (position #\newline string :start start :end end)))
143         (cond
144          (newline
145           (pretty-sout stream string start newline)
146           (enqueue-newline stream :literal)
147           (pretty-sout stream string (1+ newline) end))
148          (t
149           (let ((chars (- end start)))
150             (loop
151               (let* ((available (ensure-space-in-buffer stream chars))
152                      (count (min available chars))
153                      (fill-pointer (pretty-stream-buffer-fill-pointer stream))
154                      (new-fill-ptr (+ fill-pointer count)))
155                 (replace (pretty-stream-buffer stream)
156                          string
157                          :start1 fill-pointer :end1 new-fill-ptr
158                          :start2 start)
159                 (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
160                 (decf chars count)
161                 (when (zerop count)
162                   (return))
163                 (incf start count))))))))))
164
165 (defun pretty-misc (stream op &optional arg1 arg2)
166   (declare (ignore stream op arg1 arg2)))
167 \f
168 ;;;; logical blocks
169
170 (defstruct (logical-block (:copier nil))
171   ;; The column this logical block started in.
172   (start-column 0 :type column)
173   ;; The column the current section started in.
174   (section-column 0 :type column)
175   ;; The length of the per-line prefix. We can't move the indentation
176   ;; left of this.
177   (per-line-prefix-end 0 :type index)
178   ;; The overall length of the prefix, including any indentation.
179   (prefix-length 0 :type index)
180   ;; The overall length of the suffix.
181   (suffix-length 0 :type index)
182   ;; The line number
183   (section-start-line 0 :type index))
184
185 (defun really-start-logical-block (stream column prefix suffix)
186   (let* ((blocks (pretty-stream-blocks stream))
187          (prev-block (car blocks))
188          (per-line-end (logical-block-per-line-prefix-end prev-block))
189          (prefix-length (logical-block-prefix-length prev-block))
190          (suffix-length (logical-block-suffix-length prev-block))
191          (block (make-logical-block
192                  :start-column column
193                  :section-column column
194                  :per-line-prefix-end per-line-end
195                  :prefix-length prefix-length
196                  :suffix-length suffix-length
197                  :section-start-line (pretty-stream-line-number stream))))
198     (setf (pretty-stream-blocks stream) (cons block blocks))
199     (set-indentation stream column)
200     (when prefix
201       (setf (logical-block-per-line-prefix-end block) column)
202       (replace (pretty-stream-prefix stream) prefix
203                :start1 (- column (length prefix)) :end1 column))
204     (when suffix
205       (let* ((total-suffix (pretty-stream-suffix stream))
206              (total-suffix-len (length total-suffix))
207              (additional (length suffix))
208              (new-suffix-len (+ suffix-length additional)))
209         (when (> new-suffix-len total-suffix-len)
210           (let ((new-total-suffix-len
211                  (max (* total-suffix-len 2)
212                       (+ suffix-length
213                          (floor (* additional 5) 4)))))
214             (setf total-suffix
215                   (replace (make-string new-total-suffix-len) total-suffix
216                            :start1 (- new-total-suffix-len suffix-length)
217                            :start2 (- total-suffix-len suffix-length)))
218             (setf total-suffix-len new-total-suffix-len)
219             (setf (pretty-stream-suffix stream) total-suffix)))
220         (replace total-suffix suffix
221                  :start1 (- total-suffix-len new-suffix-len)
222                  :end1 (- total-suffix-len suffix-length))
223         (setf (logical-block-suffix-length block) new-suffix-len))))
224   nil)
225
226 (defun set-indentation (stream column)
227   (let* ((prefix (pretty-stream-prefix stream))
228          (prefix-len (length prefix))
229          (block (car (pretty-stream-blocks stream)))
230          (current (logical-block-prefix-length block))
231          (minimum (logical-block-per-line-prefix-end block))
232          (column (max minimum column)))
233     (when (> column prefix-len)
234       (setf prefix
235             (replace (make-string (max (* prefix-len 2)
236                                        (+ prefix-len
237                                           (floor (* (- column prefix-len) 5)
238                                                  4))))
239                      prefix
240                      :end1 current))
241       (setf (pretty-stream-prefix stream) prefix))
242     (when (> column current)
243       (fill prefix #\space :start current :end column))
244     (setf (logical-block-prefix-length block) column)))
245
246 (defun really-end-logical-block (stream)
247   (let* ((old (pop (pretty-stream-blocks stream)))
248          (old-indent (logical-block-prefix-length old))
249          (new (car (pretty-stream-blocks stream)))
250          (new-indent (logical-block-prefix-length new)))
251     (when (> new-indent old-indent)
252       (fill (pretty-stream-prefix stream) #\space
253             :start old-indent :end new-indent)))
254   nil)
255 \f
256 ;;;; the pending operation queue
257
258 (defstruct (queued-op (:constructor nil)
259                       (:copier nil))
260   (posn 0 :type posn))
261
262 (defmacro enqueue (stream type &rest args)
263   (let ((constructor (symbolicate "MAKE-" type)))
264     (once-only ((stream stream)
265                 (entry `(,constructor :posn
266                                       (index-posn
267                                        (pretty-stream-buffer-fill-pointer
268                                         ,stream)
269                                        ,stream)
270                                       ,@args))
271                 (op `(list ,entry))
272                 (head `(pretty-stream-queue-head ,stream)))
273       `(progn
274          (if ,head
275              (setf (cdr ,head) ,op)
276              (setf (pretty-stream-queue-tail ,stream) ,op))
277          (setf (pretty-stream-queue-head ,stream) ,op)
278          ,entry))))
279
280 (defstruct (section-start (:include queued-op)
281                           (:constructor nil)
282                           (:copier nil))
283   (depth 0 :type index)
284   (section-end nil :type (or null newline block-end)))
285
286 (defstruct (newline (:include section-start)
287                     (:copier nil))
288   (kind (missing-arg)
289         :type (member :linear :fill :miser :literal :mandatory)))
290
291 (defun enqueue-newline (stream kind)
292   (let* ((depth (length (pretty-stream-pending-blocks stream)))
293          (newline (enqueue stream newline :kind kind :depth depth)))
294     (dolist (entry (pretty-stream-queue-tail stream))
295       (when (and (not (eq newline entry))
296                  (section-start-p entry)
297                  (null (section-start-section-end entry))
298                  (<= depth (section-start-depth entry)))
299         (setf (section-start-section-end entry) newline))))
300   (maybe-output stream (or (eq kind :literal) (eq kind :mandatory))))
301
302 (defstruct (indentation (:include queued-op)
303                         (:copier nil))
304   (kind (missing-arg) :type (member :block :current))
305   (amount 0 :type fixnum))
306
307 (defun enqueue-indent (stream kind amount)
308   (enqueue stream indentation :kind kind :amount amount))
309
310 (defstruct (block-start (:include section-start)
311                         (:copier nil))
312   (block-end nil :type (or null block-end))
313   (prefix nil :type (or null (simple-array character (*))))
314   (suffix nil :type (or null (simple-array character (*)))))
315
316 (defun start-logical-block (stream prefix per-line-p suffix)
317   ;; (In the PPRINT-LOGICAL-BLOCK form which calls us,
318   ;; :PREFIX and :PER-LINE-PREFIX have hairy defaulting behavior,
319   ;; and might end up being NIL.)
320   (declare (type (or null string) prefix))
321   ;; (But the defaulting behavior of PPRINT-LOGICAL-BLOCK :SUFFIX is
322   ;; trivial, so it should always be a string.)
323   (declare (type string suffix))
324   (when prefix
325     (setq prefix (coerce prefix '(simple-array character (*))))
326     (pretty-sout stream prefix 0 (length prefix)))
327   (let* ((pending-blocks (pretty-stream-pending-blocks stream))
328          (start (enqueue stream block-start
329                          :prefix (and per-line-p prefix)
330                          :suffix (coerce suffix '(simple-array character (*)))
331                          :depth (length pending-blocks))))
332     (setf (pretty-stream-pending-blocks stream)
333           (cons start pending-blocks))))
334
335 (defstruct (block-end (:include queued-op)
336                       (:copier nil))
337   (suffix nil :type (or null (simple-array character (*)))))
338
339 (defun end-logical-block (stream)
340   (let* ((start (pop (pretty-stream-pending-blocks stream)))
341          (suffix (block-start-suffix start))
342          (end (enqueue stream block-end :suffix suffix)))
343     (when suffix
344       (pretty-sout stream suffix 0 (length suffix)))
345     (setf (block-start-block-end start) end)))
346
347 (defstruct (tab (:include queued-op)
348                 (:copier nil))
349   (sectionp nil :type (member t nil))
350   (relativep nil :type (member t nil))
351   (colnum 0 :type column)
352   (colinc 0 :type column))
353
354 (defun enqueue-tab (stream kind colnum colinc)
355   (multiple-value-bind (sectionp relativep)
356       (ecase kind
357         (:line (values nil nil))
358         (:line-relative (values nil t))
359         (:section (values t nil))
360         (:section-relative (values t t)))
361     (enqueue stream tab :sectionp sectionp :relativep relativep
362              :colnum colnum :colinc colinc)))
363 \f
364 ;;;; tab support
365
366 (defun compute-tab-size (tab section-start column)
367   (let* ((origin (if (tab-sectionp tab) section-start 0))
368          (colnum (tab-colnum tab))
369          (colinc (tab-colinc tab))
370          (position (- column origin)))
371     (cond ((tab-relativep tab)
372            (unless (<= colinc 1)
373              (let ((newposn (+ position colnum)))
374                (let ((rem (rem newposn colinc)))
375                  (unless (zerop rem)
376                    (incf colnum (- colinc rem))))))
377            colnum)
378           ((< position colnum)
379            (- colnum position))
380           ((zerop colinc) 0)
381           (t
382            (- colinc
383               (rem (- position colnum) colinc))))))
384
385 (defun index-column (index stream)
386   (let ((column (pretty-stream-buffer-start-column stream))
387         (section-start (logical-block-section-column
388                         (first (pretty-stream-blocks stream))))
389         (end-posn (index-posn index stream)))
390     (dolist (op (pretty-stream-queue-tail stream))
391       (when (>= (queued-op-posn op) end-posn)
392         (return))
393       (typecase op
394         (tab
395          (incf column
396                (compute-tab-size op
397                                  section-start
398                                  (+ column
399                                     (posn-index (tab-posn op)
400                                                     stream)))))
401         ((or newline block-start)
402          (setf section-start
403                (+ column (posn-index (queued-op-posn op)
404                                          stream))))))
405     (+ column index)))
406
407 (defun expand-tabs (stream through)
408   (let ((insertions nil)
409         (additional 0)
410         (column (pretty-stream-buffer-start-column stream))
411         (section-start (logical-block-section-column
412                         (first (pretty-stream-blocks stream)))))
413     (dolist (op (pretty-stream-queue-tail stream))
414       (typecase op
415         (tab
416          (let* ((index (posn-index (tab-posn op) stream))
417                 (tabsize (compute-tab-size op
418                                            section-start
419                                            (+ column index))))
420            (unless (zerop tabsize)
421              (push (cons index tabsize) insertions)
422              (incf additional tabsize)
423              (incf column tabsize))))
424         ((or newline block-start)
425          (setf section-start
426                (+ column (posn-index (queued-op-posn op) stream)))))
427       (when (eq op through)
428         (return)))
429     (when insertions
430       (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
431              (new-fill-ptr (+ fill-ptr additional))
432              (buffer (pretty-stream-buffer stream))
433              (new-buffer buffer)
434              (length (length buffer))
435              (end fill-ptr))
436         (when (> new-fill-ptr length)
437           (let ((new-length (max (* length 2)
438                                  (+ fill-ptr
439                                     (floor (* additional 5) 4)))))
440             (setf new-buffer (make-string new-length))
441             (setf (pretty-stream-buffer stream) new-buffer)))
442         (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
443         (decf (pretty-stream-buffer-offset stream) additional)
444         (dolist (insertion insertions)
445           (let* ((srcpos (car insertion))
446                  (amount (cdr insertion))
447                  (dstpos (+ srcpos additional)))
448             (replace new-buffer buffer :start1 dstpos :start2 srcpos :end2 end)
449             (fill new-buffer #\space :start (- dstpos amount) :end dstpos)
450             (decf additional amount)
451             (setf end srcpos)))
452         (unless (eq new-buffer buffer)
453           (replace new-buffer buffer :end1 end :end2 end))))))
454 \f
455 ;;;; stuff to do the actual outputting
456
457 (defun ensure-space-in-buffer (stream want)
458   (declare (type pretty-stream stream)
459            (type index want))
460   (let* ((buffer (pretty-stream-buffer stream))
461          (length (length buffer))
462          (fill-ptr (pretty-stream-buffer-fill-pointer stream))
463          (available (- length fill-ptr)))
464     (cond ((plusp available)
465            available)
466           ((> fill-ptr (pretty-stream-line-length stream))
467            (unless (maybe-output stream nil)
468              (output-partial-line stream))
469            (ensure-space-in-buffer stream want))
470           (t
471            (let* ((new-length (max (* length 2)
472                                    (+ length
473                                       (floor (* want 5) 4))))
474                   (new-buffer (make-string new-length)))
475              (setf (pretty-stream-buffer stream) new-buffer)
476              (replace new-buffer buffer :end1 fill-ptr)
477              (- new-length fill-ptr))))))
478
479 (defun maybe-output (stream force-newlines-p)
480   (declare (type pretty-stream stream))
481   (let ((tail (pretty-stream-queue-tail stream))
482         (output-anything nil))
483     (loop
484       (unless tail
485         (setf (pretty-stream-queue-head stream) nil)
486         (return))
487       (let ((next (pop tail)))
488         (etypecase next
489           (newline
490            (when (ecase (newline-kind next)
491                    ((:literal :mandatory :linear) t)
492                    (:miser (misering-p stream))
493                    (:fill
494                     (or (misering-p stream)
495                         (> (pretty-stream-line-number stream)
496                            (logical-block-section-start-line
497                             (first (pretty-stream-blocks stream))))
498                         (ecase (fits-on-line-p stream
499                                                (newline-section-end next)
500                                                force-newlines-p)
501                           ((t) nil)
502                           ((nil) t)
503                           (:dont-know
504                            (return))))))
505              (setf output-anything t)
506              (output-line stream next)))
507           (indentation
508            (unless (misering-p stream)
509              (set-indentation stream
510                               (+ (ecase (indentation-kind next)
511                                    (:block
512                                     (logical-block-start-column
513                                      (car (pretty-stream-blocks stream))))
514                                    (:current
515                                     (posn-column
516                                      (indentation-posn next)
517                                      stream)))
518                                  (indentation-amount next)))))
519           (block-start
520            (ecase (fits-on-line-p stream (block-start-section-end next)
521                                   force-newlines-p)
522              ((t)
523               ;; Just nuke the whole logical block and make it look
524               ;; like one nice long literal.
525               (let ((end (block-start-block-end next)))
526                 (expand-tabs stream end)
527                 (setf tail (cdr (member end tail)))))
528              ((nil)
529               (really-start-logical-block
530                stream
531                (posn-column (block-start-posn next) stream)
532                (block-start-prefix next)
533                (block-start-suffix next)))
534              (:dont-know
535               (return))))
536           (block-end
537            (really-end-logical-block stream))
538           (tab
539            (expand-tabs stream next))))
540       (setf (pretty-stream-queue-tail stream) tail))
541     output-anything))
542
543 (defun misering-p (stream)
544   (declare (type pretty-stream stream))
545   (and *print-miser-width*
546        (<= (- (pretty-stream-line-length stream)
547               (logical-block-start-column (car (pretty-stream-blocks stream))))
548            *print-miser-width*)))
549
550 (defun fits-on-line-p (stream until force-newlines-p)
551   (let ((available (pretty-stream-line-length stream)))
552     (when (and (not *print-readably*)
553                (pretty-stream-print-lines stream)
554                (= (pretty-stream-print-lines stream)
555                   (pretty-stream-line-number stream)))
556       (decf available 3) ; for the `` ..''
557       (decf available (logical-block-suffix-length
558                        (car (pretty-stream-blocks stream)))))
559     (cond (until
560            (<= (posn-column (queued-op-posn until) stream) available))
561           (force-newlines-p nil)
562           ((> (index-column (pretty-stream-buffer-fill-pointer stream) stream)
563               available)
564            nil)
565           (t
566            :dont-know))))
567
568 (defun output-line (stream until)
569   (declare (type pretty-stream stream)
570            (type newline until))
571   (let* ((target (pretty-stream-target stream))
572          (buffer (pretty-stream-buffer stream))
573          (kind (newline-kind until))
574          (literal-p (eq kind :literal))
575          (amount-to-consume (posn-index (newline-posn until) stream))
576          (amount-to-print
577           (if literal-p
578               amount-to-consume
579               (let ((last-non-blank
580                      (position #\space buffer :end amount-to-consume
581                                :from-end t :test #'char/=)))
582                 (if last-non-blank
583                     (1+ last-non-blank)
584                     0)))))
585     (write-string buffer target :end amount-to-print)
586     (let ((line-number (pretty-stream-line-number stream)))
587       (incf line-number)
588       (when (and (not *print-readably*)
589                  (pretty-stream-print-lines stream)
590                  (>= line-number (pretty-stream-print-lines stream)))
591         (write-string " .." target)
592         (let ((suffix-length (logical-block-suffix-length
593                               (car (pretty-stream-blocks stream)))))
594           (unless (zerop suffix-length)
595             (let* ((suffix (pretty-stream-suffix stream))
596                    (len (length suffix)))
597               (write-string suffix target
598                             :start (- len suffix-length)
599                             :end len))))
600         (throw 'line-limit-abbreviation-happened t))
601       (setf (pretty-stream-line-number stream) line-number)
602       (write-char #\newline target)
603       (setf (pretty-stream-buffer-start-column stream) 0)
604       (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
605              (block (first (pretty-stream-blocks stream)))
606              (prefix-len
607               (if literal-p
608                   (logical-block-per-line-prefix-end block)
609                   (logical-block-prefix-length block)))
610              (shift (- amount-to-consume prefix-len))
611              (new-fill-ptr (- fill-ptr shift))
612              (new-buffer buffer)
613              (buffer-length (length buffer)))
614         (when (> new-fill-ptr buffer-length)
615           (setf new-buffer
616                 (make-string (max (* buffer-length 2)
617                                   (+ buffer-length
618                                      (floor (* (- new-fill-ptr buffer-length)
619                                                5)
620                                             4)))))
621           (setf (pretty-stream-buffer stream) new-buffer))
622         (replace new-buffer buffer
623                  :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
624         (replace new-buffer (pretty-stream-prefix stream)
625                  :end1 prefix-len)
626         (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
627         (incf (pretty-stream-buffer-offset stream) shift)
628         (unless literal-p
629           (setf (logical-block-section-column block) prefix-len)
630           (setf (logical-block-section-start-line block) line-number))))))
631
632 (defun output-partial-line (stream)
633   (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
634          (tail (pretty-stream-queue-tail stream))
635          (count
636           (if tail
637               (posn-index (queued-op-posn (car tail)) stream)
638               fill-ptr))
639          (new-fill-ptr (- fill-ptr count))
640          (buffer (pretty-stream-buffer stream)))
641     (when (zerop count)
642       (error "Output-partial-line called when nothing can be output."))
643     (write-string buffer (pretty-stream-target stream)
644                   :start 0 :end count)
645     (incf (pretty-stream-buffer-start-column stream) count)
646     (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr)
647     (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
648     (incf (pretty-stream-buffer-offset stream) count)))
649
650 (defun force-pretty-output (stream)
651   (maybe-output stream nil)
652   (expand-tabs stream nil)
653   (write-string (pretty-stream-buffer stream)
654                 (pretty-stream-target stream)
655                 :end (pretty-stream-buffer-fill-pointer stream)))
656 \f
657 ;;;; user interface to the pretty printer
658
659 (defun pprint-newline (kind &optional stream)
660   #!+sb-doc
661   "Output a conditional newline to STREAM (which defaults to
662    *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do
663    nothing if not. KIND can be one of:
664      :LINEAR - A line break is inserted if and only if the immediatly
665         containing section cannot be printed on one line.
666      :MISER - Same as LINEAR, but only if ``miser-style'' is in effect.
667         (See *PRINT-MISER-WIDTH*.)
668      :FILL - A line break is inserted if and only if either:
669        (a) the following section cannot be printed on the end of the
670            current line,
671        (b) the preceding section was not printed on a single line, or
672        (c) the immediately containing section cannot be printed on one
673            line and miser-style is in effect.
674      :MANDATORY - A line break is always inserted.
675    When a line break is inserted by any type of conditional newline, any
676    blanks that immediately precede the conditional newline are ommitted
677    from the output and indentation is introduced at the beginning of the
678    next line. (See PPRINT-INDENT.)"
679   (declare (type (member :linear :miser :fill :mandatory) kind)
680            (type (or stream (member t nil)) stream)
681            (values null))
682   (let ((stream (case stream
683                   ((t) *terminal-io*)
684                   ((nil) *standard-output*)
685                   (t stream))))
686     (when (print-pretty-on-stream-p stream)
687       (enqueue-newline stream kind)))
688   nil)
689
690 (defun pprint-indent (relative-to n &optional stream)
691   #!+sb-doc
692   "Specify the indentation to use in the current logical block if STREAM
693    (which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream
694    and do nothing if not. (See PPRINT-LOGICAL-BLOCK.)  N is the indentation
695    to use (in ems, the width of an ``m'') and RELATIVE-TO can be either:
696      :BLOCK - Indent relative to the column the current logical block
697         started on.
698      :CURRENT - Indent relative to the current column.
699    The new indentation value does not take effect until the following line
700    break."
701   (declare (type (member :block :current) relative-to)
702            (type real n)
703            (type (or stream (member t nil)) stream)
704            (values null))
705   (let ((stream (case stream
706                   ((t) *terminal-io*)
707                   ((nil) *standard-output*)
708                   (t stream))))
709     (when (print-pretty-on-stream-p stream)
710       (enqueue-indent stream relative-to (truncate n))))
711   nil)
712
713 (defun pprint-tab (kind colnum colinc &optional stream)
714   #!+sb-doc
715   "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing
716    stream, perform tabbing based on KIND, otherwise do nothing. KIND can
717    be one of:
718      :LINE - Tab to column COLNUM. If already past COLNUM tab to the next
719        multiple of COLINC.
720      :SECTION - Same as :LINE, but count from the start of the current
721        section, not the start of the line.
722      :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of
723        COLINC.
724      :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start
725        of the current section, not the start of the line."
726   (declare (type (member :line :section :line-relative :section-relative) kind)
727            (type unsigned-byte colnum colinc)
728            (type (or stream (member t nil)) stream)
729            (values null))
730   (let ((stream (case stream
731                   ((t) *terminal-io*)
732                   ((nil) *standard-output*)
733                   (t stream))))
734     (when (print-pretty-on-stream-p stream)
735       (enqueue-tab stream kind colnum colinc)))
736   nil)
737
738 (defun pprint-fill (stream list &optional (colon? t) atsign?)
739   #!+sb-doc
740   "Output LIST to STREAM putting :FILL conditional newlines between each
741    element. If COLON? is NIL (defaults to T), then no parens are printed
742    around the output. ATSIGN? is ignored (but allowed so that PPRINT-FILL
743    can be used with the ~/.../ format directive."
744   (declare (ignore atsign?))
745   (pprint-logical-block (stream list
746                                 :prefix (if colon? "(" "")
747                                 :suffix (if colon? ")" ""))
748     (pprint-exit-if-list-exhausted)
749     (loop
750       (output-object (pprint-pop) stream)
751       (pprint-exit-if-list-exhausted)
752       (write-char #\space stream)
753       (pprint-newline :fill stream))))
754
755 (defun pprint-linear (stream list &optional (colon? t) atsign?)
756   #!+sb-doc
757   "Output LIST to STREAM putting :LINEAR conditional newlines between each
758    element. If COLON? is NIL (defaults to T), then no parens are printed
759    around the output. ATSIGN? is ignored (but allowed so that PPRINT-LINEAR
760    can be used with the ~/.../ format directive."
761   (declare (ignore atsign?))
762   (pprint-logical-block (stream list
763                                 :prefix (if colon? "(" "")
764                                 :suffix (if colon? ")" ""))
765     (pprint-exit-if-list-exhausted)
766     (loop
767       (output-object (pprint-pop) stream)
768       (pprint-exit-if-list-exhausted)
769       (write-char #\space stream)
770       (pprint-newline :linear stream))))
771
772 (defun pprint-tabular (stream list &optional (colon? t) atsign? tabsize)
773   #!+sb-doc
774   "Output LIST to STREAM tabbing to the next column that is an even multiple
775    of TABSIZE (which defaults to 16) between each element. :FILL style
776    conditional newlines are also output between each element. If COLON? is
777    NIL (defaults to T), then no parens are printed around the output.
778    ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with
779    the ~/.../ format directive."
780   (declare (ignore atsign?))
781   (pprint-logical-block (stream list
782                                 :prefix (if colon? "(" "")
783                                 :suffix (if colon? ")" ""))
784     (pprint-exit-if-list-exhausted)
785     (loop
786       (output-object (pprint-pop) stream)
787       (pprint-exit-if-list-exhausted)
788       (write-char #\space stream)
789       (pprint-tab :section-relative 0 (or tabsize 16) stream)
790       (pprint-newline :fill stream))))
791 \f
792 ;;;; pprint-dispatch tables
793
794 (defvar *initial-pprint-dispatch*)
795 (defvar *building-initial-table* nil)
796
797 (defstruct (pprint-dispatch-entry (:copier nil))
798   ;; the type specifier for this entry
799   (type (missing-arg) :type t)
800   ;; a function to test to see whether an object is of this time.
801   ;; Pretty must just (LAMBDA (OBJ) (TYPEP OBJECT TYPE)) except that
802   ;; we handle the CONS type specially so that (CONS (MEMBER FOO))
803   ;; works. We don't bother computing this for entries in the CONS
804   ;; hash table, because we don't need it.
805   (test-fn nil :type (or function null))
806   ;; the priority for this guy
807   (priority 0 :type real)
808   ;; T iff one of the original entries.
809   (initial-p *building-initial-table* :type (member t nil))
810   ;; and the associated function
811   (fun (missing-arg) :type callable))
812 (def!method print-object ((entry pprint-dispatch-entry) stream)
813   (print-unreadable-object (entry stream :type t)
814     (format stream "type=~S, priority=~S~@[ [initial]~]"
815             (pprint-dispatch-entry-type entry)
816             (pprint-dispatch-entry-priority entry)
817             (pprint-dispatch-entry-initial-p entry))))
818
819 (defun cons-type-specifier-p (spec)
820   (and (consp spec)
821        (eq (car spec) 'cons)
822        (cdr spec)
823        (null (cddr spec))
824        (let ((car (cadr spec)))
825          (and (consp car)
826               (let ((carcar (car car)))
827                 (or (eq carcar 'member)
828                     (eq carcar 'eql)))
829               (cdr car)
830               (null (cddr car))))))
831
832 (defun entry< (e1 e2)
833   (declare (type pprint-dispatch-entry e1 e2))
834   (if (pprint-dispatch-entry-initial-p e1)
835       (if (pprint-dispatch-entry-initial-p e2)
836           (< (pprint-dispatch-entry-priority e1)
837              (pprint-dispatch-entry-priority e2))
838           t)
839       (if (pprint-dispatch-entry-initial-p e2)
840           nil
841           (< (pprint-dispatch-entry-priority e1)
842              (pprint-dispatch-entry-priority e2)))))
843
844 (macrolet ((frob (x)
845              `(cons ',x (lambda (object) ,x))))
846   (defvar *precompiled-pprint-dispatch-funs*
847     (list (frob (typep object 'array))
848           (frob (and (consp object)
849                      (symbolp (car object))
850                      (fboundp (car object))))
851           (frob (typep object 'cons)))))
852
853 (defun compute-test-fn (type)
854   (let ((was-cons nil))
855     (labels ((compute-test-expr (type object)
856                (if (listp type)
857                    (case (car type)
858                      (cons
859                       (setq was-cons t)
860                       (destructuring-bind
861                           (&optional (car nil car-p) (cdr nil cdr-p))
862                           (cdr type)
863                         `(and (consp ,object)
864                               ,@(when car-p
865                                   `(,(compute-test-expr
866                                       car `(car ,object))))
867                               ,@(when cdr-p
868                                   `(,(compute-test-expr
869                                       cdr `(cdr ,object)))))))
870                      (not
871                       (destructuring-bind (type) (cdr type)
872                         `(not ,(compute-test-expr type object))))
873                      (and
874                       `(and ,@(mapcar (lambda (type)
875                                         (compute-test-expr type object))
876                                       (cdr type))))
877                      (or
878                       `(or ,@(mapcar (lambda (type)
879                                        (compute-test-expr type object))
880                                      (cdr type))))
881                      (t
882                       `(typep ,object ',type)))
883                    `(typep ,object ',type))))
884       (let ((expr (compute-test-expr type 'object)))
885         (cond ((cdr (assoc expr *precompiled-pprint-dispatch-funs*
886                            :test #'equal)))
887               (t
888                (compile nil `(lambda (object) ,expr))))))))
889
890 (defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
891   (declare (type (or pprint-dispatch-table null) table))
892   (let* ((orig (or table *initial-pprint-dispatch*))
893          (new (make-pprint-dispatch-table
894                :entries (copy-list (pprint-dispatch-table-entries orig))))
895          (new-cons-entries (pprint-dispatch-table-cons-entries new)))
896     (maphash (lambda (key value)
897                (setf (gethash key new-cons-entries) value))
898              (pprint-dispatch-table-cons-entries orig))
899     new))
900
901 (defun pprint-dispatch (object &optional (table *print-pprint-dispatch*))
902   (declare (type (or pprint-dispatch-table null) table))
903   (let* ((table (or table *initial-pprint-dispatch*))
904          (cons-entry
905           (and (consp object)
906                (gethash (car object)
907                         (pprint-dispatch-table-cons-entries table))))
908          (entry
909           (dolist (entry (pprint-dispatch-table-entries table) cons-entry)
910             (when (and cons-entry
911                        (entry< entry cons-entry))
912               (return cons-entry))
913             (when (funcall (pprint-dispatch-entry-test-fn entry) object)
914               (return entry)))))
915     (if entry
916         (values (pprint-dispatch-entry-fun entry) t)
917         (values (lambda (stream object)
918                   (output-ugly-object object stream))
919                 nil))))
920
921 (defun set-pprint-dispatch (type function &optional
922                             (priority 0) (table *print-pprint-dispatch*))
923   (declare (type (or null callable) function)
924            (type real priority)
925            (type pprint-dispatch-table table))
926   (/show0 "entering SET-PPRINT-DISPATCH, TYPE=...")
927   (/hexstr type)
928   (if function
929       (if (cons-type-specifier-p type)
930           (setf (gethash (second (second type))
931                          (pprint-dispatch-table-cons-entries table))
932                 (make-pprint-dispatch-entry :type type
933                                             :priority priority
934                                             :fun function))
935           (let ((list (delete type (pprint-dispatch-table-entries table)
936                               :key #'pprint-dispatch-entry-type
937                               :test #'equal))
938                 (entry (make-pprint-dispatch-entry
939                         :type type
940                         :test-fn (compute-test-fn type)
941                         :priority priority
942                         :fun function)))
943             (do ((prev nil next)
944                  (next list (cdr next)))
945                 ((null next)
946                  (if prev
947                      (setf (cdr prev) (list entry))
948                      (setf list (list entry))))
949               (when (entry< (car next) entry)
950                 (if prev
951                     (setf (cdr prev) (cons entry next))
952                     (setf list (cons entry next)))
953                 (return)))
954             (setf (pprint-dispatch-table-entries table) list)))
955       (if (cons-type-specifier-p type)
956           (remhash (second (second type))
957                    (pprint-dispatch-table-cons-entries table))
958           (setf (pprint-dispatch-table-entries table)
959                 (delete type (pprint-dispatch-table-entries table)
960                         :key #'pprint-dispatch-entry-type
961                         :test #'equal))))
962   (/show0 "about to return NIL from SET-PPRINT-DISPATCH")
963   nil)
964 \f
965 ;;;; standard pretty-printing routines
966
967 (defun pprint-array (stream array)
968   (cond ((or (and (null *print-array*) (null *print-readably*))
969              (stringp array)
970              (bit-vector-p array))
971          (output-ugly-object array stream))
972         ((and *print-readably*
973               (not (array-readably-printable-p array)))
974          (let ((*print-readably* nil))
975            (error 'print-not-readable :object array)))
976         ((vectorp array)
977          (pprint-vector stream array))
978         (t
979          (pprint-multi-dim-array stream array))))
980
981 (defun pprint-vector (stream vector)
982   (pprint-logical-block (stream nil :prefix "#(" :suffix ")")
983     (dotimes (i (length vector))
984       (unless (zerop i)
985         (format stream " ~:_"))
986       (pprint-pop)
987       (output-object (aref vector i) stream))))
988
989 (defun pprint-multi-dim-array (stream array)
990   (funcall (formatter "#~DA") stream (array-rank array))
991   (with-array-data ((data array) (start) (end))
992     (declare (ignore end))
993     (labels ((output-guts (stream index dimensions)
994                (if (null dimensions)
995                    (output-object (aref data index) stream)
996                    (pprint-logical-block
997                        (stream nil :prefix "(" :suffix ")")
998                      (let ((dim (car dimensions)))
999                        (unless (zerop dim)
1000                          (let* ((dims (cdr dimensions))
1001                                 (index index)
1002                                 (step (reduce #'* dims))
1003                                 (count 0))
1004                            (loop
1005                              (pprint-pop)
1006                              (output-guts stream index dims)
1007                              (when (= (incf count) dim)
1008                                (return))
1009                              (write-char #\space stream)
1010                              (pprint-newline (if dims :linear :fill)
1011                                              stream)
1012                              (incf index step)))))))))
1013       (output-guts stream start (array-dimensions array)))))
1014
1015 (defun pprint-lambda-list (stream lambda-list &rest noise)
1016   (declare (ignore noise))
1017   (when (and (consp lambda-list)
1018              (member (car lambda-list) *backq-tokens*))
1019     ;; if this thing looks like a backquoty thing, then we don't want
1020     ;; to destructure it, we want to output it straight away.  [ this
1021     ;; is the exception to the normal processing: if we did this
1022     ;; generally we would find lambda lists such as (FUNCTION FOO)
1023     ;; being printed as #'FOO ]  -- CSR, 2003-12-07
1024     (output-object lambda-list stream)
1025     (return-from pprint-lambda-list nil))
1026   (pprint-logical-block (stream lambda-list :prefix "(" :suffix ")")
1027     (let ((state :required)
1028           (first t))
1029       (loop
1030         (pprint-exit-if-list-exhausted)
1031         (unless first
1032           (write-char #\space stream))
1033         (let ((arg (pprint-pop)))
1034           (unless first
1035             (case arg
1036               (&optional
1037                (setf state :optional)
1038                (pprint-newline :linear stream))
1039               ((&rest &body)
1040                (setf state :required)
1041                (pprint-newline :linear stream))
1042               (&key
1043                (setf state :key)
1044                (pprint-newline :linear stream))
1045               (&aux
1046                (setf state :optional)
1047                (pprint-newline :linear stream))
1048               (t
1049                (pprint-newline :fill stream))))
1050           (ecase state
1051             (:required
1052              (pprint-lambda-list stream arg))
1053             ((:optional :key)
1054              (pprint-logical-block
1055                  (stream arg :prefix "(" :suffix ")")
1056                (pprint-exit-if-list-exhausted)
1057                (if (eq state :key)
1058                    (pprint-logical-block
1059                        (stream (pprint-pop) :prefix "(" :suffix ")")
1060                      (pprint-exit-if-list-exhausted)
1061                      (output-object (pprint-pop) stream)
1062                      (pprint-exit-if-list-exhausted)
1063                      (write-char #\space stream)
1064                      (pprint-newline :fill stream)
1065                      (pprint-lambda-list stream (pprint-pop))
1066                      (loop
1067                        (pprint-exit-if-list-exhausted)
1068                        (write-char #\space stream)
1069                        (pprint-newline :fill stream)
1070                        (output-object (pprint-pop) stream)))
1071                    (pprint-lambda-list stream (pprint-pop)))
1072                (loop
1073                  (pprint-exit-if-list-exhausted)
1074                  (write-char #\space stream)
1075                  (pprint-newline :linear stream)
1076                  (output-object (pprint-pop) stream))))))
1077         (setf first nil)))))
1078
1079 (defun pprint-lambda (stream list &rest noise)
1080   (declare (ignore noise))
1081   (funcall (formatter
1082             ;; KLUDGE: This format string, and other format strings which also
1083             ;; refer to SB!PRETTY, rely on the current SBCL not-quite-ANSI
1084             ;; behavior of FORMATTER in order to make code which survives the
1085             ;; transition when SB!PRETTY is renamed to SB-PRETTY after cold
1086             ;; init. (ANSI says that the FORMATTER functions should be
1087             ;; equivalent to the format string, but the SBCL FORMATTER
1088             ;; functions contain references to package objects, not package
1089             ;; names, so they keep right on going if the packages are renamed.)
1090             ;; If our FORMATTER behavior is ever made more compliant, the code
1091             ;; here will have to change. -- WHN 19991207
1092             "~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
1093            stream
1094            list))
1095
1096 (defun pprint-block (stream list &rest noise)
1097   (declare (ignore noise))
1098   (funcall (formatter "~:<~^~W~^~3I ~:_~W~1I~@{ ~_~W~}~:>") stream list))
1099
1100 (defun pprint-flet (stream list &rest noise)
1101   (declare (ignore noise))
1102   (if (and (consp list)
1103            (consp (cdr list))
1104            (cddr list))
1105       (funcall (formatter
1106                 "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
1107                stream
1108                list)
1109       ;; for printing function names like (flet foo)
1110       (pprint-logical-block (stream list :prefix "(" :suffix ")")
1111         (pprint-exit-if-list-exhausted)
1112         (write (pprint-pop) :stream stream)
1113         (loop
1114            (pprint-exit-if-list-exhausted)
1115            (write-char #\space stream)
1116            (write (pprint-pop) :stream stream)))))
1117
1118 (defun pprint-let (stream list &rest noise)
1119   (declare (ignore noise))
1120   (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>")
1121            stream
1122            list))
1123
1124 (defun pprint-progn (stream list &rest noise)
1125   (declare (ignore noise))
1126   (funcall (formatter "~:<~^~W~@{ ~_~W~}~:>") stream list))
1127
1128 (defun pprint-progv (stream list &rest noise)
1129   (declare (ignore noise))
1130   (funcall (formatter "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>")
1131            stream list))
1132
1133 (defun pprint-quote (stream list &rest noise)
1134   (declare (ignore noise))
1135   (if (and (consp list)
1136            (consp (cdr list))
1137            (null (cddr list)))
1138       (case (car list)
1139         (function
1140          (write-string "#'" stream)
1141          (output-object (cadr list) stream))
1142         (quote
1143          (write-char #\' stream)
1144          (output-object (cadr list) stream))
1145         (t
1146          (pprint-fill stream list)))
1147       (pprint-fill stream list)))
1148
1149 (defun pprint-setq (stream list &rest noise)
1150   (declare (ignore noise))
1151   (pprint-logical-block (stream list :prefix "(" :suffix ")")
1152     (pprint-exit-if-list-exhausted)
1153     (output-object (pprint-pop) stream)
1154     (pprint-exit-if-list-exhausted)
1155     (write-char #\space stream)
1156     (pprint-newline :miser stream)
1157     (if (and (consp (cdr list)) (consp (cddr list)))
1158         (loop
1159           (pprint-indent :current 2 stream)
1160           (output-object (pprint-pop) stream)
1161           (pprint-exit-if-list-exhausted)
1162           (write-char #\space stream)
1163           (pprint-newline :linear stream)
1164           (pprint-indent :current -2 stream)
1165           (output-object (pprint-pop) stream)
1166           (pprint-exit-if-list-exhausted)
1167           (write-char #\space stream)
1168           (pprint-newline :linear stream))
1169         (progn
1170           (pprint-indent :current 0 stream)
1171           (output-object (pprint-pop) stream)
1172           (pprint-exit-if-list-exhausted)
1173           (write-char #\space stream)
1174           (pprint-newline :linear stream)
1175           (output-object (pprint-pop) stream)))))
1176
1177 ;;; FIXME: could become SB!XC:DEFMACRO wrapped in EVAL-WHEN (COMPILE EVAL)
1178 (defmacro pprint-tagbody-guts (stream)
1179   `(loop
1180      (pprint-exit-if-list-exhausted)
1181      (write-char #\space ,stream)
1182      (let ((form-or-tag (pprint-pop)))
1183        (pprint-indent :block
1184                       (if (atom form-or-tag) 0 1)
1185                       ,stream)
1186        (pprint-newline :linear ,stream)
1187        (output-object form-or-tag ,stream))))
1188
1189 (defun pprint-tagbody (stream list &rest noise)
1190   (declare (ignore noise))
1191   (pprint-logical-block (stream list :prefix "(" :suffix ")")
1192     (pprint-exit-if-list-exhausted)
1193     (output-object (pprint-pop) stream)
1194     (pprint-tagbody-guts stream)))
1195
1196 (defun pprint-case (stream list &rest noise)
1197   (declare (ignore noise))
1198   (funcall (formatter
1199             "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/SB!PRETTY:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>")
1200            stream
1201            list))
1202
1203 (defun pprint-defun (stream list &rest noise)
1204   (declare (ignore noise))
1205   (funcall (formatter
1206             "~:<~^~W~^ ~@_~:I~W~^ ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
1207            stream
1208            list))
1209
1210 (defun pprint-destructuring-bind (stream list &rest noise)
1211   (declare (ignore noise))
1212   (funcall (formatter
1213             "~:<~^~W~^~3I ~_~:/SB!PRETTY:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>")
1214            stream list))
1215
1216 (defun pprint-do (stream list &rest noise)
1217   (declare (ignore noise))
1218   (pprint-logical-block (stream list :prefix "(" :suffix ")")
1219     (pprint-exit-if-list-exhausted)
1220     (output-object (pprint-pop) stream)
1221     (pprint-exit-if-list-exhausted)
1222     (write-char #\space stream)
1223     (pprint-indent :current 0 stream)
1224     (funcall (formatter "~:<~@{~:<~^~W~^ ~@_~:I~W~@{ ~_~W~}~:>~^~:@_~}~:>")
1225              stream
1226              (pprint-pop))
1227     (pprint-exit-if-list-exhausted)
1228     (write-char #\space stream)
1229     (pprint-newline :linear stream)
1230     (pprint-linear stream (pprint-pop))
1231     (pprint-tagbody-guts stream)))
1232
1233 (defun pprint-dolist (stream list &rest noise)
1234   (declare (ignore noise))
1235   (pprint-logical-block (stream list :prefix "(" :suffix ")")
1236     (pprint-exit-if-list-exhausted)
1237     (output-object (pprint-pop) stream)
1238     (pprint-exit-if-list-exhausted)
1239     (pprint-indent :block 3 stream)
1240     (write-char #\space stream)
1241     (pprint-newline :fill stream)
1242     (funcall (formatter "~:<~^~W~^ ~:_~:I~W~@{ ~_~W~}~:>")
1243              stream
1244              (pprint-pop))
1245     (pprint-tagbody-guts stream)))
1246
1247 (defun pprint-typecase (stream list &rest noise)
1248   (declare (ignore noise))
1249   (funcall (formatter
1250             "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>")
1251            stream
1252            list))
1253
1254 (defun pprint-prog (stream list &rest noise)
1255   (declare (ignore noise))
1256   (pprint-logical-block (stream list :prefix "(" :suffix ")")
1257     (pprint-exit-if-list-exhausted)
1258     (output-object (pprint-pop) stream)
1259     (pprint-exit-if-list-exhausted)
1260     (write-char #\space stream)
1261     (pprint-newline :miser stream)
1262     (pprint-fill stream (pprint-pop))
1263     (pprint-tagbody-guts stream)))
1264
1265 (defun pprint-fun-call (stream list &rest noise)
1266   (declare (ignore noise))
1267   (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>")
1268            stream
1269            list))
1270 \f
1271 ;;;; the interface seen by regular (ugly) printer and initialization routines
1272
1273 ;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when
1274 ;;; *PRINT-PRETTY* is true.
1275 (defun output-pretty-object (object stream)
1276   (with-pretty-stream (stream)
1277     (funcall (pprint-dispatch object) stream object)))
1278
1279 (defun !pprint-cold-init ()
1280   (/show0 "entering !PPRINT-COLD-INIT")
1281   (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))
1282   (let ((*print-pprint-dispatch* *initial-pprint-dispatch*)
1283         (*building-initial-table* t))
1284     ;; printers for regular types
1285     (/show0 "doing SET-PPRINT-DISPATCH for regular types")
1286     (set-pprint-dispatch 'array #'pprint-array)
1287     (set-pprint-dispatch '(cons symbol)
1288                          #'pprint-fun-call -1)
1289     (set-pprint-dispatch 'cons #'pprint-fill -2)
1290     ;; cons cells with interesting things for the car
1291     (/show0 "doing SET-PPRINT-DISPATCH for CONS with interesting CAR")
1292
1293     (dolist (magic-form '((lambda pprint-lambda)
1294
1295                           ;; special forms
1296                           (block pprint-block)
1297                           (catch pprint-block)
1298                           (eval-when pprint-block)
1299                           (flet pprint-flet)
1300                           (function pprint-quote)
1301                           (labels pprint-flet)
1302                           (let pprint-let)
1303                           (let* pprint-let)
1304                           (locally pprint-progn)
1305                           (macrolet pprint-flet)
1306                           (multiple-value-call pprint-block)
1307                           (multiple-value-prog1 pprint-block)
1308                           (progn pprint-progn)
1309                           (progv pprint-progv)
1310                           (quote pprint-quote)
1311                           (return-from pprint-block)
1312                           (setq pprint-setq)
1313                           (symbol-macrolet pprint-let)
1314                           (tagbody pprint-tagbody)
1315                           (throw pprint-block)
1316                           (unwind-protect pprint-block)
1317
1318                           ;; macros
1319                           (case pprint-case)
1320                           (ccase pprint-case)
1321                           (ctypecase pprint-typecase)
1322                           (defconstant pprint-block)
1323                           (define-modify-macro pprint-defun)
1324                           (define-setf-expander pprint-defun)
1325                           (defmacro pprint-defun)
1326                           (defparameter pprint-block)
1327                           (defsetf pprint-defun)
1328                           (defstruct pprint-block)
1329                           (deftype pprint-defun)
1330                           (defun pprint-defun)
1331                           (defvar pprint-block)
1332                           (destructuring-bind pprint-destructuring-bind)
1333                           (do pprint-do)
1334                           (do* pprint-do)
1335                           (do-all-symbols pprint-dolist)
1336                           (do-external-symbols pprint-dolist)
1337                           (do-symbols pprint-dolist)
1338                           (dolist pprint-dolist)
1339                           (dotimes pprint-dolist)
1340                           (ecase pprint-case)
1341                           (etypecase pprint-typecase)
1342                           #+nil (handler-bind ...)
1343                           #+nil (handler-case ...)
1344                           #+nil (loop ...)
1345                           (multiple-value-bind pprint-progv)
1346                           (multiple-value-setq pprint-block)
1347                           (pprint-logical-block pprint-block)
1348                           (print-unreadable-object pprint-block)
1349                           (prog pprint-prog)
1350                           (prog* pprint-prog)
1351                           (prog1 pprint-block)
1352                           (prog2 pprint-progv)
1353                           (psetf pprint-setq)
1354                           (psetq pprint-setq)
1355                           #+nil (restart-bind ...)
1356                           #+nil (restart-case ...)
1357                           (setf pprint-setq)
1358                           (step pprint-progn)
1359                           (time pprint-progn)
1360                           (typecase pprint-typecase)
1361                           (unless pprint-block)
1362                           (when pprint-block)
1363                           (with-compilation-unit pprint-block)
1364                           #+nil (with-condition-restarts ...)
1365                           (with-hash-table-iterator pprint-block)
1366                           (with-input-from-string pprint-block)
1367                           (with-open-file pprint-block)
1368                           (with-open-stream pprint-block)
1369                           (with-output-to-string pprint-block)
1370                           (with-package-iterator pprint-block)
1371                           (with-simple-restart pprint-block)
1372                           (with-standard-io-syntax pprint-progn)))
1373
1374       (set-pprint-dispatch `(cons (eql ,(first magic-form)))
1375                            (symbol-function (second magic-form))))
1376
1377     ;; other pretty-print init forms
1378     (/show0 "about to call !BACKQ-PP-COLD-INIT")
1379     (sb!impl::!backq-pp-cold-init)
1380     (/show0 "leaving !PPRINT-COLD-INIT"))
1381
1382   (setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
1383   (setf *print-pretty* t))