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
20 ;;; the output buffer.
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 sb!kernel:lisp-stream
34 (:misc #'pretty-misc))
35 (:constructor make-pretty-stream (target)))
36 ;; Where the output is going to finally go.
37 (target (required-argument) :type stream)
38 ;; Line length we should format to. Cached here so we don't have to keep
39 ;; extracting it from the target stream.
40 (line-length (or *print-right-margin*
41 (sb!impl::line-length target)
44 ;; A simple string holding all the text that has been output but not yet
46 (buffer (make-string initial-buffer-size) :type simple-string)
47 ;; The index into BUFFER where more text should be put.
48 (buffer-fill-pointer 0 :type index)
49 ;; Whenever we output stuff from the buffer, we shift the remaining noise
50 ;; over. This makes it difficult to keep references to locations in
51 ;; the buffer. Therefore, we have to keep track of the total amount of
52 ;; stuff that has been shifted out of the buffer.
53 (buffer-offset 0 :type posn)
54 ;; The column the first character in the buffer will appear in. Normally
55 ;; zero, but if we end up with a very long line with no breaks in it we
56 ;; might have to output part of it. Then this will no longer be zero.
57 (buffer-start-column (or (sb!impl::charpos target) 0) :type column)
58 ;; The line number we are currently on. Used for *print-lines* abrevs and
59 ;; to tell when sections have been split across multiple lines.
60 (line-number 0 :type index)
61 ;; Stack of logical blocks in effect at the buffer start.
62 (blocks (list (make-logical-block)) :type list)
63 ;; Buffer holding the per-line prefix active at the buffer start.
64 ;; Indentation is included in this. The length of this is stored
65 ;; in the logical block stack.
66 (prefix (make-string initial-buffer-size) :type simple-string)
67 ;; Buffer holding the total remaining suffix active at the buffer start.
68 ;; The characters are right-justified in the buffer to make it easier
69 ;; to output the buffer. The length is stored in the logical block
71 (suffix (make-string initial-buffer-size) :type simple-string)
72 ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
73 ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
74 ;; cons. Adding things to the queue is basically (setf (cdr head) (list
75 ;; new)) and removing them is basically (pop tail) [except that care must
76 ;; be taken to handle the empty queue case correctly.]
77 (queue-tail nil :type list)
78 (queue-head nil :type list)
79 ;; Block-start queue entries in effect at the queue head.
80 (pending-blocks nil :type list))
81 (def!method print-object ((pstream pretty-stream) stream)
82 ;; FIXME: CMU CL had #+NIL'ed out this code and done a hand-written
83 ;; FORMAT hack instead. Make sure that this code actually works instead
84 ;; of falling into infinite regress or something.
85 (print-unreadable-object (pstream stream :type t :identity t)))
87 #!-sb-fluid (declaim (inline index-posn posn-index posn-column))
88 (defun index-posn (index stream)
89 (declare (type index index) (type pretty-stream stream)
91 (+ index (pretty-stream-buffer-offset stream)))
92 (defun posn-index (posn stream)
93 (declare (type posn posn) (type pretty-stream stream)
95 (- posn (pretty-stream-buffer-offset stream)))
96 (defun posn-column (posn stream)
97 (declare (type posn posn) (type pretty-stream stream)
99 (index-column (posn-index posn stream) stream))
101 ;;;; stream interface routines
103 (defun pretty-out (stream char)
104 (declare (type pretty-stream stream)
105 (type base-char char))
106 (cond ((char= char #\newline)
107 (enqueue-newline stream :literal))
109 (ensure-space-in-buffer stream 1)
110 (let ((fill-pointer (pretty-stream-buffer-fill-pointer stream)))
111 (setf (schar (pretty-stream-buffer stream) fill-pointer) char)
112 (setf (pretty-stream-buffer-fill-pointer stream)
113 (1+ fill-pointer))))))
115 (defun pretty-sout (stream string start end)
116 (declare (type pretty-stream stream)
117 (type simple-string string)
119 (type (or index null) end))
120 (let ((end (or end (length string))))
121 (unless (= start end)
122 (let ((newline (position #\newline string :start start :end end)))
125 (pretty-sout stream string start newline)
126 (enqueue-newline stream :literal)
127 (pretty-sout stream string (1+ newline) end))
129 (let ((chars (- end start)))
131 (let* ((available (ensure-space-in-buffer stream chars))
132 (count (min available chars))
133 (fill-pointer (pretty-stream-buffer-fill-pointer stream))
134 (new-fill-ptr (+ fill-pointer count)))
135 (replace (pretty-stream-buffer stream)
137 :start1 fill-pointer :end1 new-fill-ptr
139 (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
143 (incf start count))))))))))
145 (defun pretty-misc (stream op &optional arg1 arg2)
146 (declare (ignore stream op arg1 arg2)))
150 (defstruct logical-block
151 ;; The column this logical block started in.
152 (start-column 0 :type column)
153 ;; The column the current section started in.
154 (section-column 0 :type column)
155 ;; The length of the per-line prefix. We can't move the indentation
157 (per-line-prefix-end 0 :type index)
158 ;; The overall length of the prefix, including any indentation.
159 (prefix-length 0 :type index)
160 ;; The overall length of the suffix.
161 (suffix-length 0 :type index)
163 (section-start-line 0 :type index))
165 (defun really-start-logical-block (stream column prefix suffix)
166 (let* ((blocks (pretty-stream-blocks stream))
167 (prev-block (car blocks))
168 (per-line-end (logical-block-per-line-prefix-end prev-block))
169 (prefix-length (logical-block-prefix-length prev-block))
170 (suffix-length (logical-block-suffix-length prev-block))
171 (block (make-logical-block
173 :section-column column
174 :per-line-prefix-end per-line-end
175 :prefix-length prefix-length
176 :suffix-length suffix-length
177 :section-start-line (pretty-stream-line-number stream))))
178 (setf (pretty-stream-blocks stream) (cons block blocks))
179 (set-indentation stream column)
181 (setf (logical-block-per-line-prefix-end block) column)
182 (replace (pretty-stream-prefix stream) prefix
183 :start1 (- column (length prefix)) :end1 column))
185 (let* ((total-suffix (pretty-stream-suffix stream))
186 (total-suffix-len (length total-suffix))
187 (additional (length suffix))
188 (new-suffix-len (+ suffix-length additional)))
189 (when (> new-suffix-len total-suffix-len)
190 (let ((new-total-suffix-len
191 (max (* total-suffix-len 2)
193 (floor (* additional 5) 4)))))
195 (replace (make-string new-total-suffix-len) total-suffix
196 :start1 (- new-total-suffix-len suffix-length)
197 :start2 (- total-suffix-len suffix-length)))
198 (setf total-suffix-len new-total-suffix-len)
199 (setf (pretty-stream-suffix stream) total-suffix)))
200 (replace total-suffix suffix
201 :start1 (- total-suffix-len new-suffix-len)
202 :end1 (- total-suffix-len suffix-length))
203 (setf (logical-block-suffix-length block) new-suffix-len))))
206 (defun set-indentation (stream column)
207 (let* ((prefix (pretty-stream-prefix stream))
208 (prefix-len (length prefix))
209 (block (car (pretty-stream-blocks stream)))
210 (current (logical-block-prefix-length block))
211 (minimum (logical-block-per-line-prefix-end block))
212 (column (max minimum column)))
213 (when (> column prefix-len)
215 (replace (make-string (max (* prefix-len 2)
217 (floor (* (- column prefix-len) 5)
221 (setf (pretty-stream-prefix stream) prefix))
222 (when (> column current)
223 (fill prefix #\space :start current :end column))
224 (setf (logical-block-prefix-length block) column)))
226 (defun really-end-logical-block (stream)
227 (let* ((old (pop (pretty-stream-blocks stream)))
228 (old-indent (logical-block-prefix-length old))
229 (new (car (pretty-stream-blocks stream)))
230 (new-indent (logical-block-prefix-length new)))
231 (when (> new-indent old-indent)
232 (fill (pretty-stream-prefix stream) #\space
233 :start old-indent :end new-indent)))
236 ;;;; the pending operation queue
238 (defstruct (queued-op (:constructor nil))
241 (defmacro enqueue (stream type &rest args)
242 (let ((constructor (intern (concatenate 'string
244 (symbol-name type)))))
245 (once-only ((stream stream)
246 (entry `(,constructor :posn
248 (pretty-stream-buffer-fill-pointer
253 (head `(pretty-stream-queue-head ,stream)))
256 (setf (cdr ,head) ,op)
257 (setf (pretty-stream-queue-tail ,stream) ,op))
258 (setf (pretty-stream-queue-head ,stream) ,op)
261 (defstruct (section-start (:include queued-op)
263 (depth 0 :type index)
264 (section-end nil :type (or null newline block-end)))
267 (:include section-start))
268 (kind (required-argument)
269 :type (member :linear :fill :miser :literal :mandatory)))
271 (defun enqueue-newline (stream kind)
272 (let* ((depth (length (pretty-stream-pending-blocks stream)))
273 (newline (enqueue stream newline :kind kind :depth depth)))
274 (dolist (entry (pretty-stream-queue-tail stream))
275 (when (and (not (eq newline entry))
276 (section-start-p entry)
277 (null (section-start-section-end entry))
278 (<= depth (section-start-depth entry)))
279 (setf (section-start-section-end entry) newline))))
280 (maybe-output stream (or (eq kind :literal) (eq kind :mandatory))))
282 (defstruct (indentation
283 (:include queued-op))
284 (kind (required-argument) :type (member :block :current))
285 (amount 0 :type fixnum))
287 (defun enqueue-indent (stream kind amount)
288 (enqueue stream indentation :kind kind :amount amount))
290 (defstruct (block-start
291 (:include section-start))
292 (block-end nil :type (or null block-end))
293 (prefix nil :type (or null simple-string))
294 (suffix nil :type (or null simple-string)))
296 (defun start-logical-block (stream prefix per-line-p suffix)
297 ;; (In the PPRINT-LOGICAL-BLOCK form which calls us,
298 ;; :PREFIX and :PER-LINE-PREFIX have hairy defaulting behavior,
299 ;; and might end up being NIL.)
300 (declare (type (or null string prefix)))
301 ;; (But the defaulting behavior of PPRINT-LOGICAL-BLOCK :SUFFIX is
302 ;; trivial, so it should always be a string.)
303 (declare (type string suffix))
305 (pretty-sout stream prefix 0 (length prefix)))
306 (let* ((pending-blocks (pretty-stream-pending-blocks stream))
307 (start (enqueue stream block-start
308 :prefix (and per-line-p prefix)
310 :depth (length pending-blocks))))
311 (setf (pretty-stream-pending-blocks stream)
312 (cons start pending-blocks))))
314 (defstruct (block-end
315 (:include queued-op))
316 (suffix nil :type (or null simple-string)))
318 (defun end-logical-block (stream)
319 (let* ((start (pop (pretty-stream-pending-blocks stream)))
320 (suffix (block-start-suffix start))
321 (end (enqueue stream block-end :suffix suffix)))
323 (pretty-sout stream suffix 0 (length suffix)))
324 (setf (block-start-block-end start) end)))
327 (:include queued-op))
328 (sectionp nil :type (member t nil))
329 (relativep nil :type (member t nil))
330 (colnum 0 :type column)
331 (colinc 0 :type column))
333 (defun enqueue-tab (stream kind colnum colinc)
334 (multiple-value-bind (sectionp relativep)
336 (:line (values nil nil))
337 (:line-relative (values nil t))
338 (:section (values t nil))
339 (:section-relative (values t t)))
340 (enqueue stream tab :sectionp sectionp :relativep relativep
341 :colnum colnum :colinc colinc)))
345 (defun compute-tab-size (tab section-start column)
346 (let ((origin (if (tab-sectionp tab) section-start 0))
347 (colnum (tab-colnum tab))
348 (colinc (tab-colinc tab)))
349 (cond ((tab-relativep tab)
350 (unless (<= colinc 1)
351 (let ((newposn (+ column colnum)))
352 (let ((rem (rem newposn colinc)))
354 (incf colnum (- colinc rem))))))
356 ((<= column (+ colnum origin))
357 (- (+ colnum origin) column))
360 (rem (- column origin) colinc))))))
362 (defun index-column (index stream)
363 (let ((column (pretty-stream-buffer-start-column stream))
364 (section-start (logical-block-section-column
365 (first (pretty-stream-blocks stream))))
366 (end-posn (index-posn index stream)))
367 (dolist (op (pretty-stream-queue-tail stream))
368 (when (>= (queued-op-posn op) end-posn)
376 (posn-index (tab-posn op)
378 ((or newline block-start)
380 (+ column (posn-index (queued-op-posn op)
384 (defun expand-tabs (stream through)
385 (let ((insertions nil)
387 (column (pretty-stream-buffer-start-column stream))
388 (section-start (logical-block-section-column
389 (first (pretty-stream-blocks stream)))))
390 (dolist (op (pretty-stream-queue-tail stream))
393 (let* ((index (posn-index (tab-posn op) stream))
394 (tabsize (compute-tab-size op
397 (unless (zerop tabsize)
398 (push (cons index tabsize) insertions)
399 (incf additional tabsize)
400 (incf column tabsize))))
401 ((or newline block-start)
403 (+ column (posn-index (queued-op-posn op) stream)))))
404 (when (eq op through)
407 (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
408 (new-fill-ptr (+ fill-ptr additional))
409 (buffer (pretty-stream-buffer stream))
411 (length (length buffer))
413 (when (> new-fill-ptr length)
414 (let ((new-length (max (* length 2)
416 (floor (* additional 5) 4)))))
417 (setf new-buffer (make-string new-length))
418 (setf (pretty-stream-buffer stream) new-buffer)))
419 (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
420 (decf (pretty-stream-buffer-offset stream) additional)
421 (dolist (insertion insertions)
422 (let* ((srcpos (car insertion))
423 (amount (cdr insertion))
424 (dstpos (+ srcpos additional)))
425 (replace new-buffer buffer :start1 dstpos :start2 srcpos :end2 end)
426 (fill new-buffer #\space :start (- dstpos amount) :end dstpos)
427 (decf additional amount)
429 (unless (eq new-buffer buffer)
430 (replace new-buffer buffer :end1 end :end2 end))))))
432 ;;;; stuff to do the actual outputting
434 (defun ensure-space-in-buffer (stream want)
435 (declare (type pretty-stream stream)
437 (let* ((buffer (pretty-stream-buffer stream))
438 (length (length buffer))
439 (fill-ptr (pretty-stream-buffer-fill-pointer stream))
440 (available (- length fill-ptr)))
441 (cond ((plusp available)
443 ((> fill-ptr (pretty-stream-line-length stream))
444 (unless (maybe-output stream nil)
445 (output-partial-line stream))
446 (ensure-space-in-buffer stream want))
448 (let* ((new-length (max (* length 2)
450 (floor (* want 5) 4))))
451 (new-buffer (make-string new-length)))
452 (setf (pretty-stream-buffer stream) new-buffer)
453 (replace new-buffer buffer :end1 fill-ptr)
454 (- new-length fill-ptr))))))
456 (defun maybe-output (stream force-newlines-p)
457 (declare (type pretty-stream stream))
458 (let ((tail (pretty-stream-queue-tail stream))
459 (output-anything nil))
462 (setf (pretty-stream-queue-head stream) nil)
464 (let ((next (pop tail)))
467 (when (ecase (newline-kind next)
468 ((:literal :mandatory :linear) t)
469 (:miser (misering-p stream))
471 (or (misering-p stream)
472 (> (pretty-stream-line-number stream)
473 (logical-block-section-start-line
474 (first (pretty-stream-blocks stream))))
475 (ecase (fits-on-line-p stream
476 (newline-section-end next)
482 (setf output-anything t)
483 (output-line stream next)))
485 (unless (misering-p stream)
486 (set-indentation stream
487 (+ (ecase (indentation-kind next)
489 (logical-block-start-column
490 (car (pretty-stream-blocks stream))))
493 (indentation-posn next)
495 (indentation-amount next)))))
497 (ecase (fits-on-line-p stream (block-start-section-end next)
500 ;; Just nuke the whole logical block and make it look
501 ;; like one nice long literal.
502 (let ((end (block-start-block-end next)))
503 (expand-tabs stream end)
504 (setf tail (cdr (member end tail)))))
506 (really-start-logical-block
508 (posn-column (block-start-posn next) stream)
509 (block-start-prefix next)
510 (block-start-suffix next)))
514 (really-end-logical-block stream))
516 (expand-tabs stream next))))
517 (setf (pretty-stream-queue-tail stream) tail))
520 (defun misering-p (stream)
521 (declare (type pretty-stream stream))
522 (and *print-miser-width*
523 (<= (- (pretty-stream-line-length stream)
524 (logical-block-start-column (car (pretty-stream-blocks stream))))
525 *print-miser-width*)))
527 (defun fits-on-line-p (stream until force-newlines-p)
528 (let ((available (pretty-stream-line-length stream)))
529 (when (and (not *print-readably*) *print-lines*
530 (= *print-lines* (pretty-stream-line-number stream)))
531 (decf available 3) ; for the `` ..''
532 (decf available (logical-block-suffix-length
533 (car (pretty-stream-blocks stream)))))
535 (<= (posn-column (queued-op-posn until) stream) available))
536 (force-newlines-p nil)
537 ((> (index-column (pretty-stream-buffer-fill-pointer stream) stream)
543 (defun output-line (stream until)
544 (declare (type pretty-stream stream)
545 (type newline until))
546 (let* ((target (pretty-stream-target stream))
547 (buffer (pretty-stream-buffer stream))
548 (kind (newline-kind until))
549 (literal-p (eq kind :literal))
550 (amount-to-consume (posn-index (newline-posn until) stream))
554 (let ((last-non-blank
555 (position #\space buffer :end amount-to-consume
556 :from-end t :test #'char/=)))
560 (write-string buffer target :end amount-to-print)
561 (let ((line-number (pretty-stream-line-number stream)))
563 (when (and (not *print-readably*)
564 *print-lines* (>= line-number *print-lines*))
565 (write-string " .." target)
566 (let ((suffix-length (logical-block-suffix-length
567 (car (pretty-stream-blocks stream)))))
568 (unless (zerop suffix-length)
569 (let* ((suffix (pretty-stream-suffix stream))
570 (len (length suffix)))
571 (write-string suffix target
572 :start (- len suffix-length)
574 (throw 'line-limit-abbreviation-happened t))
575 (setf (pretty-stream-line-number stream) line-number)
576 (write-char #\newline target)
577 (setf (pretty-stream-buffer-start-column stream) 0)
578 (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
579 (block (first (pretty-stream-blocks stream)))
582 (logical-block-per-line-prefix-end block)
583 (logical-block-prefix-length block)))
584 (shift (- amount-to-consume prefix-len))
585 (new-fill-ptr (- fill-ptr shift))
587 (buffer-length (length buffer)))
588 (when (> new-fill-ptr buffer-length)
590 (make-string (max (* buffer-length 2)
592 (floor (* (- new-fill-ptr buffer-length)
595 (setf (pretty-stream-buffer stream) new-buffer))
596 (replace new-buffer buffer
597 :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
598 (replace new-buffer (pretty-stream-prefix stream)
600 (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
601 (incf (pretty-stream-buffer-offset stream) shift)
603 (setf (logical-block-section-column block) prefix-len)
604 (setf (logical-block-section-start-line block) line-number))))))
606 (defun output-partial-line (stream)
607 (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
608 (tail (pretty-stream-queue-tail stream))
611 (posn-index (queued-op-posn (car tail)) stream)
613 (new-fill-ptr (- fill-ptr count))
614 (buffer (pretty-stream-buffer stream)))
616 (error "Output-partial-line called when nothing can be output."))
617 (write-string buffer (pretty-stream-target stream)
619 (incf (pretty-stream-buffer-start-column stream) count)
620 (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr)
621 (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
622 (incf (pretty-stream-buffer-offset stream) count)))
624 (defun force-pretty-output (stream)
625 (maybe-output stream nil)
626 (expand-tabs stream nil)
627 (write-string (pretty-stream-buffer stream)
628 (pretty-stream-target stream)
629 :end (pretty-stream-buffer-fill-pointer stream)))
631 ;;;; user interface to the pretty printer
633 (defun pprint-newline (kind &optional stream)
635 "Output a conditional newline to STREAM (which defaults to
636 *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do
637 nothing if not. KIND can be one of:
638 :LINEAR - A line break is inserted if and only if the immediatly
639 containing section cannot be printed on one line.
640 :MISER - Same as LINEAR, but only if ``miser-style'' is in effect.
641 (See *PRINT-MISER-WIDTH*.)
642 :FILL - A line break is inserted if and only if either:
643 (a) the following section cannot be printed on the end of the
645 (b) the preceding section was not printed on a single line, or
646 (c) the immediately containing section cannot be printed on one
647 line and miser-style is in effect.
648 :MANDATORY - A line break is always inserted.
649 When a line break is inserted by any type of conditional newline, any
650 blanks that immediately precede the conditional newline are ommitted
651 from the output and indentation is introduced at the beginning of the
652 next line. (See PPRINT-INDENT.)"
653 (declare (type (member :linear :miser :fill :mandatory) kind)
654 (type (or stream (member t nil)) stream)
656 (let ((stream (case stream
658 ((nil) *standard-output*)
660 (when (pretty-stream-p stream)
661 (enqueue-newline stream kind)))
664 (defun pprint-indent (relative-to n &optional stream)
666 "Specify the indentation to use in the current logical block if STREAM
667 (which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream
668 and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the indention
669 to use (in ems, the width of an ``m'') and RELATIVE-TO can be either:
670 :BLOCK - Indent relative to the column the current logical block
672 :CURRENT - Indent relative to the current column.
673 The new indention value does not take effect until the following line
675 (declare (type (member :block :current) relative-to)
677 (type (or stream (member t nil)) stream)
679 (let ((stream (case stream
681 ((nil) *standard-output*)
683 (when (pretty-stream-p stream)
684 (enqueue-indent stream relative-to n)))
687 (defun pprint-tab (kind colnum colinc &optional stream)
689 "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing
690 stream, perform tabbing based on KIND, otherwise do nothing. KIND can
692 :LINE - Tab to column COLNUM. If already past COLNUM tab to the next
694 :SECTION - Same as :LINE, but count from the start of the current
695 section, not the start of the line.
696 :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of
698 :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start
699 of the current section, not the start of the line."
700 (declare (type (member :line :section :line-relative :section-relative) kind)
701 (type unsigned-byte colnum colinc)
702 (type (or stream (member t nil)) stream)
704 (let ((stream (case stream
706 ((nil) *standard-output*)
708 (when (pretty-stream-p stream)
709 (enqueue-tab stream kind colnum colinc)))
712 (defun pprint-fill (stream list &optional (colon? t) atsign?)
714 "Output LIST to STREAM putting :FILL conditional newlines between each
715 element. If COLON? is NIL (defaults to T), then no parens are printed
716 around the output. ATSIGN? is ignored (but allowed so that PPRINT-FILL
717 can be used with the ~/.../ format directive."
718 (declare (ignore atsign?))
719 (pprint-logical-block (stream list
720 :prefix (if colon? "(" "")
721 :suffix (if colon? ")" ""))
722 (pprint-exit-if-list-exhausted)
724 (output-object (pprint-pop) stream)
725 (pprint-exit-if-list-exhausted)
726 (write-char #\space stream)
727 (pprint-newline :fill stream))))
729 (defun pprint-linear (stream list &optional (colon? t) atsign?)
731 "Output LIST to STREAM putting :LINEAR conditional newlines between each
732 element. If COLON? is NIL (defaults to T), then no parens are printed
733 around the output. ATSIGN? is ignored (but allowed so that PPRINT-LINEAR
734 can be used with the ~/.../ format directive."
735 (declare (ignore atsign?))
736 (pprint-logical-block (stream list
737 :prefix (if colon? "(" "")
738 :suffix (if colon? ")" ""))
739 (pprint-exit-if-list-exhausted)
741 (output-object (pprint-pop) stream)
742 (pprint-exit-if-list-exhausted)
743 (write-char #\space stream)
744 (pprint-newline :linear stream))))
746 (defun pprint-tabular (stream list &optional (colon? t) atsign? tabsize)
748 "Output LIST to STREAM tabbing to the next column that is an even multiple
749 of TABSIZE (which defaults to 16) between each element. :FILL style
750 conditional newlines are also output between each element. If COLON? is
751 NIL (defaults to T), then no parens are printed around the output.
752 ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with
753 the ~/.../ format directive."
754 (declare (ignore atsign?))
755 (pprint-logical-block (stream list
756 :prefix (if colon? "(" "")
757 :suffix (if colon? ")" ""))
758 (pprint-exit-if-list-exhausted)
760 (output-object (pprint-pop) stream)
761 (pprint-exit-if-list-exhausted)
762 (write-char #\space stream)
763 (pprint-tab :section-relative 0 (or tabsize 16) stream)
764 (pprint-newline :fill stream))))
766 ;;;; pprint-dispatch tables
768 (defvar *initial-pprint-dispatch*)
769 (defvar *building-initial-table* nil)
771 (defstruct pprint-dispatch-entry
772 ;; The type specifier for this entry.
773 (type (required-argument) :type t)
774 ;; A function to test to see whether an object is of this time. Pretty must
775 ;; just (lambda (obj) (typep object type)) except that we handle the
776 ;; CONS type specially so that (cons (member foo)) works. We don't
777 ;; bother computing this for entries in the CONS hash table, because
779 (test-fn nil :type (or function null))
780 ;; The priority for this guy.
781 (priority 0 :type real)
782 ;; T iff one of the original entries.
783 (initial-p *building-initial-table* :type (member t nil))
784 ;; And the associated function.
785 (function (required-argument) :type function))
786 (def!method print-object ((entry pprint-dispatch-entry) stream)
787 (print-unreadable-object (entry stream :type t)
788 (format stream "type=~S, priority=~S~@[ [initial]~]"
789 (pprint-dispatch-entry-type entry)
790 (pprint-dispatch-entry-priority entry)
791 (pprint-dispatch-entry-initial-p entry))))
793 (defstruct pprint-dispatch-table
794 ;; A list of all the entries (except for CONS entries below) in highest
795 ;; to lowest priority.
796 (entries nil :type list)
797 ;; A hash table mapping things to entries for type specifiers of the
798 ;; form (CONS (MEMBER <thing>)). If the type specifier is of this form,
799 ;; we put it in this hash table instead of the regular entries table.
800 (cons-entries (make-hash-table :test 'eql)))
801 (def!method print-object ((table pprint-dispatch-table) stream)
802 (print-unreadable-object (table stream :type t :identity t)))
804 (defun cons-type-specifier-p (spec)
806 (eq (car spec) 'cons)
809 (let ((car (cadr spec)))
811 (let ((carcar (car car)))
812 (or (eq carcar 'member)
815 (null (cddr car))))))
817 (defun entry< (e1 e2)
818 (declare (type pprint-dispatch-entry e1 e2))
819 (if (pprint-dispatch-entry-initial-p e1)
820 (if (pprint-dispatch-entry-initial-p e2)
821 (< (pprint-dispatch-entry-priority e1)
822 (pprint-dispatch-entry-priority e2))
824 (if (pprint-dispatch-entry-initial-p e2)
826 (< (pprint-dispatch-entry-priority e1)
827 (pprint-dispatch-entry-priority e2)))))
830 `(cons ',x #'(lambda (object) ,x))))
831 (defvar *precompiled-pprint-dispatch-funs*
832 (list (frob (typep object 'array))
833 (frob (and (consp object)
834 (and (typep (car object) 'symbol)
835 (typep (car object) '(satisfies fboundp)))))
836 (frob (typep object 'cons)))))
838 (defun compute-test-fn (type)
839 (let ((was-cons nil))
840 (labels ((compute-test-expr (type object)
846 (&optional (car nil car-p) (cdr nil cdr-p))
848 `(and (consp ,object)
850 `(,(compute-test-expr
851 car `(car ,object))))
853 `(,(compute-test-expr
854 cdr `(cdr ,object)))))))
856 (destructuring-bind (type) (cdr type)
857 `(not ,(compute-test-expr type object))))
859 `(and ,@(mapcar #'(lambda (type)
860 (compute-test-expr type object))
863 `(or ,@(mapcar #'(lambda (type)
864 (compute-test-expr type object))
867 `(typep ,object ',type)))
868 `(typep ,object ',type))))
869 (let ((expr (compute-test-expr type 'object)))
870 (cond ((cdr (assoc expr *precompiled-pprint-dispatch-funs*
873 (compile nil `(lambda (object) ,expr)))
875 (warn "CONS PPRINT dispatch ignored w/o compiler loaded:~% ~S"
877 #'(lambda (object) (declare (ignore object)) nil))
879 (let ((ttype (sb!kernel:specifier-type type)))
880 #'(lambda (object) (sb!kernel:%typep object ttype)))))))))
882 (defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
883 (declare (type (or pprint-dispatch-table null) table))
884 (let* ((orig (or table *initial-pprint-dispatch*))
885 (new (make-pprint-dispatch-table
886 :entries (copy-list (pprint-dispatch-table-entries orig))))
887 (new-cons-entries (pprint-dispatch-table-cons-entries new)))
888 (maphash #'(lambda (key value)
889 (setf (gethash key new-cons-entries) value))
890 (pprint-dispatch-table-cons-entries orig))
893 (defun pprint-dispatch (object &optional (table *print-pprint-dispatch*))
894 (declare (type (or pprint-dispatch-table null) table))
895 (let* ((table (or table *initial-pprint-dispatch*))
898 (gethash (car object)
899 (pprint-dispatch-table-cons-entries table))))
901 (dolist (entry (pprint-dispatch-table-entries table) cons-entry)
902 (when (and cons-entry
903 (entry< entry cons-entry))
905 (when (funcall (pprint-dispatch-entry-test-fn entry) object)
908 (values (pprint-dispatch-entry-function entry) t)
909 (values #'(lambda (stream object)
910 (output-ugly-object object stream))
913 (defun set-pprint-dispatch (type function &optional
914 (priority 0) (table *print-pprint-dispatch*))
915 (declare (type (or null function) function)
917 (type pprint-dispatch-table table))
919 (if (cons-type-specifier-p type)
920 (setf (gethash (second (second type))
921 (pprint-dispatch-table-cons-entries table))
922 (make-pprint-dispatch-entry :type type :priority priority
924 (let ((list (delete type (pprint-dispatch-table-entries table)
925 :key #'pprint-dispatch-entry-type
927 (entry (make-pprint-dispatch-entry
928 :type type :test-fn (compute-test-fn type)
929 :priority priority :function function)))
931 (next list (cdr next)))
934 (setf (cdr prev) (list entry))
935 (setf list (list entry))))
936 (when (entry< (car next) entry)
938 (setf (cdr prev) (cons entry next))
939 (setf list (cons entry next)))
941 (setf (pprint-dispatch-table-entries table) list)))
942 (if (cons-type-specifier-p type)
943 (remhash (second (second type))
944 (pprint-dispatch-table-cons-entries table))
945 (setf (pprint-dispatch-table-entries table)
946 (delete type (pprint-dispatch-table-entries table)
947 :key #'pprint-dispatch-entry-type
951 ;;;; standard pretty-printing routines
953 (defun pprint-array (stream array)
954 (cond ((or (and (null *print-array*) (null *print-readably*))
956 (bit-vector-p array))
957 (output-ugly-object array stream))
958 ((and *print-readably* (not (eq (array-element-type array) 't)))
959 (let ((*print-readably* nil))
960 (error 'print-not-readable :object array)))
962 (pprint-vector stream array))
964 (pprint-multi-dim-array stream array))))
966 (defun pprint-vector (stream vector)
967 (pprint-logical-block (stream nil :prefix "#(" :suffix ")")
968 (dotimes (i (length vector))
970 (format stream " ~:_"))
972 (output-object (aref vector i) stream))))
974 (defun pprint-multi-dim-array (stream array)
975 (funcall (formatter "#~DA") stream (array-rank array))
976 (with-array-data ((data array) (start) (end))
977 (declare (ignore end))
978 (labels ((output-guts (stream index dimensions)
979 (if (null dimensions)
980 (output-object (aref data index) stream)
981 (pprint-logical-block
982 (stream nil :prefix "(" :suffix ")")
983 (let ((dim (car dimensions)))
985 (let* ((dims (cdr dimensions))
987 (step (reduce #'* dims))
991 (output-guts stream index dims)
992 (when (= (incf count) dim)
994 (write-char #\space stream)
995 (pprint-newline (if dims :linear :fill)
997 (incf index step)))))))))
998 (output-guts stream start (array-dimensions array)))))
1000 (defun pprint-lambda-list (stream lambda-list &rest noise)
1001 (declare (ignore noise))
1002 (pprint-logical-block (stream lambda-list :prefix "(" :suffix ")")
1003 (let ((state :required)
1006 (pprint-exit-if-list-exhausted)
1008 (write-char #\space stream))
1009 (let ((arg (pprint-pop)))
1013 (setf state :optional)
1014 (pprint-newline :linear stream))
1016 (setf state :required)
1017 (pprint-newline :linear stream))
1020 (pprint-newline :linear stream))
1022 (setf state :optional)
1023 (pprint-newline :linear stream))
1025 (pprint-newline :fill stream))))
1028 (pprint-lambda-list stream arg))
1030 (pprint-logical-block
1031 (stream arg :prefix "(" :suffix ")")
1032 (pprint-exit-if-list-exhausted)
1034 (pprint-logical-block
1035 (stream (pprint-pop) :prefix "(" :suffix ")")
1036 (pprint-exit-if-list-exhausted)
1037 (output-object (pprint-pop) stream)
1038 (pprint-exit-if-list-exhausted)
1039 (write-char #\space stream)
1040 (pprint-newline :fill stream)
1041 (pprint-lambda-list stream (pprint-pop))
1043 (pprint-exit-if-list-exhausted)
1044 (write-char #\space stream)
1045 (pprint-newline :fill stream)
1046 (output-object (pprint-pop) stream)))
1047 (pprint-lambda-list stream (pprint-pop)))
1049 (pprint-exit-if-list-exhausted)
1050 (write-char #\space stream)
1051 (pprint-newline :linear stream)
1052 (output-object (pprint-pop) stream))))))
1053 (setf first nil)))))
1055 (defun pprint-lambda (stream list &rest noise)
1056 (declare (ignore noise))
1058 ;; KLUDGE: This format string, and other format strings which also
1059 ;; refer to SB!PRETTY, rely on the current SBCL not-quite-ANSI
1060 ;; behavior of FORMATTER in order to make code which survives the
1061 ;; transition when SB!PRETTY is renamed to SB-PRETTY after cold
1062 ;; init. (ANSI says that the FORMATTER functions should be
1063 ;; equivalent to the format string, but the SBCL FORMATTER
1064 ;; functions contain references to package objects, not package
1065 ;; names, so they keep right on going if the packages are renamed.)
1066 ;; If our FORMATTER behavior is ever made more compliant, the code
1067 ;; here will have to change. -- WHN 19991207
1068 "~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
1072 (defun pprint-block (stream list &rest noise)
1073 (declare (ignore noise))
1074 (funcall (formatter "~:<~^~W~^~3I ~:_~W~1I~@{ ~_~W~}~:>") stream list))
1076 (defun pprint-flet (stream list &rest noise)
1077 (declare (ignore noise))
1079 "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
1083 (defun pprint-let (stream list &rest noise)
1084 (declare (ignore noise))
1085 (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>")
1089 (defun pprint-progn (stream list &rest noise)
1090 (declare (ignore noise))
1091 (funcall (formatter "~:<~^~W~@{ ~_~W~}~:>") stream list))
1093 (defun pprint-progv (stream list &rest noise)
1094 (declare (ignore noise))
1095 (funcall (formatter "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>")
1098 (defun pprint-quote (stream list &rest noise)
1099 (declare (ignore noise))
1100 (if (and (consp list)
1105 (write-string "#'" stream)
1106 (output-object (cadr list) stream))
1108 (write-char #\' stream)
1109 (output-object (cadr list) stream))
1111 (pprint-fill stream list)))
1112 (pprint-fill stream list)))
1114 (defun pprint-setq (stream list &rest noise)
1115 (declare (ignore noise))
1116 (pprint-logical-block (stream list :prefix "(" :suffix ")")
1117 (pprint-exit-if-list-exhausted)
1118 (output-object (pprint-pop) stream)
1119 (pprint-exit-if-list-exhausted)
1120 (write-char #\space stream)
1121 (pprint-newline :miser stream)
1122 (if (and (consp (cdr list)) (consp (cddr list)))
1124 (pprint-indent :current 2 stream)
1125 (output-object (pprint-pop) stream)
1126 (pprint-exit-if-list-exhausted)
1127 (write-char #\space stream)
1128 (pprint-newline :linear stream)
1129 (pprint-indent :current -2 stream)
1130 (output-object (pprint-pop) stream)
1131 (pprint-exit-if-list-exhausted)
1132 (write-char #\space stream)
1133 (pprint-newline :linear stream))
1135 (pprint-indent :current 0 stream)
1136 (output-object (pprint-pop) stream)
1137 (pprint-exit-if-list-exhausted)
1138 (write-char #\space stream)
1139 (pprint-newline :linear stream)
1140 (output-object (pprint-pop) stream)))))
1142 ;;; FIXME: could become SB!XC:DEFMACRO wrapped in EVAL-WHEN (COMPILE EVAL)
1143 (defmacro pprint-tagbody-guts (stream)
1145 (pprint-exit-if-list-exhausted)
1146 (write-char #\space ,stream)
1147 (let ((form-or-tag (pprint-pop)))
1148 (pprint-indent :block
1149 (if (atom form-or-tag) 0 1)
1151 (pprint-newline :linear ,stream)
1152 (output-object form-or-tag ,stream))))
1154 (defun pprint-tagbody (stream list &rest noise)
1155 (declare (ignore noise))
1156 (pprint-logical-block (stream list :prefix "(" :suffix ")")
1157 (pprint-exit-if-list-exhausted)
1158 (output-object (pprint-pop) stream)
1159 (pprint-tagbody-guts stream)))
1161 (defun pprint-case (stream list &rest noise)
1162 (declare (ignore noise))
1164 "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/SB!PRETTY:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>")
1168 (defun pprint-defun (stream list &rest noise)
1169 (declare (ignore noise))
1171 "~:<~^~W~^ ~@_~:I~W~^ ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
1175 (defun pprint-destructuring-bind (stream list &rest noise)
1176 (declare (ignore noise))
1178 "~:<~^~W~^~3I ~_~:/SB!PRETTY:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>")
1181 (defun pprint-do (stream list &rest noise)
1182 (declare (ignore noise))
1183 (pprint-logical-block (stream list :prefix "(" :suffix ")")
1184 (pprint-exit-if-list-exhausted)
1185 (output-object (pprint-pop) stream)
1186 (pprint-exit-if-list-exhausted)
1187 (write-char #\space stream)
1188 (pprint-indent :current 0 stream)
1189 (funcall (formatter "~:<~@{~:<~^~W~^ ~@_~:I~W~@{ ~_~W~}~:>~^~:@_~}~:>")
1192 (pprint-exit-if-list-exhausted)
1193 (write-char #\space stream)
1194 (pprint-newline :linear stream)
1195 (pprint-linear stream (pprint-pop))
1196 (pprint-tagbody-guts stream)))
1198 (defun pprint-dolist (stream list &rest noise)
1199 (declare (ignore noise))
1200 (pprint-logical-block (stream list :prefix "(" :suffix ")")
1201 (pprint-exit-if-list-exhausted)
1202 (output-object (pprint-pop) stream)
1203 (pprint-exit-if-list-exhausted)
1204 (pprint-indent :block 3 stream)
1205 (write-char #\space stream)
1206 (pprint-newline :fill stream)
1207 (funcall (formatter "~:<~^~W~^ ~:_~:I~W~@{ ~_~W~}~:>")
1210 (pprint-tagbody-guts stream)))
1212 (defun pprint-typecase (stream list &rest noise)
1213 (declare (ignore noise))
1215 "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>")
1219 (defun pprint-prog (stream list &rest noise)
1220 (declare (ignore noise))
1221 (pprint-logical-block (stream list :prefix "(" :suffix ")")
1222 (pprint-exit-if-list-exhausted)
1223 (output-object (pprint-pop) stream)
1224 (pprint-exit-if-list-exhausted)
1225 (write-char #\space stream)
1226 (pprint-newline :miser stream)
1227 (pprint-fill stream (pprint-pop))
1228 (pprint-tagbody-guts stream)))
1230 (defun pprint-function-call (stream list &rest noise)
1231 (declare (ignore noise))
1232 (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>")
1236 ;;;; the interface seen by regular (ugly) printer and initialization routines
1238 ;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when *PRINT-PRETTY* is
1240 (defun output-pretty-object (object stream)
1241 (with-pretty-stream (stream)
1242 (funcall (pprint-dispatch object) stream object)))
1244 (defun !pprint-cold-init ()
1245 (/show0 "entering !PPRINT-COLD-INIT")
1246 (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))
1247 (let ((*print-pprint-dispatch* *initial-pprint-dispatch*)
1248 (*building-initial-table* t))
1249 ;; printers for regular types
1250 (/show0 "doing SET-PPRINT-DISPATCH for regular types")
1251 (set-pprint-dispatch 'array #'pprint-array)
1252 (set-pprint-dispatch '(cons (and symbol (satisfies fboundp)))
1253 #'pprint-function-call -1)
1254 (set-pprint-dispatch 'cons #'pprint-fill -2)
1255 ;; cons cells with interesting things for the car
1256 (/show0 "doing SET-PPRINT-DISPATCH for CONS with interesting CAR")
1258 (dolist (magic-form '((lambda pprint-lambda)
1261 (block pprint-block)
1262 (catch pprint-block)
1263 (eval-when pprint-block)
1265 (function pprint-quote)
1266 (labels pprint-flet)
1269 (locally pprint-progn)
1270 (macrolet pprint-flet)
1271 (multiple-value-call pprint-block)
1272 (multiple-value-prog1 pprint-block)
1273 (progn pprint-progn)
1274 (progv pprint-progv)
1275 (quote pprint-quote)
1276 (return-from pprint-block)
1278 (symbol-macrolet pprint-let)
1279 (tagbody pprint-tagbody)
1280 (throw pprint-block)
1281 (unwind-protect pprint-block)
1286 (ctypecase pprint-typecase)
1287 (defconstant pprint-block)
1288 (define-modify-macro pprint-defun)
1289 (define-setf-expander pprint-defun)
1290 (defmacro pprint-defun)
1291 (defparameter pprint-block)
1292 (defsetf pprint-defun)
1293 (defstruct pprint-block)
1294 (deftype pprint-defun)
1295 (defun pprint-defun)
1296 (defvar pprint-block)
1297 (destructuring-bind pprint-destructuring-bind)
1300 (do-all-symbols pprint-dolist)
1301 (do-external-symbols pprint-dolist)
1302 (do-symbols pprint-dolist)
1303 (dolist pprint-dolist)
1304 (dotimes pprint-dolist)
1306 (etypecase pprint-typecase)
1307 #+nil (handler-bind ...)
1308 #+nil (handler-case ...)
1310 (multiple-value-bind pprint-progv)
1311 (multiple-value-setq pprint-block)
1312 (pprint-logical-block pprint-block)
1313 (print-unreadable-object pprint-block)
1316 (prog1 pprint-block)
1317 (prog2 pprint-progv)
1320 #+nil (restart-bind ...)
1321 #+nil (restart-case ...)
1325 (typecase pprint-typecase)
1326 (unless pprint-block)
1328 (with-compilation-unit pprint-block)
1329 #+nil (with-condition-restarts ...)
1330 (with-hash-table-iterator pprint-block)
1331 (with-input-from-string pprint-block)
1332 (with-open-file pprint-block)
1333 (with-open-stream pprint-block)
1334 (with-output-to-string pprint-block)
1335 (with-package-iterator pprint-block)
1336 (with-simple-restart pprint-block)
1337 (with-standard-io-syntax pprint-progn)))
1339 (set-pprint-dispatch `(cons (eql ,(first magic-form)))
1340 (symbol-function (second magic-form))))
1342 ;; other pretty-print init forms
1343 (/show0 "about to call !BACKQ-PP-COLD-INIT")
1344 (sb!impl::!backq-pp-cold-init)
1345 (/show0 "leaving !PPRINT-COLD-INIT"))
1347 (setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
1348 (setf *pretty-printer* #'output-pretty-object)
1349 (setf *print-pretty* t))