1 ;;;; Common Lisp pretty printer
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 ;;; 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
22 '(and fixnum unsigned-byte
))
23 ;;; The INDEX type is picked up from the kernel package.
27 (defconstant initial-buffer-size
128)
29 (defconstant default-line-length
80)
31 (defstruct (pretty-stream (:include ansi-stream
35 (:constructor make-pretty-stream
(target))
37 ;; Where the output is going to finally go.
38 (target (missing-arg) :type stream
:read-only t
)
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
)
46 ;; If non-nil, a function to call before performing OUT or SOUT
47 (char-out-oneshot-hook nil
:type
(or null function
))
48 ;; A simple string holding all the text that has been output but not yet
50 (buffer (make-string initial-buffer-size
) :type
(simple-array character
(*)))
51 ;; The index into BUFFER where more text should be put.
52 (buffer-fill-pointer 0 :type index
)
53 ;; Whenever we output stuff from the buffer, we shift the remaining noise
54 ;; over. This makes it difficult to keep references to locations in
55 ;; the buffer. Therefore, we have to keep track of the total amount of
56 ;; stuff that has been shifted out of the buffer.
57 (buffer-offset 0 :type posn
)
58 ;; The column the first character in the buffer will appear in. Normally
59 ;; zero, but if we end up with a very long line with no breaks in it we
60 ;; might have to output part of it. Then this will no longer be zero.
61 (buffer-start-column (or (sb!impl
::charpos target
) 0) :type column
)
62 ;; The line number we are currently on. Used for *PRINT-LINES*
63 ;; abbreviations and to tell when sections have been split across
65 (line-number 0 :type index
)
66 ;; the value of *PRINT-LINES* captured at object creation time. We
67 ;; use this, instead of the dynamic *PRINT-LINES*, to avoid
69 ;; (let ((*print-lines* 50))
70 ;; (pprint-logical-block ..
72 ;; (let ((*print-lines* 8))
73 ;; (print (aref possiblybigthings i) prettystream)))))
74 ;; terminating the output of the entire logical blockafter 8 lines.
75 (print-lines *print-lines
* :type
(or index null
) :read-only t
)
76 ;; Stack of logical blocks in effect at the buffer start.
77 (blocks (list (make-logical-block)) :type list
)
78 ;; Buffer holding the per-line prefix active at the buffer start.
79 ;; Indentation is included in this. The length of this is stored
80 ;; in the logical block stack.
81 (prefix (make-string initial-buffer-size
) :type
(simple-array character
(*)))
82 ;; Buffer holding the total remaining suffix active at the buffer start.
83 ;; The characters are right-justified in the buffer to make it easier
84 ;; to output the buffer. The length is stored in the logical block
86 (suffix (make-string initial-buffer-size
) :type
(simple-array character
(*)))
87 ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
88 ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
89 ;; cons. Adding things to the queue is basically (setf (cdr head) (list
90 ;; new)) and removing them is basically (pop tail) [except that care must
91 ;; be taken to handle the empty queue case correctly.]
92 (queue-tail nil
:type list
)
93 (queue-head nil
:type list
)
94 ;; Block-start queue entries in effect at the queue head.
95 (pending-blocks nil
:type list
))
96 (def!method print-object
((pstream pretty-stream
) stream
)
97 ;; FIXME: CMU CL had #+NIL'ed out this code and done a hand-written
98 ;; FORMAT hack instead. Make sure that this code actually works instead
99 ;; of falling into infinite regress or something.
100 (print-unreadable-object (pstream stream
:type t
:identity t
)))
102 #!-sb-fluid
(declaim (inline index-posn posn-index posn-column
))
103 (defun index-posn (index stream
)
104 (declare (type index index
) (type pretty-stream stream
)
106 (+ index
(pretty-stream-buffer-offset stream
)))
107 (defun posn-index (posn stream
)
108 (declare (type posn posn
) (type pretty-stream stream
)
110 (- posn
(pretty-stream-buffer-offset stream
)))
111 (defun posn-column (posn stream
)
112 (declare (type posn posn
) (type pretty-stream stream
)
114 (index-column (posn-index posn stream
) stream
))
116 ;;; Is it OK to do pretty printing on this stream at this time?
117 (defun print-pretty-on-stream-p (stream)
118 (and (pretty-stream-p stream
)
121 ;;;; stream interface routines
123 (defun pretty-out (stream char
)
124 (declare (type pretty-stream stream
)
125 (type character char
))
126 (let ((f (pretty-stream-char-out-oneshot-hook stream
)))
128 (setf (pretty-stream-char-out-oneshot-hook stream
) nil
)
129 (funcall f stream char
)))
130 (cond ((char= char
#\newline
)
131 (enqueue-newline stream
:literal
))
133 (ensure-space-in-buffer stream
1)
134 (let ((fill-pointer (pretty-stream-buffer-fill-pointer stream
)))
135 (setf (schar (pretty-stream-buffer stream
) fill-pointer
) char
)
136 (setf (pretty-stream-buffer-fill-pointer stream
)
137 (1+ fill-pointer
))))))
139 (defun pretty-sout (stream string start end
)
140 (declare (type pretty-stream stream
)
141 (type simple-string string
)
143 (type (or index null
) end
))
144 (let* ((end (or end
(length string
))))
145 (unless (= start end
)
146 (sb!impl
::string-dispatch
(simple-base-string
148 (simple-array character
(*)))
150 ;; For POSITION transform
151 (declare (optimize (speed 2)))
152 (let ((f (pretty-stream-char-out-oneshot-hook stream
)))
154 (setf (pretty-stream-char-out-oneshot-hook stream
) nil
)
155 (funcall f stream
(aref string start
))))
156 (let ((newline (position #\newline string
:start start
:end end
)))
159 (pretty-sout stream string start newline
)
160 (enqueue-newline stream
:literal
)
161 (pretty-sout stream string
(1+ newline
) end
))
163 (let ((chars (- end start
)))
165 (let* ((available (ensure-space-in-buffer stream chars
))
166 (count (min available chars
))
167 (fill-pointer (pretty-stream-buffer-fill-pointer
169 (new-fill-ptr (+ fill-pointer count
)))
170 (if (typep string
'simple-base-string
)
171 ;; FIXME: Reimplementing REPLACE, since it
172 ;; can't be inlined and we don't have a
173 ;; generic "simple-array -> simple-array"
175 (loop for i from fill-pointer below new-fill-ptr
177 with target
= (pretty-stream-buffer stream
)
178 do
(setf (aref target i
)
180 (replace (pretty-stream-buffer stream
)
182 :start1 fill-pointer
:end1 new-fill-ptr
184 (setf (pretty-stream-buffer-fill-pointer stream
)
189 (incf start count
)))))))))))
191 (defun pretty-misc (stream op
&optional arg1 arg2
)
192 (declare (ignore stream op arg1 arg2
)))
196 (defstruct (logical-block (:copier nil
))
197 ;; The column this logical block started in.
198 (start-column 0 :type column
)
199 ;; The column the current section started in.
200 (section-column 0 :type column
)
201 ;; The length of the per-line prefix. We can't move the indentation
203 (per-line-prefix-end 0 :type index
)
204 ;; The overall length of the prefix, including any indentation.
205 (prefix-length 0 :type index
)
206 ;; The overall length of the suffix.
207 (suffix-length 0 :type index
)
209 (section-start-line 0 :type index
))
211 (defun really-start-logical-block (stream column prefix suffix
)
212 (let* ((blocks (pretty-stream-blocks stream
))
213 (prev-block (car blocks
))
214 (per-line-end (logical-block-per-line-prefix-end prev-block
))
215 (prefix-length (logical-block-prefix-length prev-block
))
216 (suffix-length (logical-block-suffix-length prev-block
))
217 (block (make-logical-block
219 :section-column column
220 :per-line-prefix-end per-line-end
221 :prefix-length prefix-length
222 :suffix-length suffix-length
223 :section-start-line
(pretty-stream-line-number stream
))))
224 (setf (pretty-stream-blocks stream
) (cons block blocks
))
225 (set-indentation stream column
)
227 (setf (logical-block-per-line-prefix-end block
) column
)
228 (replace (pretty-stream-prefix stream
) prefix
229 :start1
(- column
(length prefix
)) :end1 column
))
231 (let* ((total-suffix (pretty-stream-suffix stream
))
232 (total-suffix-len (length total-suffix
))
233 (additional (length suffix
))
234 (new-suffix-len (+ suffix-length additional
)))
235 (when (> new-suffix-len total-suffix-len
)
236 (let ((new-total-suffix-len
237 (max (* total-suffix-len
2)
239 (floor (* additional
5) 4)))))
241 (replace (make-string new-total-suffix-len
) total-suffix
242 :start1
(- new-total-suffix-len suffix-length
)
243 :start2
(- total-suffix-len suffix-length
)))
244 (setf total-suffix-len new-total-suffix-len
)
245 (setf (pretty-stream-suffix stream
) total-suffix
)))
246 (replace total-suffix suffix
247 :start1
(- total-suffix-len new-suffix-len
)
248 :end1
(- total-suffix-len suffix-length
))
249 (setf (logical-block-suffix-length block
) new-suffix-len
))))
252 (defun set-indentation (stream column
)
253 (let* ((prefix (pretty-stream-prefix stream
))
254 (prefix-len (length prefix
))
255 (block (car (pretty-stream-blocks stream
)))
256 (current (logical-block-prefix-length block
))
257 (minimum (logical-block-per-line-prefix-end block
))
258 (column (max minimum column
)))
259 (when (> column prefix-len
)
261 (replace (make-string (max (* prefix-len
2)
263 (floor (* (- column prefix-len
) 5)
267 (setf (pretty-stream-prefix stream
) prefix
))
268 (when (> column current
)
269 (fill prefix
#\space
:start current
:end column
))
270 (setf (logical-block-prefix-length block
) column
)))
272 (defun really-end-logical-block (stream)
273 (let* ((old (pop (pretty-stream-blocks stream
)))
274 (old-indent (logical-block-prefix-length old
))
275 (new (car (pretty-stream-blocks stream
)))
276 (new-indent (logical-block-prefix-length new
)))
277 (when (> new-indent old-indent
)
278 (fill (pretty-stream-prefix stream
) #\space
279 :start old-indent
:end new-indent
)))
282 ;;;; the pending operation queue
284 (defstruct (queued-op (:constructor nil
)
288 (defmacro enqueue
(stream type
&rest args
)
289 (let ((constructor (symbolicate "MAKE-" type
)))
290 (once-only ((stream stream
)
291 (entry `(,constructor
:posn
293 (pretty-stream-buffer-fill-pointer
298 (head `(pretty-stream-queue-head ,stream
)))
301 (setf (cdr ,head
) ,op
)
302 (setf (pretty-stream-queue-tail ,stream
) ,op
))
303 (setf (pretty-stream-queue-head ,stream
) ,op
)
306 (defstruct (section-start (:include queued-op
)
309 (depth 0 :type index
)
310 (section-end nil
:type
(or null newline block-end
)))
312 (defstruct (newline (:include section-start
)
315 :type
(member :linear
:fill
:miser
:literal
:mandatory
)))
317 (defun enqueue-newline (stream kind
)
318 (let* ((depth (length (pretty-stream-pending-blocks stream
)))
319 (newline (enqueue stream newline
:kind kind
:depth depth
)))
320 (dolist (entry (pretty-stream-queue-tail stream
))
321 (when (and (not (eq newline entry
))
322 (section-start-p entry
)
323 (null (section-start-section-end entry
))
324 (<= depth
(section-start-depth entry
)))
325 (setf (section-start-section-end entry
) newline
))))
326 (maybe-output stream
(or (eq kind
:literal
) (eq kind
:mandatory
))))
328 (defstruct (indentation (:include queued-op
)
330 (kind (missing-arg) :type
(member :block
:current
))
331 (amount 0 :type fixnum
))
333 (defun enqueue-indent (stream kind amount
)
334 (enqueue stream indentation
:kind kind
:amount amount
))
336 (defstruct (block-start (:include section-start
)
338 (block-end nil
:type
(or null block-end
))
339 (prefix nil
:type
(or null simple-string
))
340 (suffix nil
:type
(or null simple-string
)))
342 (defun start-logical-block (stream prefix per-line-p suffix
)
343 ;; (In the PPRINT-LOGICAL-BLOCK form which calls us,
344 ;; :PREFIX and :PER-LINE-PREFIX have hairy defaulting behavior,
345 ;; and might end up being NIL.)
346 (declare (type (or null string
) prefix
))
347 ;; (But the defaulting behavior of PPRINT-LOGICAL-BLOCK :SUFFIX is
348 ;; trivial, so it should always be a string.)
349 (declare (type string suffix
))
351 (unless (typep prefix
'simple-string
)
352 (setq prefix
(coerce prefix
'(simple-array character
(*)))))
353 (pretty-sout stream prefix
0 (length prefix
)))
354 (unless (typep suffix
'simple-string
)
355 (setq suffix
(coerce suffix
'(simple-array character
(*)))))
356 (let* ((pending-blocks (pretty-stream-pending-blocks stream
))
357 (start (enqueue stream block-start
358 :prefix
(and per-line-p prefix
)
360 :depth
(length pending-blocks
))))
361 (setf (pretty-stream-pending-blocks stream
)
362 (cons start pending-blocks
))))
364 (defstruct (block-end (:include queued-op
)
366 (suffix nil
:type
(or null simple-string
)))
368 (defun end-logical-block (stream)
369 (let* ((start (pop (pretty-stream-pending-blocks stream
)))
370 (suffix (block-start-suffix start
))
371 (end (enqueue stream block-end
:suffix suffix
)))
373 (pretty-sout stream suffix
0 (length suffix
)))
374 (setf (block-start-block-end start
) end
)))
376 (defstruct (tab (:include queued-op
)
378 (sectionp nil
:type
(member t nil
))
379 (relativep nil
:type
(member t nil
))
380 (colnum 0 :type column
)
381 (colinc 0 :type column
))
383 (defun enqueue-tab (stream kind colnum colinc
)
384 (multiple-value-bind (sectionp relativep
)
386 (:line
(values nil nil
))
387 (:line-relative
(values nil t
))
388 (:section
(values t nil
))
389 (:section-relative
(values t t
)))
390 (enqueue stream tab
:sectionp sectionp
:relativep relativep
391 :colnum colnum
:colinc colinc
)))
395 (defun compute-tab-size (tab section-start column
)
396 (let* ((origin (if (tab-sectionp tab
) section-start
0))
397 (colnum (tab-colnum tab
))
398 (colinc (tab-colinc tab
))
399 (position (- column origin
)))
400 (cond ((tab-relativep tab
)
401 (unless (<= colinc
1)
402 (let ((newposn (+ position colnum
)))
403 (let ((rem (rem newposn colinc
)))
405 (incf colnum
(- colinc rem
))))))
412 (rem (- position colnum
) colinc
))))))
414 (defun index-column (index stream
)
415 (let ((column (pretty-stream-buffer-start-column stream
))
416 (section-start (logical-block-section-column
417 (first (pretty-stream-blocks stream
))))
418 (end-posn (index-posn index stream
)))
419 (dolist (op (pretty-stream-queue-tail stream
))
420 (when (>= (queued-op-posn op
) end-posn
)
428 (posn-index (tab-posn op
)
430 ((or newline block-start
)
432 (+ column
(posn-index (queued-op-posn op
)
436 (defun expand-tabs (stream through
)
437 (let ((insertions nil
)
439 (column (pretty-stream-buffer-start-column stream
))
440 (section-start (logical-block-section-column
441 (first (pretty-stream-blocks stream
)))))
442 (dolist (op (pretty-stream-queue-tail stream
))
445 (let* ((index (posn-index (tab-posn op
) stream
))
446 (tabsize (compute-tab-size op
449 (unless (zerop tabsize
)
450 (push (cons index tabsize
) insertions
)
451 (incf additional tabsize
)
452 (incf column tabsize
))))
453 ((or newline block-start
)
455 (+ column
(posn-index (queued-op-posn op
) stream
)))))
456 (when (eq op through
)
459 (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream
))
460 (new-fill-ptr (+ fill-ptr additional
))
461 (buffer (pretty-stream-buffer stream
))
463 (length (length buffer
))
465 (when (> new-fill-ptr length
)
466 (let ((new-length (max (* length
2)
468 (floor (* additional
5) 4)))))
469 (setf new-buffer
(make-string new-length
))
470 (setf (pretty-stream-buffer stream
) new-buffer
)))
471 (setf (pretty-stream-buffer-fill-pointer stream
) new-fill-ptr
)
472 (decf (pretty-stream-buffer-offset stream
) additional
)
473 (dolist (insertion insertions
)
474 (let* ((srcpos (car insertion
))
475 (amount (cdr insertion
))
476 (dstpos (+ srcpos additional
)))
477 (replace new-buffer buffer
:start1 dstpos
:start2 srcpos
:end2 end
)
478 (fill new-buffer
#\space
:start
(- dstpos amount
) :end dstpos
)
479 (decf additional amount
)
481 (unless (eq new-buffer buffer
)
482 (replace new-buffer buffer
:end1 end
:end2 end
))))))
484 ;;;; stuff to do the actual outputting
486 (defun ensure-space-in-buffer (stream want
)
487 (declare (type pretty-stream stream
)
489 (let* ((buffer (pretty-stream-buffer stream
))
490 (length (length buffer
))
491 (fill-ptr (pretty-stream-buffer-fill-pointer stream
))
492 (available (- length fill-ptr
)))
493 (cond ((plusp available
)
495 ((> fill-ptr
(pretty-stream-line-length stream
))
496 (unless (maybe-output stream nil
)
497 (output-partial-line stream
))
498 (ensure-space-in-buffer stream want
))
500 (let* ((new-length (max (* length
2)
502 (floor (* want
5) 4))))
503 (new-buffer (make-string new-length
)))
504 (setf (pretty-stream-buffer stream
) new-buffer
)
505 (replace new-buffer buffer
:end1 fill-ptr
)
506 (- new-length fill-ptr
))))))
508 (defun maybe-output (stream force-newlines-p
)
509 (declare (type pretty-stream stream
))
510 (let ((tail (pretty-stream-queue-tail stream
))
511 (output-anything nil
))
514 (setf (pretty-stream-queue-head stream
) nil
)
516 (let ((next (pop tail
)))
519 (when (ecase (newline-kind next
)
520 ((:literal
:mandatory
:linear
) t
)
521 (:miser
(misering-p stream
))
523 (or (misering-p stream
)
524 (> (pretty-stream-line-number stream
)
525 (logical-block-section-start-line
526 (first (pretty-stream-blocks stream
))))
527 (ecase (fits-on-line-p stream
528 (newline-section-end next
)
534 (setf output-anything t
)
535 (output-line stream next
)))
537 (unless (misering-p stream
)
538 (set-indentation stream
539 (+ (ecase (indentation-kind next
)
541 (logical-block-start-column
542 (car (pretty-stream-blocks stream
))))
545 (indentation-posn next
)
547 (indentation-amount next
)))))
549 (ecase (fits-on-line-p stream
(block-start-section-end next
)
552 ;; Just nuke the whole logical block and make it look
553 ;; like one nice long literal.
554 (let ((end (block-start-block-end next
)))
555 (expand-tabs stream end
)
556 (setf tail
(cdr (member end tail
)))))
558 (really-start-logical-block
560 (posn-column (block-start-posn next
) stream
)
561 (block-start-prefix next
)
562 (block-start-suffix next
)))
566 (really-end-logical-block stream
))
568 (expand-tabs stream next
))))
569 (setf (pretty-stream-queue-tail stream
) tail
))
572 (defun misering-p (stream)
573 (declare (type pretty-stream stream
))
574 (and *print-miser-width
*
575 (<= (- (pretty-stream-line-length stream
)
576 (logical-block-start-column (car (pretty-stream-blocks stream
))))
577 *print-miser-width
*)))
579 (defun fits-on-line-p (stream until force-newlines-p
)
580 (let ((available (pretty-stream-line-length stream
)))
581 (when (and (not *print-readably
*)
582 (pretty-stream-print-lines stream
)
583 (= (pretty-stream-print-lines stream
)
584 (pretty-stream-line-number stream
)))
585 (decf available
3) ; for the `` ..''
586 (decf available
(logical-block-suffix-length
587 (car (pretty-stream-blocks stream
)))))
589 (<= (posn-column (queued-op-posn until
) stream
) available
))
590 (force-newlines-p nil
)
591 ((> (index-column (pretty-stream-buffer-fill-pointer stream
) stream
)
597 (defun output-line (stream until
)
598 (declare (type pretty-stream stream
)
599 (type newline until
))
600 (let* ((target (pretty-stream-target stream
))
601 (buffer (pretty-stream-buffer stream
))
602 (kind (newline-kind until
))
603 (literal-p (eq kind
:literal
))
604 (amount-to-consume (posn-index (newline-posn until
) stream
))
608 (let ((last-non-blank
609 (position #\space buffer
:end amount-to-consume
610 :from-end t
:test
#'char
/=)))
614 (write-string buffer target
:end amount-to-print
)
615 (let ((line-number (pretty-stream-line-number stream
)))
617 (when (and (not *print-readably
*)
618 (pretty-stream-print-lines stream
)
619 (>= line-number
(pretty-stream-print-lines stream
)))
620 (write-string " .." target
)
621 (let ((suffix-length (logical-block-suffix-length
622 (car (pretty-stream-blocks stream
)))))
623 (unless (zerop suffix-length
)
624 (let* ((suffix (pretty-stream-suffix stream
))
625 (len (length suffix
)))
626 (write-string suffix target
627 :start
(- len suffix-length
)
629 (throw 'line-limit-abbreviation-happened t
))
630 (setf (pretty-stream-line-number stream
) line-number
)
631 (write-char #\newline target
)
632 (setf (pretty-stream-buffer-start-column stream
) 0)
633 (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream
))
634 (block (first (pretty-stream-blocks stream
)))
637 (logical-block-per-line-prefix-end block
)
638 (logical-block-prefix-length block
)))
639 (shift (- amount-to-consume prefix-len
))
640 (new-fill-ptr (- fill-ptr shift
))
642 (buffer-length (length buffer
)))
643 (when (> new-fill-ptr buffer-length
)
645 (make-string (max (* buffer-length
2)
647 (floor (* (- new-fill-ptr buffer-length
)
650 (setf (pretty-stream-buffer stream
) new-buffer
))
651 (replace new-buffer buffer
652 :start1 prefix-len
:start2 amount-to-consume
:end2 fill-ptr
)
653 (replace new-buffer
(pretty-stream-prefix stream
)
655 (setf (pretty-stream-buffer-fill-pointer stream
) new-fill-ptr
)
656 (incf (pretty-stream-buffer-offset stream
) shift
)
658 (setf (logical-block-section-column block
) prefix-len
)
659 (setf (logical-block-section-start-line block
) line-number
))))))
661 (defun output-partial-line (stream)
662 (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream
))
663 (tail (pretty-stream-queue-tail stream
))
666 (posn-index (queued-op-posn (car tail
)) stream
)
668 (new-fill-ptr (- fill-ptr count
))
669 (buffer (pretty-stream-buffer stream
)))
671 (error "Output-partial-line called when nothing can be output."))
672 (write-string buffer
(pretty-stream-target stream
)
674 (incf (pretty-stream-buffer-start-column stream
) count
)
675 (replace buffer buffer
:end1 new-fill-ptr
:start2 count
:end2 fill-ptr
)
676 (setf (pretty-stream-buffer-fill-pointer stream
) new-fill-ptr
)
677 (incf (pretty-stream-buffer-offset stream
) count
)))
679 (defun force-pretty-output (stream)
680 (maybe-output stream nil
)
681 (expand-tabs stream nil
)
682 (write-string (pretty-stream-buffer stream
)
683 (pretty-stream-target stream
)
684 :end
(pretty-stream-buffer-fill-pointer stream
)))
686 ;;;; user interface to the pretty printer
688 (defun pprint-newline (kind &optional stream
)
690 "Output a conditional newline to STREAM (which defaults to
691 *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do
692 nothing if not. KIND can be one of:
693 :LINEAR - A line break is inserted if and only if the immediately
694 containing section cannot be printed on one line.
695 :MISER - Same as LINEAR, but only if ``miser-style'' is in effect.
696 (See *PRINT-MISER-WIDTH*.)
697 :FILL - A line break is inserted if and only if either:
698 (a) the following section cannot be printed on the end of the
700 (b) the preceding section was not printed on a single line, or
701 (c) the immediately containing section cannot be printed on one
702 line and miser-style is in effect.
703 :MANDATORY - A line break is always inserted.
704 When a line break is inserted by any type of conditional newline, any
705 blanks that immediately precede the conditional newline are omitted
706 from the output and indentation is introduced at the beginning of the
707 next line. (See PPRINT-INDENT.)"
708 (declare (type (member :linear
:miser
:fill
:mandatory
) kind
)
709 (type (or stream
(member t nil
)) stream
)
711 (let ((stream (case stream
713 ((nil) *standard-output
*)
715 (when (print-pretty-on-stream-p stream
)
716 (enqueue-newline stream kind
)))
719 (defun pprint-indent (relative-to n
&optional stream
)
721 "Specify the indentation to use in the current logical block if
722 STREAM \(which defaults to *STANDARD-OUTPUT*) is a pretty-printing
723 stream and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the
724 indentation to use (in ems, the width of an ``m'') and RELATIVE-TO can
727 :BLOCK - Indent relative to the column the current logical block
730 :CURRENT - Indent relative to the current column.
732 The new indentation value does not take effect until the following
734 (declare (type (member :block
:current
) relative-to
)
736 (type (or stream
(member t nil
)) stream
)
738 (let ((stream (case stream
740 ((nil) *standard-output
*)
742 (when (print-pretty-on-stream-p stream
)
743 (enqueue-indent stream relative-to
(truncate n
))))
746 (defun pprint-tab (kind colnum colinc
&optional stream
)
748 "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing
749 stream, perform tabbing based on KIND, otherwise do nothing. KIND can
751 :LINE - Tab to column COLNUM. If already past COLNUM tab to the next
753 :SECTION - Same as :LINE, but count from the start of the current
754 section, not the start of the line.
755 :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of
757 :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start
758 of the current section, not the start of the line."
759 (declare (type (member :line
:section
:line-relative
:section-relative
) kind
)
760 (type unsigned-byte colnum colinc
)
761 (type (or stream
(member t nil
)) stream
)
763 (let ((stream (case stream
765 ((nil) *standard-output
*)
767 (when (print-pretty-on-stream-p stream
)
768 (enqueue-tab stream kind colnum colinc
)))
771 (defun pprint-fill (stream list
&optional
(colon? t
) atsign?
)
773 "Output LIST to STREAM putting :FILL conditional newlines between each
774 element. If COLON? is NIL (defaults to T), then no parens are printed
775 around the output. ATSIGN? is ignored (but allowed so that PPRINT-FILL
776 can be used with the ~/.../ format directive."
777 (declare (ignore atsign?
))
778 (pprint-logical-block (stream list
779 :prefix
(if colon?
"(" "")
780 :suffix
(if colon?
")" ""))
781 (pprint-exit-if-list-exhausted)
783 (output-object (pprint-pop) stream
)
784 (pprint-exit-if-list-exhausted)
785 (write-char #\space stream
)
786 (pprint-newline :fill stream
))))
788 (defun pprint-linear (stream list
&optional
(colon? t
) atsign?
)
790 "Output LIST to STREAM putting :LINEAR conditional newlines between each
791 element. If COLON? is NIL (defaults to T), then no parens are printed
792 around the output. ATSIGN? is ignored (but allowed so that PPRINT-LINEAR
793 can be used with the ~/.../ format directive."
794 (declare (ignore atsign?
))
795 (pprint-logical-block (stream list
796 :prefix
(if colon?
"(" "")
797 :suffix
(if colon?
")" ""))
798 (pprint-exit-if-list-exhausted)
800 (output-object (pprint-pop) stream
)
801 (pprint-exit-if-list-exhausted)
802 (write-char #\space stream
)
803 (pprint-newline :linear stream
))))
805 (defun pprint-tabular (stream list
&optional
(colon? t
) atsign? tabsize
)
807 "Output LIST to STREAM tabbing to the next column that is an even multiple
808 of TABSIZE (which defaults to 16) between each element. :FILL style
809 conditional newlines are also output between each element. If COLON? is
810 NIL (defaults to T), then no parens are printed around the output.
811 ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with
812 the ~/.../ format directive."
813 (declare (ignore atsign?
))
814 (pprint-logical-block (stream list
815 :prefix
(if colon?
"(" "")
816 :suffix
(if colon?
")" ""))
817 (pprint-exit-if-list-exhausted)
819 (output-object (pprint-pop) stream
)
820 (pprint-exit-if-list-exhausted)
821 (write-char #\space stream
)
822 (pprint-tab :section-relative
0 (or tabsize
16) stream
)
823 (pprint-newline :fill stream
))))
825 ;;;; pprint-dispatch tables
827 (defvar *standard-pprint-dispatch-table
*)
828 (defvar *initial-pprint-dispatch-table
*)
830 (defstruct (pprint-dispatch-entry (:copier nil
))
831 ;; the type specifier for this entry
832 (type (missing-arg) :type t
:read-only t
)
833 ;; a function to test to see whether an object is of this type,
834 ;; either (LAMBDA (OBJ) (TYPEP OBJECT TYPE)) or a builtin predicate.
835 ;; We don't bother computing this for entries in the CONS
836 ;; hash table, because we don't need it.
837 (test-fn nil
:type
(or function null
) :read-only t
)
838 ;; the priority for this guy
839 (priority 0 :type real
:read-only t
)
840 ;; T iff one of the original entries.
841 (initial-p (eq *initial-pprint-dispatch-table
* nil
)
842 :type
(member t nil
) :read-only t
)
843 ;; and the associated function
844 (fun (missing-arg) :type callable
:read-only t
))
845 (def!method print-object
((entry pprint-dispatch-entry
) stream
)
846 (print-unreadable-object (entry stream
:type t
)
847 (format stream
"type=~S, priority=~S~@[ [initial]~]"
848 (pprint-dispatch-entry-type entry
)
849 (pprint-dispatch-entry-priority entry
)
850 (pprint-dispatch-entry-initial-p entry
))))
852 (defun cons-type-specifier-p (spec)
853 (typep spec
'(cons (eql cons
)
854 (cons (cons (member eql member
) (cons t null
))
857 ;; Return T iff E1 is strictly less preferable than E2.
858 (defun entry< (e1 e2
)
859 (declare (type pprint-dispatch-entry e1 e2
))
860 (if (pprint-dispatch-entry-initial-p e1
)
861 (if (pprint-dispatch-entry-initial-p e2
)
862 (< (pprint-dispatch-entry-priority e1
)
863 (pprint-dispatch-entry-priority e2
))
865 (if (pprint-dispatch-entry-initial-p e2
)
867 (< (pprint-dispatch-entry-priority e1
)
868 (pprint-dispatch-entry-priority e2
)))))
870 ;; Return the predicate for TYPE. This used to involve rewriting TYPE
871 ;; into a sexpr due to (CONS <t1> <t2>) not being an official specifier.
872 ;; Now that it is, there's nothing magical about it.
873 (defun compute-test-fn (type function
)
874 (declare (special sb
!c
::*backend-type-predicates
*))
875 ;; Avoid compiling code for an existing structure predicate
876 (or (and (eq (info :type
:kind type
) :instance
)
877 (let ((layout (info :type
:compiler-layout type
)))
879 (let ((info (layout-info layout
)))
881 (let ((pred (dd-predicate-name info
)))
882 (and pred
(fboundp pred
)
883 (symbol-function pred
))))))))
884 ;; avoid compiling code for CONS, ARRAY, VECTOR, etc
885 (awhen (assoc (specifier-type type
) sb
!c
::*backend-type-predicates
*
887 (symbol-function (cdr it
)))
888 ;; OK, compile something
890 ;; Keep name as a string, because NAMED-LAMBDA with a symbol
891 ;; affects the global environment, when all you want
892 ;; is to give the lambda a human-readable label.
894 (cond ((symbolp type
) type
)
895 ((symbolp function
) function
)
896 ((%fun-name function
))
898 (write-to-string type
:pretty nil
:escape nil
900 (compile nil
`(named-lambda ,name
(object) (typep object
',type
))))))
902 (defun copy-pprint-dispatch (&optional
(table *print-pprint-dispatch
*))
903 (declare (type (or pprint-dispatch-table null
) table
))
904 (let* ((orig (or table
*initial-pprint-dispatch-table
*))
905 (new (make-pprint-dispatch-table
906 :entries
(copy-list (pprint-dispatch-table-entries orig
)))))
907 (replace/eql-hash-table
(pprint-dispatch-table-cons-entries new
)
908 (pprint-dispatch-table-cons-entries orig
))
911 (defun pprint-dispatch (object &optional
(table *print-pprint-dispatch
*))
912 (declare (type (or pprint-dispatch-table null
) table
))
913 (let* ((table (or table
*initial-pprint-dispatch-table
*))
916 (gethash (car object
)
917 (pprint-dispatch-table-cons-entries table
))))
919 (dolist (entry (pprint-dispatch-table-entries table
) cons-entry
)
920 (when (and cons-entry
921 (entry< entry cons-entry
))
923 (when (funcall (pprint-dispatch-entry-test-fn entry
) object
)
926 (values (pprint-dispatch-entry-fun entry
) t
)
927 (values (lambda (stream object
)
928 (output-ugly-object object stream
))
931 (defun assert-not-standard-pprint-dispatch-table (pprint-dispatch operation
)
932 (when (eq pprint-dispatch
*standard-pprint-dispatch-table
*)
933 (cerror "Frob it anyway!" 'standard-pprint-dispatch-table-modified-error
934 :operation operation
)))
936 ;; The dispatch mechanism is not quite sophisticated enough to have a guard
937 ;; condition on CONS entries. One place this would impact is that you could
938 ;; write the full matcher for QUOTE as just a type-specifier. It can be done
939 ;; now, but using the non-cons table entails linear scan.
940 ;; A test-fn in the cons table would require storing multiple entries per
941 ;; key though because any might fail. Conceivably you could have
942 ;; (cons (eql foo) cons) and (cons (eql foo) bit-vector) as two FOO entries.
943 (defun set-pprint-dispatch (type function
&optional
944 (priority 0) (table *print-pprint-dispatch
*))
945 (declare (type (or null callable
) function
)
947 (type pprint-dispatch-table table
))
948 (/show0
"entering SET-PPRINT-DISPATCH, TYPE=...")
950 (assert-not-standard-pprint-dispatch-table table
'set-pprint-dispatch
)
951 (let* ((consp (cons-type-specifier-p type
))
953 (make-pprint-dispatch-entry
955 :test-fn
(unless consp
(compute-test-fn type function
))
956 :priority priority
:fun function
))))
958 (let ((hashtable (pprint-dispatch-table-cons-entries table
))
959 (key (second (second type
))))
961 (setf (gethash key hashtable
) entry
)
962 (remhash key hashtable
)))
963 (setf (pprint-dispatch-table-entries table
)
964 (let ((list (delete type
(pprint-dispatch-table-entries table
)
965 :key
#'pprint-dispatch-entry-type
968 ;; ENTRY< is T if lower in priority, which should sort to
969 ;; the end, but MERGE's predicate wants T for the (a,b) pair
970 ;; if 'a' should go in front of 'b', so swap them.
971 ;; (COMPLEMENT #'entry<) is unstable wrt insertion order.
972 (merge 'list list
(list entry
) (lambda (a b
) (entry< b a
)))
974 (/show0
"about to return NIL from SET-PPRINT-DISPATCH")
977 ;;;; standard pretty-printing routines
979 (defun pprint-array (stream array
)
980 (cond ((and (null *print-array
*) (null *print-readably
*))
981 (output-ugly-object array stream
))
982 ((and *print-readably
*
983 (not (array-readably-printable-p array
)))
986 (sb!impl
::output-unreadable-vector-readably array stream
)
987 (sb!impl
::output-unreadable-array-readably array stream
))
988 (print-not-readable-error array stream
)))
990 (pprint-vector stream array
))
992 (pprint-multi-dim-array stream array
))))
994 (defun pprint-vector (stream vector
)
995 (pprint-logical-block (stream nil
:prefix
"#(" :suffix
")")
996 (dotimes (i (length vector
))
998 (format stream
" ~:_"))
1000 (output-object (aref vector i
) stream
))))
1002 (defun pprint-multi-dim-array (stream array
)
1003 (funcall (formatter "#~DA") stream
(array-rank array
))
1004 (with-array-data ((data array
) (start) (end))
1005 (declare (ignore end
))
1006 (labels ((output-guts (stream index dimensions
)
1007 (if (null dimensions
)
1008 (output-object (aref data index
) stream
)
1009 (pprint-logical-block
1010 (stream nil
:prefix
"(" :suffix
")")
1011 (let ((dim (car dimensions
)))
1013 (let* ((dims (cdr dimensions
))
1015 (step (reduce #'* dims
))
1019 (output-guts stream index dims
)
1020 (when (= (incf count
) dim
)
1022 (write-char #\space stream
)
1023 (pprint-newline (if dims
:linear
:fill
)
1025 (incf index step
)))))))))
1026 (output-guts stream start
(array-dimensions array
)))))
1028 (defun pprint-lambda-list (stream lambda-list
&rest noise
)
1029 (declare (ignore noise
))
1030 (pprint-logical-block (stream lambda-list
:prefix
"(" :suffix
")")
1031 (let ((state :required
)
1034 (pprint-exit-if-list-exhausted)
1036 (write-char #\space stream
))
1037 (let ((arg (pprint-pop)))
1041 (setf state
:optional
)
1042 (pprint-newline :linear stream
))
1044 (setf state
:required
)
1045 (pprint-newline :linear stream
))
1048 (pprint-newline :linear stream
))
1050 (setf state
:optional
)
1051 (pprint-newline :linear stream
))
1053 (pprint-newline :fill stream
))))
1056 (pprint-lambda-list stream arg
))
1058 (pprint-logical-block
1059 (stream arg
:prefix
"(" :suffix
")")
1060 (pprint-exit-if-list-exhausted)
1062 (pprint-logical-block
1063 (stream (pprint-pop) :prefix
"(" :suffix
")")
1064 (pprint-exit-if-list-exhausted)
1065 (output-object (pprint-pop) stream
)
1066 (pprint-exit-if-list-exhausted)
1067 (write-char #\space stream
)
1068 (pprint-newline :fill stream
)
1069 (pprint-lambda-list stream
(pprint-pop))
1071 (pprint-exit-if-list-exhausted)
1072 (write-char #\space stream
)
1073 (pprint-newline :fill stream
)
1074 (output-object (pprint-pop) stream
)))
1075 (pprint-lambda-list stream
(pprint-pop)))
1077 (pprint-exit-if-list-exhausted)
1078 (write-char #\space stream
)
1079 (pprint-newline :linear stream
)
1080 (output-object (pprint-pop) stream
))))))
1081 (setf first nil
)))))
1083 (defun pprint-lambda (stream list
&rest noise
)
1084 (declare (ignore noise
))
1086 ;; KLUDGE: This format string, and other format strings which also
1087 ;; refer to SB!PRETTY, rely on the current SBCL not-quite-ANSI
1088 ;; behavior of FORMATTER in order to make code which survives the
1089 ;; transition when SB!PRETTY is renamed to SB-PRETTY after cold
1090 ;; init. (ANSI says that the FORMATTER functions should be
1091 ;; equivalent to the format string, but the SBCL FORMATTER
1092 ;; functions contain references to package objects, not package
1093 ;; names, so they keep right on going if the packages are renamed.)
1094 ;; If our FORMATTER behavior is ever made more compliant, the code
1095 ;; here will have to change. -- WHN 19991207
1096 "~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
1100 (defun pprint-block (stream list
&rest noise
)
1101 (declare (ignore noise
))
1102 (funcall (formatter "~:<~^~W~^~3I ~:_~W~1I~@{ ~_~W~}~:>") stream list
))
1104 (defun pprint-flet (stream list
&rest noise
)
1105 (declare (ignore noise
))
1106 (if (and (consp list
)
1109 ;; Filter out (FLET FOO :IN BAR) names.
1110 (and (consp (cddr list
))
1111 (not (eq :in
(third list
)))))
1113 "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
1116 ;; for printing function names like (flet foo)
1117 (pprint-logical-block (stream list
:prefix
"(" :suffix
")")
1118 (pprint-exit-if-list-exhausted)
1119 (write (pprint-pop) :stream stream
)
1121 (pprint-exit-if-list-exhausted)
1122 (write-char #\space stream
)
1123 (write (pprint-pop) :stream stream
)))))
1125 (defun pprint-let (stream list
&rest noise
)
1126 (declare (ignore noise
))
1127 (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>")
1131 (defun pprint-progn (stream list
&rest noise
)
1132 (declare (ignore noise
))
1133 (pprint-linear stream list
))
1135 (defun pprint-progv (stream list
&rest noise
)
1136 (declare (ignore noise
))
1137 (funcall (formatter "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>")
1140 (defun pprint-prog2 (stream list
&rest noise
)
1141 (declare (ignore noise
))
1142 (funcall (formatter "~:<~^~W~^~3I ~:_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>")
1145 (defun pprint-unquoting-comma (stream obj
&rest noise
)
1146 (declare (ignore noise
))
1147 (write-string (svref #("," ",." ",@") (comma-kind obj
)) stream
)
1148 (when (eql (comma-kind obj
) 0)
1149 ;; Ensure a space is written before any output that would change the meaning
1150 ;; of the preceding the comma to ",." or ",@" such as a symbol named "@BAR".
1151 (setf (pretty-stream-char-out-oneshot-hook stream
)
1152 (lambda (stream char
)
1153 (when (member char
'(#\.
#\
@))
1154 (write-char #\Space stream
)))))
1155 (output-object (comma-expr obj
) stream
))
1157 (defvar *pprint-quote-with-syntactic-sugar
* t
)
1159 (defun pprint-quote (stream list
&rest noise
)
1160 (declare (ignore noise
))
1161 (when (and (listp list
) (singleton-p (cdr list
)))
1162 (let* ((pretty-p nil
)
1163 (sigil (case (car list
)
1166 ;; QUASIQUOTE can't choose not to print prettily.
1167 ;; Wrongly nested commas beget unreadable sexprs.
1168 (quasiquote (setq pretty-p t
) "`"))))
1169 (when (or pretty-p
*pprint-quote-with-syntactic-sugar
*)
1170 (write-string sigil stream
)
1171 (return-from pprint-quote
(output-object (cadr list
) stream
)))))
1172 (pprint-fill stream list
))
1174 (defun pprint-declare (stream list
&rest noise
)
1175 (declare (ignore noise
))
1176 ;; Make sure to print (DECLARE (FUNCTION F)) not (DECLARE #'A).
1177 (let ((*pprint-quote-with-syntactic-sugar
* nil
))
1178 (pprint-spread-fun-call stream list
)))
1180 ;;; Try to print every variable-value pair on one line; if that doesn't
1181 ;;; work print the value indented by 2 spaces:
1189 (defun pprint-setq (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-exit-if-list-exhausted)
1195 (write-char #\space stream
)
1196 (unless (listp (cdr list
))
1197 (write-string ". " stream
))
1198 (pprint-newline :miser stream
)
1199 (pprint-logical-block (stream (cdr list
) :prefix
"" :suffix
"")
1201 (pprint-indent :block
2 stream
)
1202 (output-object (pprint-pop) stream
)
1203 (pprint-exit-if-list-exhausted)
1204 (write-char #\space stream
)
1205 (pprint-newline :fill stream
)
1206 (pprint-indent :block
0 stream
)
1207 (output-object (pprint-pop) stream
)
1208 (pprint-exit-if-list-exhausted)
1209 (write-char #\space stream
)
1210 (pprint-newline :mandatory stream
)))))
1212 ;;; FIXME: could become SB!XC:DEFMACRO wrapped in EVAL-WHEN (COMPILE EVAL)
1213 (defmacro pprint-tagbody-guts
(stream)
1215 (pprint-exit-if-list-exhausted)
1216 (write-char #\space
,stream
)
1217 (let ((form-or-tag (pprint-pop)))
1218 (pprint-indent :block
1219 (if (atom form-or-tag
) 0 1)
1221 (pprint-newline :linear
,stream
)
1222 (output-object form-or-tag
,stream
))))
1224 (defun pprint-tagbody (stream list
&rest noise
)
1225 (declare (ignore noise
))
1226 (pprint-logical-block (stream list
:prefix
"(" :suffix
")")
1227 (pprint-exit-if-list-exhausted)
1228 (output-object (pprint-pop) stream
)
1229 (pprint-tagbody-guts stream
)))
1231 (defun pprint-case (stream list
&rest noise
)
1232 (declare (ignore noise
))
1234 "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/SB!PRETTY:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>")
1238 (defun pprint-defun (stream list
&rest noise
)
1239 (declare (ignore noise
))
1241 "~:<~^~W~^ ~@_~:I~W~^ ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
1245 (defun pprint-defmethod (stream list
&rest noise
)
1246 (declare (ignore noise
))
1247 (if (and (consp (cdr list
))
1249 (consp (third list
)))
1250 (pprint-defun stream list
)
1252 "~:<~^~W~^ ~@_~:I~W~^ ~W~^ ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
1256 (defun pprint-defpackage (stream list
&rest noise
)
1257 (declare (ignore noise
))
1259 "~:<~W~^ ~3I~:_~W~^~1I~@{~:@_~:<~^~W~^ ~:I~@_~@{~W~^ ~_~}~:>~}~:>")
1263 (defun pprint-destructuring-bind (stream list
&rest noise
)
1264 (declare (ignore noise
))
1266 "~:<~^~W~^~3I ~_~:/SB!PRETTY:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>")
1269 (defun pprint-do (stream list
&rest noise
)
1270 (declare (ignore noise
))
1271 (pprint-logical-block (stream list
:prefix
"(" :suffix
")")
1272 (pprint-exit-if-list-exhausted)
1273 (output-object (pprint-pop) stream
)
1274 (pprint-exit-if-list-exhausted)
1275 (write-char #\space stream
)
1276 (pprint-indent :current
0 stream
)
1277 (funcall (formatter "~:<~@{~:<~^~W~^ ~@_~:I~W~@{ ~_~W~}~:>~^~:@_~}~:>")
1280 (pprint-exit-if-list-exhausted)
1281 (write-char #\space stream
)
1282 (pprint-newline :linear stream
)
1283 (pprint-linear stream
(pprint-pop))
1284 (pprint-tagbody-guts stream
)))
1286 (defun pprint-dolist (stream list
&rest noise
)
1287 (declare (ignore noise
))
1288 (pprint-logical-block (stream list
:prefix
"(" :suffix
")")
1289 (pprint-exit-if-list-exhausted)
1290 (output-object (pprint-pop) stream
)
1291 (pprint-exit-if-list-exhausted)
1292 (pprint-indent :block
3 stream
)
1293 (write-char #\space stream
)
1294 (pprint-newline :fill stream
)
1295 (funcall (formatter "~:<~^~W~^ ~:_~:I~W~@{ ~_~W~}~:>")
1298 (pprint-tagbody-guts stream
)))
1300 (defun pprint-typecase (stream list
&rest noise
)
1301 (declare (ignore noise
))
1303 "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>")
1307 (defun pprint-prog (stream list
&rest noise
)
1308 (declare (ignore noise
))
1309 (pprint-logical-block (stream list
:prefix
"(" :suffix
")")
1310 (pprint-exit-if-list-exhausted)
1311 (output-object (pprint-pop) stream
)
1312 (pprint-exit-if-list-exhausted)
1313 (write-char #\space stream
)
1314 (pprint-newline :miser stream
)
1315 (pprint-fill stream
(pprint-pop))
1316 (pprint-tagbody-guts stream
)))
1318 ;;; Each clause in this list will get its own line.
1319 ;;; FIXME: (LOOP for x in list summing (f x) into count finally ...)
1320 ;;; puts a newline in between INTO and COUNT.
1321 ;;; It would be awesome to have code in common with the macro
1322 ;;; the properly represents each clauses.
1323 (defvar *loop-seperating-clauses
*
1328 :collect
:collecting
1333 :maximize
:maximizing
1334 :minimize
:minimizing
1335 :if
:when
:unless
:end
1336 :for
:while
:until
:repeat
:always
:never
:thereis
1339 (defun pprint-extended-loop (stream list
)
1340 (pprint-logical-block (stream list
:prefix
"(" :suffix
")")
1341 (output-object (pprint-pop) stream
)
1342 (pprint-exit-if-list-exhausted)
1343 (write-char #\space stream
)
1344 (pprint-indent :current
0 stream
)
1345 (output-object (pprint-pop) stream
)
1346 (pprint-exit-if-list-exhausted)
1347 (write-char #\space stream
)
1348 (loop for thing
= (pprint-pop)
1349 when
(and (symbolp thing
)
1350 (member thing
*loop-seperating-clauses
* :test
#'string
=))
1351 do
(pprint-newline :mandatory stream
)
1352 do
(output-object thing stream
)
1353 do
(pprint-exit-if-list-exhausted)
1354 do
(write-char #\space stream
))))
1356 (defun pprint-loop (stream list
&rest noise
)
1357 (declare (ignore noise
))
1358 (destructuring-bind (loop-symbol . clauses
) list
1359 (declare (ignore loop-symbol
))
1360 (if (or (atom clauses
) (consp (car clauses
)))
1361 (pprint-spread-fun-call stream list
)
1362 (pprint-extended-loop stream list
))))
1364 (defun pprint-if (stream list
&rest noise
)
1365 (declare (ignore noise
))
1366 ;; Indent after the ``predicate'' form, and the ``then'' form.
1367 (funcall (formatter "~:<~^~W~^ ~:I~W~^ ~:@_~@{~W~^ ~:@_~}~:>")
1371 (defun pprint-fun-call (stream list
&rest noise
)
1372 (declare (ignore noise
))
1373 (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~:_~}~:>")
1377 (defun pprint-spread-fun-call (stream list
&rest noise
)
1378 (declare (ignore noise
))
1379 ;; Similiar to PPRINT-FUN-CALL but emit a mandatory newline after
1380 ;; each parameter. I.e. spread out each parameter on its own line.
1381 (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~:@_~}~:>")
1385 (defun pprint-data-list (stream list
&rest noise
)
1386 (declare (ignore noise
))
1387 (pprint-fill stream list
))
1389 ;;; Returns an Emacs-style indent spec: an integer N, meaning indent
1390 ;;; the first N arguments specially then indent any further arguments
1392 (defun macro-indentation (name)
1393 (labels ((proper-list-p (list)
1394 (not (nth-value 1 (ignore-errors (list-length list
)))))
1395 (macro-arglist (name)
1396 (%simple-fun-arglist
(macro-function name
)))
1397 (clean-arglist (arglist)
1398 "Remove &whole, &enviroment, and &aux elements from ARGLIST."
1399 (cond ((null arglist
) '())
1400 ((member (car arglist
) '(&whole
&environment
))
1401 (clean-arglist (cddr arglist
)))
1402 ((eq (car arglist
) '&aux
)
1404 (t (cons (car arglist
) (clean-arglist (cdr arglist
)))))))
1405 (let ((arglist (macro-arglist name
)))
1406 (if (proper-list-p arglist
) ; guard against dotted arglists
1407 (position '&body
(remove '&optional
(clean-arglist arglist
)))
1410 ;;; Pretty-Print macros by looking where &BODY appears in a macro's
1412 (defun pprint-macro-call (stream list
&rest noise
)
1413 (declare (ignore noise
))
1414 (let ((indentation (and (car list
) (macro-indentation (car list
)))))
1416 (return-from pprint-macro-call
1417 (pprint-fun-call stream list
)))
1418 (pprint-logical-block (stream list
:prefix
"(" :suffix
")")
1419 (output-object (pprint-pop) stream
)
1420 (pprint-exit-if-list-exhausted)
1421 (write-char #\space stream
)
1422 (loop for indent from
0 below indentation do
1424 ;; Place the very first argument next to the macro name
1426 (output-object (pprint-pop) stream
)
1427 (pprint-exit-if-list-exhausted))
1428 ;; Indent any other non-body argument by the same
1429 ;; amount. It's what Emacs seems to do, too.
1431 (pprint-indent :block
3 stream
)
1432 (pprint-newline :mandatory stream
)
1433 (output-object (pprint-pop) stream
)
1434 (pprint-exit-if-list-exhausted))))
1435 ;; Indent back for the body.
1436 (pprint-indent :block
1 stream
)
1437 (pprint-newline :mandatory stream
)
1439 (output-object (pprint-pop) stream
)
1440 (pprint-exit-if-list-exhausted)
1441 (pprint-newline :mandatory stream
)))))
1443 ;;;; the interface seen by regular (ugly) printer and initialization routines
1445 ;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when
1446 ;;; *PRINT-PRETTY* is true.
1447 (defun output-pretty-object (object stream
)
1448 (multiple-value-bind (fun pretty
) (pprint-dispatch object
)
1450 (with-pretty-stream (stream)
1451 (funcall fun stream object
))
1452 ;; No point in consing up a pretty stream if we are not using pretty
1453 ;; printing the object after all.
1454 (output-ugly-object object stream
))))
1456 (defun !pprint-cold-init
()
1457 (/show0
"entering !PPRINT-COLD-INIT")
1458 ;; Kludge: We set *STANDARD-PP-D-TABLE* to a new table even though
1459 ;; it's going to be set to a copy of *INITIAL-PP-D-T* below because
1460 ;; it's used in WITH-STANDARD-IO-SYNTAX, and condition reportery
1461 ;; possibly performed in the following extent may use W-S-IO-SYNTAX.
1462 (setf *standard-pprint-dispatch-table
* (make-pprint-dispatch-table))
1463 (setf *initial-pprint-dispatch-table
* nil
)
1464 (let ((*print-pprint-dispatch
* (make-pprint-dispatch-table)))
1465 (/show0
"doing SET-PPRINT-DISPATCH for regular types")
1466 (set-pprint-dispatch '(and array
(not (or string bit-vector
))) #'pprint-array
)
1467 ;; MACRO-FUNCTION must have effectively higher priority than FBOUNDP.
1468 ;; The implementation happens to check identical priorities in the order added,
1469 ;; but that's unspecified behavior. Both must be _strictly_ lower than the
1470 ;; default cons entries though.
1471 (set-pprint-dispatch '(cons (and symbol
(satisfies macro-function
)))
1472 #'pprint-macro-call -
1)
1473 (set-pprint-dispatch '(cons (and symbol
(satisfies fboundp
)))
1474 #'pprint-fun-call -
1)
1475 (set-pprint-dispatch '(cons symbol
)
1476 #'pprint-data-list -
2)
1477 (set-pprint-dispatch 'cons
#'pprint-fill -
2)
1478 (set-pprint-dispatch 'sb
!impl
::comma
#'pprint-unquoting-comma -
3)
1479 ;; cons cells with interesting things for the car
1480 (/show0
"doing SET-PPRINT-DISPATCH for CONS with interesting CAR")
1482 (dolist (magic-form '((lambda pprint-lambda
)
1483 (declare pprint-declare
)
1486 (block pprint-block
)
1487 (catch pprint-block
)
1488 (eval-when pprint-block
)
1490 (function pprint-quote
)
1492 (labels pprint-flet
)
1495 (locally pprint-progn
)
1496 (macrolet pprint-flet
)
1497 (multiple-value-call pprint-block
)
1498 (multiple-value-prog1 pprint-block
)
1499 (progn pprint-progn
)
1500 (progv pprint-progv
)
1501 (quote pprint-quote
)
1502 (return-from pprint-block
)
1504 (symbol-macrolet pprint-let
)
1505 (tagbody pprint-tagbody
)
1506 (throw pprint-block
)
1507 (unwind-protect pprint-block
)
1512 (ctypecase pprint-typecase
)
1513 (declaim pprint-declare
)
1514 (defconstant pprint-block
)
1515 (define-modify-macro pprint-defun
)
1516 (define-setf-expander pprint-defun
)
1517 (defmacro pprint-defun
)
1518 (defmethod pprint-defmethod)
1519 (defpackage pprint-defpackage
)
1520 (defparameter pprint-block
)
1521 (defsetf pprint-defun
)
1522 (defstruct pprint-block
)
1523 (deftype pprint-defun
)
1524 (defun pprint-defun)
1525 (defvar pprint-block
)
1526 (destructuring-bind pprint-destructuring-bind
)
1529 (do-all-symbols pprint-dolist
)
1530 (do-external-symbols pprint-dolist
)
1531 (do-symbols pprint-dolist
)
1532 (dolist pprint-dolist
)
1533 (dotimes pprint-dolist
)
1535 (etypecase pprint-typecase
)
1536 #+nil
(handler-bind ...
)
1537 #+nil
(handler-case ...
)
1539 (multiple-value-bind pprint-prog2
)
1540 (multiple-value-setq pprint-block
)
1541 (pprint-logical-block pprint-block
)
1542 (print-unreadable-object pprint-block
)
1545 (prog1 pprint-block
)
1546 (prog2 pprint-prog2
)
1549 (quasiquote pprint-quote
)
1550 #+nil
(restart-bind ...
)
1551 #+nil
(restart-case ...
)
1555 (typecase pprint-typecase
)
1556 (unless pprint-block
)
1558 (with-compilation-unit pprint-block
)
1559 #+nil
(with-condition-restarts ...
)
1560 (with-hash-table-iterator pprint-block
)
1561 (with-input-from-string pprint-block
)
1562 (with-open-file pprint-block
)
1563 (with-open-stream pprint-block
)
1564 (with-output-to-string pprint-block
)
1565 (with-package-iterator pprint-block
)
1566 (with-simple-restart pprint-block
)
1567 (with-standard-io-syntax pprint-progn
)
1570 (sb!int
:dx-flet pprint-flet
)
1573 (set-pprint-dispatch `(cons (eql ,(first magic-form
)))
1574 (symbol-function (second magic-form
))))
1575 (setf *initial-pprint-dispatch-table
* *print-pprint-dispatch
*))
1577 (setf *standard-pprint-dispatch-table
*
1578 (copy-pprint-dispatch *initial-pprint-dispatch-table
*))
1579 (setf *print-pprint-dispatch
*
1580 (copy-pprint-dispatch *initial-pprint-dispatch-table
*))
1581 (setf *print-pretty
* t
))