1
;;; -*- Package: PRETTY-PRINT -*-
3
;;; **********************************************************************
4
;;; This code was written as part of the CMU Common Lisp project at
5
;;; Carnegie Mellon University, and has been placed in the public domain.
7
;;; CMU Common Lisp pretty printer.
8
;;; Written by William Lott. Algorithm stolen from Richard Waters' XP.
15
;;; There are three different units for measuring character positions:
16
;;; COLUMN - offset (if characters) from the start of the current line.
17
;;; INDEX - index into the output buffer.
18
;;; POSN - some position in the stream of characters cycling through
19
;;; 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
(defclass pretty-stream (fundamental-character-output-stream) (
33
;; Where the output is going to finally go.
35
(target :initarg :target :initform t :type stream
36
:accessor pretty-stream-target)
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 :initform (or *print-right-margin* default-line-length)
42
:accessor pretty-stream-line-length)
44
;; A simple string holding all the text that has been output but not yet
46
(buffer :initform (make-string initial-buffer-size) :type simple-string
47
:accessor pretty-stream-buffer)
49
;; The index into BUFFER where more text should be put.
50
(buffer-fill-pointer :initform 0 :type index :accessor pretty-stream-buffer-fill-pointer)
52
;; Whenever we output stuff from the buffer, we shift the remaining noise
53
;; over. This makes it difficult to keep references to locations in
54
;; the buffer. Therefore, we have to keep track of the total amount of
55
;; stuff that has been shifted out of the buffer.
56
(buffer-offset :initform 0 :type posn :accessor pretty-stream-buffer-offset)
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 :initarg :buffer-start-column :type column
62
:accessor pretty-stream-buffer-start-column)
64
;; The line number we are currently on. Used for *print-lines* abrevs and
65
;; to tell when sections have been split across multiple lines.
66
(line-number :initform 0 :type index
67
:accessor pretty-stream-line-number)
69
;; Stack of logical blocks in effect at the buffer start.
70
(blocks :initform (list (make-logical-block)) :type list
71
:accessor pretty-stream-blocks)
73
;; Buffer holding the per-line prefix active at the buffer start.
74
;; Indentation is included in this. The length of this is stored
75
;; in the logical block stack.
76
(prefix :initform (make-string initial-buffer-size) :type string
77
:accessor pretty-stream-prefix)
79
;; Buffer holding the total remaining suffix active at the buffer start.
80
;; The characters are right-justified in the buffer to make it easier
81
;; to output the buffer. The length is stored in the logical block
83
(suffix :initform (make-string initial-buffer-size) :type string
84
:accessor pretty-stream-suffix)
86
;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
87
;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
88
;; cons. Adding things to the queue is basically (setf (cdr head) (list
89
;; new)) and removing them is basically (pop tail) [except that care must
90
;; be taken to handle the empty queue case correctly.]
91
(queue-tail :initform nil :type list :accessor pretty-stream-queue-tail)
92
(queue-head :initform nil :type list :accessor pretty-stream-queue-head)
94
;; Block-start queue entries in effect at the queue head.
95
(pending-blocks :initform nil :type list :accessor pretty-stream-pending-blocks)
98
(defun pretty-stream-p (stream)
99
(typep stream 'pretty-stream))
101
(defun make-pretty-stream (target)
102
(make-instance 'pretty-stream :target target
103
:buffer-start-column (or (file-column target) 0)
106
(defmethod print-object ((pretty-stream pretty-stream) stream)
107
(print-unreadable-object (pstream stream :type t :identity t))
109
(format stream "#<pretty stream {~8,'0X}>"
110
(kernel:get-lisp-obj-address pstream)))
112
(declaim (inline index-posn posn-index posn-column))
113
(defun index-posn (index stream)
114
(declare (type index index) (type pretty-stream stream)
116
(+ index (pretty-stream-buffer-offset stream)))
117
(defun posn-index (posn stream)
118
(declare (type posn posn) (type pretty-stream stream)
120
(- posn (pretty-stream-buffer-offset stream)))
121
(defun posn-column (posn stream)
122
(declare (type posn posn) (type pretty-stream stream)
124
(index-column (posn-index posn stream) stream))
127
;;;; Stream interface routines.
129
(defmethod ext::stream-write-char ((stream pretty-stream) char)
130
(pretty-out stream char))
132
(defmethod ext::stream-force-output ((stream pretty-stream))
133
;(force-pretty-output stream)
136
(defmethod ext::stream-clear-output ((stream pretty-stream))
137
(clear-output (pretty-stream-target stream)))
139
(defun pretty-out (stream char)
140
(declare (type pretty-stream stream)
141
(type base-char char)
143
(cond ((char= char #\newline)
144
(enqueue-newline stream :literal))
146
(assure-space-in-buffer stream 1)
147
(let ((fill-pointer (pretty-stream-buffer-fill-pointer stream)))
148
(setf (schar (pretty-stream-buffer stream) fill-pointer) char)
149
(setf (pretty-stream-buffer-fill-pointer stream)
150
(1+ fill-pointer))))))
152
(defun pretty-sout (stream string start end)
153
(declare (type pretty-stream stream)
154
(type simple-string string)
156
(type (or index null) end)
158
(let ((end (or end (length string))))
159
(unless (= start end)
160
(let ((newline (position #\newline string :start start :end end)))
163
(pretty-sout stream string start newline)
164
(enqueue-newline stream :literal)
165
(pretty-sout stream string (1+ newline) end))
167
(let ((chars (- end start)))
169
(let* ((available (assure-space-in-buffer stream chars))
170
(count (min available chars))
171
(fill-pointer (pretty-stream-buffer-fill-pointer stream))
172
(new-fill-ptr (+ fill-pointer count)))
173
(replace (pretty-stream-buffer stream)
175
:start1 fill-pointer :end1 new-fill-ptr
177
(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
181
(incf start count))))))))))
186
(defstruct logical-block
188
;; The column this logical block started in.
189
(start-column 0 :type column)
191
;; The column the current section started in.
192
(section-column 0 :type column)
194
;; The length of the per-line prefix. We can't move the indentation
196
(per-line-prefix-end 0 :type index)
198
;; The overall length of the prefix, including any indentation.
199
(prefix-length 0 :type index)
201
;; The overall length of the suffix.
202
(suffix-length 0 :type index)
205
(section-start-line 0 :type index))
207
(defun really-start-logical-block (stream column prefix suffix)
208
(declare (si::c-local))
209
(let* ((blocks (pretty-stream-blocks stream))
210
(prev-block (car blocks))
211
(per-line-end (logical-block-per-line-prefix-end prev-block))
212
(prefix-length (logical-block-prefix-length prev-block))
213
(suffix-length (logical-block-suffix-length prev-block))
214
(block (make-logical-block
216
:section-column column
217
:per-line-prefix-end per-line-end
218
:prefix-length prefix-length
219
:suffix-length suffix-length
220
:section-start-line (pretty-stream-line-number stream))))
221
(setf (pretty-stream-blocks stream) (cons block blocks))
222
(set-indentation stream column)
224
(setf (logical-block-per-line-prefix-end block) column)
225
(replace (pretty-stream-prefix stream) prefix
226
:start1 (- column (length prefix)) :end1 column))
228
(let* ((total-suffix (pretty-stream-suffix stream))
229
(total-suffix-len (length total-suffix))
230
(additional (length suffix))
231
(new-suffix-len (+ suffix-length additional)))
232
(when (> new-suffix-len total-suffix-len)
233
(let ((new-total-suffix-len
234
(max (* total-suffix-len 2)
236
(floor (* additional 5) 4)))))
238
(replace (make-string new-total-suffix-len) total-suffix
239
:start1 (- new-total-suffix-len suffix-length)
240
:start2 (- total-suffix-len suffix-length)))
241
(setf total-suffix-len new-total-suffix-len)
242
(setf (pretty-stream-suffix stream) total-suffix)))
243
(replace total-suffix suffix
244
:start1 (- total-suffix-len new-suffix-len)
245
:end1 (- total-suffix-len suffix-length))
246
(setf (logical-block-suffix-length block) new-suffix-len))))
249
(defun set-indentation (stream column)
250
(declare (si::c-local))
251
(let* ((prefix (pretty-stream-prefix stream))
252
(prefix-len (length prefix))
253
(block (car (pretty-stream-blocks stream)))
254
(current (logical-block-prefix-length block))
255
(minimum (logical-block-per-line-prefix-end block))
256
(column (max minimum column)))
257
(when (> column prefix-len)
259
(replace (make-string (max (* prefix-len 2)
261
(floor (* (- column prefix-len) 5)
265
(setf (pretty-stream-prefix stream) prefix))
266
(when (> column current)
267
(fill prefix #\space :start current :end column))
268
(setf (logical-block-prefix-length block) column)))
270
(defun really-end-logical-block (stream)
271
(declare (si::c-local))
272
(let* ((old (pop (pretty-stream-blocks stream)))
273
(old-indent (logical-block-prefix-length old))
274
(new (car (pretty-stream-blocks stream)))
275
(new-indent (logical-block-prefix-length new)))
276
(when (> new-indent old-indent)
277
(fill (pretty-stream-prefix stream) #\space
278
:start old-indent :end new-indent)))
282
;;;; The pending operation queue.
287
(eval-when (:compile-toplevel :execute)
288
(defmacro enqueue (stream type &rest args)
289
(let ((constructor (intern (concatenate 'string
291
(symbol-name type)))))
292
(once-only ((stream stream)
293
(entry `(,constructor :posn
295
(pretty-stream-buffer-fill-pointer
300
(head `(pretty-stream-queue-head ,stream)))
303
(setf (cdr ,head) ,op)
304
(setf (pretty-stream-queue-tail ,stream) ,op))
305
(setf (pretty-stream-queue-head ,stream) ,op)
309
(defstruct (section-start
310
(:include queued-op))
311
(depth 0 :type index)
312
(section-end nil :type (or null newline block-end)))
315
(:include section-start))
316
(kind (required-argument)
317
:type (member :linear :fill :miser :literal :mandatory)))
319
(defun enqueue-newline (stream kind)
320
(declare (si::c-local))
321
(let* ((depth (length (pretty-stream-pending-blocks stream)))
322
(newline (enqueue stream newline :kind kind :depth depth)))
323
(dolist (entry (pretty-stream-queue-tail stream))
324
(when (and (not (eq newline entry))
325
(section-start-p entry)
326
(null (section-start-section-end entry))
327
(<= depth (section-start-depth entry)))
328
(setf (section-start-section-end entry) newline))))
329
(maybe-output stream (or (eq kind :literal) (eq kind :mandatory))))
331
(defstruct (indentation
332
(:include queued-op))
333
(kind (required-argument) :type (member :block :current))
334
(amount 0 :type fixnum))
336
(defun enqueue-indent (stream kind amount)
337
(declare (si::c-local))
338
(enqueue stream indentation :kind kind :amount amount))
340
(defstruct (block-start
341
(:include section-start))
342
(block-end nil :type (or null block-end))
343
(prefix nil :type (or null string))
344
(suffix nil :type (or null string)))
346
(defun start-logical-block (stream prefix per-line-p suffix)
347
(declare (si::c-local)
348
(type string prefix))
350
(unless (stringp prefix)
351
(error 'simple-type-error
352
:format-control "Not a valid PPRINT-LOGICAL-BLOCK prefix: ~A"
353
:format-arguments (list prefix)
355
:expected-type 'string))
357
(unless (stringp suffix)
358
(error 'simple-type-error
359
:format-control "Not a valid PPRINT-LOGICAL-BLOCK suffix: ~A"
360
:format-arguments (list suffix)
362
:expected-type 'string))
363
(let ((prefix-len (length prefix)))
364
(when (plusp prefix-len)
365
(pretty-sout stream prefix 0 prefix-len))
366
(let* ((pending-blocks (pretty-stream-pending-blocks stream))
367
(start (enqueue stream block-start
368
:prefix (and (plusp prefix-len) per-line-p prefix)
369
:suffix (and (plusp (length suffix)) suffix)
370
:depth (length pending-blocks))))
371
(setf (pretty-stream-pending-blocks stream)
372
(cons start pending-blocks)))))
374
(defstruct (block-end
375
(:include queued-op))
376
(suffix nil :type (or null string)))
378
(defun end-logical-block (stream)
379
(declare (si::c-local))
380
(let* ((start (pop (pretty-stream-pending-blocks stream)))
381
(suffix (block-start-suffix start))
382
(end (enqueue stream block-end :suffix suffix)))
384
(pretty-sout stream suffix 0 (length suffix)))
385
(setf (block-start-block-end start) end)))
388
(:include queued-op))
389
(sectionp nil :type (member t nil))
390
(relativep nil :type (member t nil))
391
(colnum 0 :type column)
392
(colinc 0 :type column))
394
(defun enqueue-tab (stream kind colnum colinc)
395
(declare (si::c-local))
399
(:line (values nil nil))
400
(:line-relative (values nil t))
401
(:section (values t nil))
402
(:section-relative (values t t)))
403
(enqueue stream tab :sectionp sectionp :relativep relativep
404
:colnum colnum :colinc colinc)))
409
(defun compute-tab-size (tab section-start column)
410
(declare (si::c-local))
411
(let ((colnum (tab-colnum tab))
412
(colinc (tab-colinc tab)))
413
(when (tab-sectionp tab)
414
(setf column (- column section-start)))
415
(cond ((tab-relativep tab)
416
(unless (<= colinc 1)
417
(let ((newposn (+ column colnum)))
418
(let ((rem (rem newposn colinc)))
420
(incf colnum (- colinc rem))))))
427
(- colinc (rem (- column colnum) colinc)))
431
(defun index-column (index stream)
432
(declare (si::c-local))
433
(let ((column (pretty-stream-buffer-start-column stream))
434
(section-start (logical-block-section-column
435
(first (pretty-stream-blocks stream))))
436
(end-posn (index-posn index stream)))
437
(dolist (op (pretty-stream-queue-tail stream))
438
(when (>= (queued-op-posn op) end-posn)
446
(posn-index (tab-posn op)
448
((or newline block-start)
450
(+ column (posn-index (queued-op-posn op)
454
(defun expand-tabs (stream through)
455
(declare (si::c-local))
456
(let ((insertions nil)
458
(column (pretty-stream-buffer-start-column stream))
459
(section-start (logical-block-section-column
460
(first (pretty-stream-blocks stream)))))
461
(dolist (op (pretty-stream-queue-tail stream))
464
(let* ((index (posn-index (tab-posn op) stream))
465
(tabsize (compute-tab-size op
468
(unless (zerop tabsize)
469
(push (cons index tabsize) insertions)
470
(incf additional tabsize)
471
(incf column tabsize))))
472
((or newline block-start)
474
(+ column (posn-index (queued-op-posn op) stream)))))
475
(when (eq op through)
478
(let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
479
(new-fill-ptr (+ fill-ptr additional))
480
(buffer (pretty-stream-buffer stream))
482
(length (length buffer))
484
(when (> new-fill-ptr length)
485
(let ((new-length (max (* length 2)
487
(floor (* additional 5) 4)))))
488
(setf new-buffer (make-string new-length))
489
(setf (pretty-stream-buffer stream) new-buffer)))
490
(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
491
(decf (pretty-stream-buffer-offset stream) additional)
492
(dolist (insertion insertions)
493
(let* ((srcpos (car insertion))
494
(amount (cdr insertion))
495
(dstpos (+ srcpos additional)))
496
(replace new-buffer buffer :start1 dstpos :start2 srcpos :end2 end)
497
(fill new-buffer #\space :start (- dstpos amount) :end dstpos)
498
(decf additional amount)
500
(unless (eq new-buffer buffer)
501
(replace new-buffer buffer :end1 end :end2 end))))))
504
;;;; Stuff to do the actual outputting.
506
(defun assure-space-in-buffer (stream want)
507
(declare (type pretty-stream stream)
510
(let* ((buffer (pretty-stream-buffer stream))
511
(length (length buffer))
512
(fill-ptr (pretty-stream-buffer-fill-pointer stream))
513
(available (- length fill-ptr)))
514
(cond ((plusp available)
516
((> fill-ptr (pretty-stream-line-length stream))
517
(unless (maybe-output stream nil)
518
(output-partial-line stream))
519
(assure-space-in-buffer stream want))
521
(let* ((new-length (max (* length 2)
523
(floor (* want 5) 4))))
524
(new-buffer (make-string new-length)))
525
(setf (pretty-stream-buffer stream) new-buffer)
526
(replace new-buffer buffer :end1 fill-ptr)
527
(- new-length fill-ptr))))))
529
(defun maybe-output (stream force-newlines-p)
530
(declare (type pretty-stream stream)
532
(let ((tail (pretty-stream-queue-tail stream))
533
(output-anything nil))
536
(setf (pretty-stream-queue-head stream) nil)
538
(let ((next (pop tail)))
541
(when (ecase (newline-kind next)
542
((:literal :mandatory :linear) t)
543
(:miser (misering-p stream))
545
(or (misering-p stream)
546
(> (pretty-stream-line-number stream)
547
(logical-block-section-start-line
548
(first (pretty-stream-blocks stream))))
549
(ecase (fits-on-line-p stream
550
(newline-section-end next)
556
(setf output-anything t)
557
(output-line stream next)))
559
(unless (misering-p stream)
560
(set-indentation stream
561
(+ (ecase (indentation-kind next)
563
(logical-block-start-column
564
(car (pretty-stream-blocks stream))))
567
(indentation-posn next)
569
(indentation-amount next)))))
571
(ecase (fits-on-line-p stream (block-start-section-end next)
574
;; Just nuke the whole logical block and make it look like one
575
;; nice long literal.
576
(let ((end (block-start-block-end next)))
577
(expand-tabs stream end)
578
(setf tail (cdr (member end tail)))))
580
(really-start-logical-block
582
(posn-column (block-start-posn next) stream)
583
(block-start-prefix next)
584
(block-start-suffix next)))
588
(really-end-logical-block stream))
590
(expand-tabs stream next))))
591
(setf (pretty-stream-queue-tail stream) tail))
594
(defun misering-p (stream)
595
(declare (type pretty-stream stream)
597
(and *print-miser-width*
598
(<= (- (pretty-stream-line-length stream)
599
(logical-block-start-column (car (pretty-stream-blocks stream))))
600
*print-miser-width*)))
602
(defun fits-on-line-p (stream until force-newlines-p)
603
(declare (si::c-local))
604
(let ((available (pretty-stream-line-length stream)))
605
(when (and (not *print-readably*) *print-lines*
606
(= *print-lines* (pretty-stream-line-number stream)))
607
(decf available 3) ; for the `` ..''
608
(decf available (logical-block-suffix-length
609
(car (pretty-stream-blocks stream)))))
611
(<= (posn-column (queued-op-posn until) stream) available))
612
(force-newlines-p nil)
613
((> (index-column (pretty-stream-buffer-fill-pointer stream) stream)
619
(defun output-line (stream until)
620
(declare (type pretty-stream stream)
623
(let* ((target (pretty-stream-target stream))
624
(buffer (pretty-stream-buffer stream))
625
(kind (newline-kind until))
626
(literal-p (eq kind :literal))
627
(amount-to-consume (posn-index (newline-posn until) stream))
631
(let ((last-non-blank
632
(position #\space buffer :end amount-to-consume
633
:from-end t :test #'char/=)))
637
(write-string buffer target :end amount-to-print)
638
(let ((line-number (pretty-stream-line-number stream)))
640
(when (and (not *print-readably*)
641
*print-lines* (>= line-number *print-lines*))
642
(write-string " .." target)
643
(let ((suffix-length (logical-block-suffix-length
644
(car (pretty-stream-blocks stream)))))
645
(unless (zerop suffix-length)
646
(let* ((suffix (pretty-stream-suffix stream))
647
(len (length suffix)))
648
(write-string suffix target
649
:start (- len suffix-length)
651
(throw 'line-limit-abbreviation-happened t))
652
(setf (pretty-stream-line-number stream) line-number)
653
(write-char #\newline target)
654
(setf (pretty-stream-buffer-start-column stream) 0)
655
(let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
656
(block (first (pretty-stream-blocks stream)))
659
(logical-block-per-line-prefix-end block)
660
(logical-block-prefix-length block)))
661
(shift (- amount-to-consume prefix-len))
662
(new-fill-ptr (- fill-ptr shift))
664
(buffer-length (length buffer)))
665
(when (> new-fill-ptr buffer-length)
667
(make-string (max (* buffer-length 2)
669
(floor (* (- new-fill-ptr buffer-length)
672
(setf (pretty-stream-buffer stream) new-buffer))
673
(replace new-buffer buffer
674
:start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
675
(replace new-buffer (pretty-stream-prefix stream)
677
(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
678
(incf (pretty-stream-buffer-offset stream) shift)
680
(setf (logical-block-section-column block) prefix-len)
681
(setf (logical-block-section-start-line block) line-number))))))
683
(defun output-partial-line (stream)
684
(declare (si::c-local))
685
(let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
686
(tail (pretty-stream-queue-tail stream))
689
(posn-index (queued-op-posn (car tail)) stream)
691
(new-fill-ptr (- fill-ptr count))
692
(buffer (pretty-stream-buffer stream)))
694
(error "Output-partial-line called when nothing can be output."))
695
(write-string buffer (pretty-stream-target stream)
697
(incf (pretty-stream-buffer-start-column stream) count)
698
(replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr)
699
(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
700
(incf (pretty-stream-buffer-offset stream) count)))
702
(defun force-pretty-output (stream)
703
(declare (si::c-local))
704
(maybe-output stream nil)
705
(expand-tabs stream nil)
706
(write-string (pretty-stream-buffer stream)
707
(pretty-stream-target stream)
708
:end (pretty-stream-buffer-fill-pointer stream)))
713
(defun pprint-pop-helper (object count stream &aux code)
714
(cond ((not (listp object))
715
(write-string ". " stream)
716
(write-object object stream)
718
((and (not *print-readably*)
719
(eql count *print-length*))
720
(write-string "..." stream)
726
(and (symbolp object) (symbol-package object))
727
(null *circle-counter*))
729
((eql 'NULL (setf code (gethash object *circle-stack* 'NULL)))
730
;; We visit this part of the list for the first time and thus we must
731
;; register it in the hash, or we are on the second pass and have
732
;; found a completely new list. This should not happend, but anyway
733
;; we try to print it.
734
(search-print-circle object)
736
((and (null code) (integerp *circle-counter*))
737
;; This object is not visited twice.
740
;; In all other cases, WRITE-OBJECT
741
(write-string ". " stream)
742
(write-object object stream)
745
;;;; User interface to the pretty printer.
747
(defun check-print-level ()
748
(declare (si::c-local))
749
"Automatically handle *print-level* abbreviation. If we are too deep, then
750
a # is printed to STREAM and BODY is ignored."
751
(cond ((or *print-readably* (null *print-level*))
753
((zerop *print-level*)
756
(setf *print-level* (1- *print-level*)))))
758
(defun search-print-circle (object)
759
(declare (si::c-local))
760
(let ((code (gethash object *circle-stack* -1)))
761
(if (fixnump *circle-counter*)
762
(cond ((or (eql code -1) (null code))
763
;; Is not referenced or was not found before
766
;; Reference twice but had no code yet
767
(setf (gethash object *circle-stack*)
768
(setf *circle-counter* (1+ *circle-counter*)))
769
(- *circle-counter*))
772
;; Was not found before
773
(setf (gethash object *circle-stack*) nil)
777
(setf (gethash object *circle-stack*) t)
780
;; Further references
783
(defun do-pprint-logical-block (function object stream prefix
784
per-line-prefix-p suffix)
785
(declare (si::c-local))
786
(unless (listp object)
787
(write-object object stream)
788
(return-from do-pprint-logical-block nil))
789
(when (and (not *print-readably*) (eql *print-level* 0))
790
(write-char #\# stream)
791
(return-from do-pprint-logical-block nil))
792
(unless (or (not *print-circle*)
795
(and (symbolp object) (symbol-package object)))
797
(cond ((not *circle-counter*)
798
(let* ((hash (make-hash-table :test 'eq :size 1024
800
:rehash-threshold 0.75))
802
(*circle-stack* hash))
803
(do-pprint-logical-block function object
804
(make-pretty-stream (make-broadcast-stream))
805
prefix per-line-prefix-p suffix)
806
(setf *circle-counter* 0)
807
(do-pprint-logical-block function object stream
808
prefix per-line-prefix-p suffix))
809
(return-from do-pprint-logical-block nil))
810
((zerop (setf code (search-print-circle object)))
811
;; Object was not referenced before: we must either traverse it
815
;; First definition, we write the #n=... prefix
816
(write-string "#" stream)
817
(let ((*print-radix* nil) (*print-base* 10))
818
(write-ugly-object (- code) stream))
819
(write-string "=" stream))
821
;; Further references, we write the #n# tag and exit
822
(write-string "#" stream)
823
(let ((*print-radix* nil) (*print-base* 10))
824
(write-ugly-object code stream))
825
(write-string "#" stream)
826
(return-from do-pprint-logical-block nil)))))
827
(let ((*print-level* (and (not *print-readably*)
829
(1- *print-level*))))
830
(start-logical-block stream prefix per-line-prefix-p suffix)
831
(funcall function object stream)
832
(end-logical-block stream))
835
(defun pprint-logical-block-helper (function object stream prefix
836
per-line-prefix-p suffix)
837
(setf stream (case stream
838
((nil) *standard-output*)
841
(if (pretty-stream-p stream)
842
(do-pprint-logical-block function object stream prefix
843
per-line-prefix-p suffix)
844
(let ((stream (make-pretty-stream stream)))
845
(catch 'line-limit-abbreviation-happened
846
(do-pprint-logical-block function object stream prefix
847
per-line-prefix-p suffix)
848
(force-pretty-output stream))
851
(defmacro pprint-logical-block
852
((stream-symbol object &key (prefix "" prefix-p)
853
(per-line-prefix "" per-line-prefix-p)
854
(suffix "" suffix-p))
856
"Group some output into a logical block. STREAM-SYMBOL should be either a
857
stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer
858
control variable *PRINT-LEVEL* is automatically handled."
859
(when per-line-prefix-p
861
(error "Cannot specify both a prefix and a per-line-prefix."))
862
(setf prefix per-line-prefix))
863
(let* ((object-var (gensym))
864
(block-name (gensym "PPRINT-LOGICAL-BLOCK-"))
865
(count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
866
(stream-var (case stream-symbol
867
((nil) '*standard-output*)
871
`(ext::lambda-block ,block-name (,object-var ,stream-var
872
&aux (,count-name 0))
873
(macrolet ((pprint-pop ()
875
(unless (pprint-pop-helper ,object-var ,count-name
877
(return-from ,block-name nil))
879
,(if object `(pop ,object-var) nil)))
880
(pprint-exit-if-list-exhausted ()
882
`'(when (null ,object-var)
883
(return-from ,block-name nil))
884
`'(return-from ,block-name nil))))
886
`(pprint-logical-block-helper #',function ,object ,stream-symbol
887
,prefix ,per-line-prefix-p ,suffix)))
889
(defmacro pprint-exit-if-list-exhausted ()
890
"Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
891
if it's list argument is exhausted. Can only be used inside
892
PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
893
PPRINT-LOGICAL-BLOCK is supplied."
894
(error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
895
PPRINT-LOGICAL-BLOCK."))
897
(defmacro pprint-pop ()
898
"Return the next element from LIST argument to the closest enclosing
899
use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
900
and *PRINT-CIRCLE*. Can only be used inside PPRINT-LOGICAL-BLOCK.
901
If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
902
is poped, but the *PRINT-LENGTH* testing still happens."
903
(error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))
905
(defun pprint-newline (kind &optional stream)
906
"Output a conditional newline to STREAM (which defaults to
907
*STANDARD-OUTPUT*) if it is a pretty-printing stream, and do
908
nothing if not. KIND can be one of:
909
:LINEAR - A line break is inserted if and only if the immediatly
910
containing section cannot be printed on one line.
911
:MISER - Same as LINEAR, but only if ``miser-style'' is in effect.
912
(See *PRINT-MISER-WIDTH*.)
913
:FILL - A line break is inserted if and only if either:
914
(a) the following section cannot be printed on the end of the
916
(b) the preceding section was not printed on a single line, or
917
(c) the immediately containing section cannot be printed on one
918
line and miser-style is in effect.
919
:MANDATORY - A line break is always inserted.
920
When a line break is inserted by any type of conditional newline, any
921
blanks that immediately precede the conditional newline are ommitted
922
from the output and indentation is introduced at the beginning of the
923
next line. (See PPRINT-INDENT.)"
924
(declare (type (member :linear :miser :fill :mandatory) kind)
925
(type (or stream (member t nil)) stream)
928
(unless (member kind '(:linear :miser :fill :mandatory))
929
(error 'simple-type-error
930
:format-control "~A is not a valid argument to PPRINT-NEWLINE"
931
:format-arguments (list kind)
933
:expected-type '(member :linear :miser :fill :mandatory)))
934
(let ((stream (case stream
936
((nil) *standard-output*)
938
(when (and (pretty-stream-p stream) *print-pretty*)
939
(enqueue-newline stream kind)))
942
(defun pprint-indent (relative-to n &optional stream)
943
"Specify the indentation to use in the current logical block if STREAM
944
(which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream
945
and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the indention
946
to use (in ems, the width of an ``m'') and RELATIVE-TO can be either:
947
:BLOCK - Indent relative to the column the current logical block
949
:CURRENT - Indent relative to the current column.
950
The new indention value does not take effect until the following line
952
(declare (type (member :block :current) relative-to)
954
(type (or stream (member t nil)) stream)
957
(unless (member relative-to '(:block :current))
958
(error 'simple-type-error
959
:format-control "~A is not a valid argument to PPRINT-INDENT"
960
:format-arguments (list kind)
962
:expected-type '(member :block :current)))
963
(let ((stream (case stream
965
((nil) *standard-output*)
967
(when (and (pretty-stream-p stream) *print-pretty*)
968
(enqueue-indent stream relative-to (round n))))
971
(defun pprint-tab (kind colnum colinc &optional stream)
972
"If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing
973
stream, perform tabbing based on KIND, otherwise do nothing. KIND can
975
:LINE - Tab to column COLNUM. If already past COLNUM tab to the next
977
:SECTION - Same as :LINE, but count from the start of the current
978
section, not the start of the line.
979
:LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of
981
:SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start
982
of the current section, not the start of the line."
983
(declare (type (member :line :section :line-relative :section-relative) kind)
984
(type unsigned-byte colnum colinc)
985
(type (or stream (member t nil)) stream)
988
(unless (member kind '(:line :section :line-relative :section-relative))
989
(error 'simple-type-error
990
:format-control "~A is not a valid argument to PPRINT-TAB"
991
:format-arguments (list kind)
993
:expected-type '(member :line :section :line-relative :section-relative)))
994
(let ((stream (case stream
996
((nil) *standard-output*)
998
(when (and (pretty-stream-p stream) *print-pretty*)
999
(enqueue-tab stream kind colnum colinc)))
1002
(defun pprint-fill (stream list &optional (colon? t) atsign?)
1003
"Output LIST to STREAM putting :FILL conditional newlines between each
1004
element. If COLON? is NIL (defaults to T), then no parens are printed
1005
around the output. ATSIGN? is ignored (but allowed so that PPRINT-FILL
1006
can be used with the ~/.../ format directive."
1007
(declare (ignore atsign?))
1008
(pprint-logical-block (stream list
1009
:prefix (if colon? "(" "")
1010
:suffix (if colon? ")" ""))
1011
(pprint-exit-if-list-exhausted)
1013
(write-object (pprint-pop) stream)
1014
(pprint-exit-if-list-exhausted)
1015
(write-char #\space stream)
1016
(pprint-newline :fill stream))))
1018
(defun pprint-linear (stream list &optional (colon? t) atsign?)
1019
"Output LIST to STREAM putting :LINEAR conditional newlines between each
1020
element. If COLON? is NIL (defaults to T), then no parens are printed
1021
around the output. ATSIGN? is ignored (but allowed so that PPRINT-LINEAR
1022
can be used with the ~/.../ format directive."
1023
(declare (ignore atsign?))
1024
(pprint-logical-block (stream list
1025
:prefix (if colon? "(" "")
1026
:suffix (if colon? ")" ""))
1027
(pprint-exit-if-list-exhausted)
1029
(write-object (pprint-pop) stream)
1030
(pprint-exit-if-list-exhausted)
1031
(write-char #\space stream)
1032
(pprint-newline :linear stream))))
1034
(defun pprint-tabular (stream list &optional (colon? t) atsign? tabsize)
1035
"Output LIST to STREAM tabbing to the next column that is an even multiple
1036
of TABSIZE (which defaults to 16) between each element. :FILL style
1037
conditional newlines are also output between each element. If COLON? is
1038
NIL (defaults to T), then no parens are printed around the output.
1039
ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with
1040
the ~/.../ format directive."
1041
(declare (ignore atsign?))
1042
(pprint-logical-block (stream list
1043
:prefix (if colon? "(" "")
1044
:suffix (if colon? ")" ""))
1045
(pprint-exit-if-list-exhausted)
1047
(write-object (pprint-pop) stream)
1048
(pprint-exit-if-list-exhausted)
1049
(write-char #\space stream)
1050
(pprint-tab :section-relative 0 (or tabsize 16) stream)
1051
(pprint-newline :fill stream))))
1054
;;;; Pprint-dispatch tables.
1056
(defvar *initial-pprint-dispatch*)
1058
(defstruct (pprint-dispatch-entry
1059
(:print-function %print-pprint-dispatch-entry))
1061
;; The type specifier for this entry.
1062
(type (required-argument) :type t)
1064
;; The priority for this guy.
1065
(priority 0 :type real)
1067
;; T iff one of the original entries.
1068
(initial-p (not (boundp '*initial-pprint-dispatch*)) :type (member t nil))
1070
;; And the associated function.
1071
(function (required-argument) :type (or function symbol)))
1073
(defun %print-pprint-dispatch-entry (entry stream depth)
1074
(declare (ignore depth))
1075
(print-unreadable-object (entry stream :type t)
1076
(format stream "Type=~S, priority=~S~@[ [Initial]~]"
1077
(pprint-dispatch-entry-type entry)
1078
(pprint-dispatch-entry-priority entry)
1079
(pprint-dispatch-entry-initial-p entry))))
1081
(defstruct (pprint-dispatch-table
1082
(:print-function %print-pprint-dispatch-table))
1084
;; A list of all the entries (except for CONS entries below) in highest
1085
;; to lowest priority.
1086
(entries nil :type list)
1088
;; A hash table mapping things to entries for type specifiers of the
1089
;; form (CONS (MEMBER <thing>)). If the type specifier is of this form,
1090
;; we put it in this hash table instead of the regular entries table.
1091
(cons-entries (make-hash-table :test #'eql)))
1093
(defun %print-pprint-dispatch-table (table stream depth)
1094
(declare (ignore depth))
1095
(print-unreadable-object (table stream :type t :identity t)))
1097
(defun cons-type-specifier-p (spec)
1098
(declare (si::c-local))
1100
(eq (car spec) 'cons)
1103
(let ((car (cadr spec)))
1105
(let ((carcar (car car)))
1106
(or (eq carcar 'member)
1109
(null (cddr car))))))
1111
(defun entry< (e1 e2)
1112
(declare (type pprint-dispatch-entry e1 e2)
1114
(if (pprint-dispatch-entry-initial-p e1)
1115
(if (pprint-dispatch-entry-initial-p e2)
1116
(< (pprint-dispatch-entry-priority e1)
1117
(pprint-dispatch-entry-priority e2))
1119
(if (pprint-dispatch-entry-initial-p e2)
1121
(< (pprint-dispatch-entry-priority e1)
1122
(pprint-dispatch-entry-priority e2)))))
1125
(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
1126
(declare (type (or pprint-dispatch-table null) table))
1127
(let* ((orig (or table *initial-pprint-dispatch*))
1128
(new (make-pprint-dispatch-table
1129
:entries (copy-list (pprint-dispatch-table-entries orig))))
1130
(new-cons-entries (pprint-dispatch-table-cons-entries new)))
1131
(maphash #'(lambda (key value)
1132
(setf (gethash key new-cons-entries) value))
1133
(pprint-dispatch-table-cons-entries orig))
1136
(defun pprint-dispatch (object &optional (table *print-pprint-dispatch*))
1137
(declare (type (or pprint-dispatch-table null) table))
1138
(let* ((table (or table *initial-pprint-dispatch*))
1141
(gethash (car object)
1142
(pprint-dispatch-table-cons-entries table))))
1144
(dolist (entry (pprint-dispatch-table-entries table) cons-entry)
1145
(when (and cons-entry
1146
(entry< entry cons-entry))
1147
(return cons-entry))
1148
(when (typep object (pprint-dispatch-entry-type entry))
1151
(values (pprint-dispatch-entry-function entry) t)
1152
(values #'(lambda (stream object)
1153
(write-ugly-object object stream))
1156
(defun set-pprint-dispatch (type function &optional
1157
(priority 0) (table *print-pprint-dispatch*))
1158
(declare (type (or null function) function)
1159
(type real priority)
1160
(type pprint-dispatch-table table))
1161
;; FIXME! This check should be automatically generated when compiling
1162
;; with high enough safety mode.
1163
(unless (typep priority 'real)
1164
(error 'simple-type-error
1165
:format-control "Not a valid priority for set-pprint-dispatch: ~A"
1166
:format-arguments (list priority)
1167
:expected-type 'real
1170
(if (cons-type-specifier-p type)
1171
(setf (gethash (second (second type))
1172
(pprint-dispatch-table-cons-entries table))
1173
(make-pprint-dispatch-entry :type type :priority priority
1174
:function function))
1175
(let ((list (delete type (pprint-dispatch-table-entries table)
1176
:key #'pprint-dispatch-entry-type
1178
(entry (make-pprint-dispatch-entry
1180
:priority priority :function function)))
1181
(do ((prev nil next)
1182
(next list (cdr next)))
1185
(setf (cdr prev) (list entry))
1186
(setf list (list entry))))
1187
(when (entry< (car next) entry)
1189
(setf (cdr prev) (cons entry next))
1190
(setf list (cons entry next)))
1192
(setf (pprint-dispatch-table-entries table) list)))
1193
(if (cons-type-specifier-p type)
1194
(remhash (second (second type))
1195
(pprint-dispatch-table-cons-entries table))
1196
(setf (pprint-dispatch-table-entries table)
1197
(delete type (pprint-dispatch-table-entries table)
1198
:key #'pprint-dispatch-entry-type
1203
;;;; Standard pretty-printing routines.
1205
(defun pprint-array (stream array)
1206
(cond ((or (and (null *print-array*) (null *print-readably*))
1208
(bit-vector-p array))
1209
(write-ugly-object array stream))
1211
(pprint-raw-array stream array))
1213
(pprint-vector stream array))
1215
(pprint-multi-dim-array stream array))))
1217
(defun pprint-vector (stream vector)
1218
(pprint-logical-block (stream nil :prefix "#(" :suffix ")")
1219
(dotimes (i (length vector))
1221
(write-char #\space stream)
1222
(pprint-newline :fill stream))
1224
(write-object (aref vector i) stream))))
1226
(defun pprint-array-contents (stream array)
1227
(declare (si::c-local)
1229
(labels ((output-guts (stream index dimensions)
1230
(if (null dimensions)
1231
(write-object (row-major-aref array index) stream)
1232
(pprint-logical-block
1233
(stream nil :prefix "(" :suffix ")")
1234
(let ((dim (car dimensions)))
1236
(let* ((dims (cdr dimensions))
1238
(step (reduce #'* dims))
1242
(output-guts stream index dims)
1243
(when (= (incf count) dim)
1245
(write-char #\space stream)
1246
(pprint-newline (if dims :linear :fill)
1248
(incf index step)))))))))
1249
(output-guts stream 0 (array-dimensions array))))
1251
(defun pprint-multi-dim-array (stream array)
1252
(declare (si::c-local))
1253
(funcall (formatter "#~DA") stream (array-rank array))
1254
(pprint-array-contents stream array))
1256
(defun pprint-raw-array (stream array)
1257
(declare (si::c-local))
1258
(write-string "#A" stream)
1259
(pprint-logical-block (stream nil :prefix "(" :suffix ")")
1260
(write-object (array-element-type array) stream)
1261
(write-char #\Space stream)
1262
(pprint-newline :fill stream)
1263
(write-object (array-dimensions array) stream)
1264
(write-char #\Space stream)
1265
(pprint-newline :fill stream)
1266
(pprint-array-contents stream array)))
1268
(defun pprint-lambda-list (stream lambda-list &rest noise)
1269
(declare (ignore noise))
1270
(pprint-logical-block (stream lambda-list :prefix "(" :suffix ")")
1271
(let ((state :required)
1274
(pprint-exit-if-list-exhausted)
1276
(write-char #\space stream))
1277
(let ((arg (pprint-pop)))
1281
(setf state :optional)
1282
(pprint-newline :linear stream))
1284
(setf state :required)
1285
(pprint-newline :linear stream))
1288
(pprint-newline :linear stream))
1290
(setf state :optional)
1291
(pprint-newline :linear stream))
1293
(pprint-newline :fill stream))))
1296
(pprint-lambda-list stream arg))
1298
(pprint-logical-block
1299
(stream arg :prefix "(" :suffix ")")
1300
(pprint-exit-if-list-exhausted)
1302
(pprint-logical-block
1303
(stream (pprint-pop) :prefix "(" :suffix ")")
1304
(pprint-exit-if-list-exhausted)
1305
(write-object (pprint-pop) stream)
1306
(pprint-exit-if-list-exhausted)
1307
(write-char #\space stream)
1308
(pprint-newline :fill stream)
1309
(pprint-lambda-list stream (pprint-pop))
1311
(pprint-exit-if-list-exhausted)
1312
(write-char #\space stream)
1313
(pprint-newline :fill stream)
1314
(write-object (pprint-pop) stream)))
1315
(pprint-lambda-list stream (pprint-pop)))
1317
(pprint-exit-if-list-exhausted)
1318
(write-char #\space stream)
1319
(pprint-newline :linear stream)
1320
(write-object (pprint-pop) stream))))))
1321
(setf first nil)))))
1323
(defun pprint-lambda (stream list &rest noise)
1324
(declare (ignore noise))
1326
"~:<~^~W~^~3I ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
1329
(defun pprint-block (stream list &rest noise)
1330
(declare (ignore noise))
1331
(funcall (formatter "~:<~^~W~^~3I ~:_~W~1I~@{ ~_~W~}~:>") stream list))
1333
(defun pprint-flet (stream list &rest noise)
1334
(declare (ignore noise))
1336
"~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
1340
(defun pprint-let (stream list &rest noise)
1341
(declare (ignore noise))
1342
(funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>")
1346
(defun pprint-progn (stream list &rest noise)
1347
(declare (ignore noise))
1348
(funcall (formatter "~:<~^~W~@{ ~_~W~}~:>") stream list))
1350
(defun pprint-progv (stream list &rest noise)
1351
(declare (ignore noise))
1352
(funcall (formatter "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>")
1355
(defun pprint-quote (stream list &rest noise)
1356
(declare (ignore noise))
1357
(if (and (consp list)
1362
(write-string "#'" stream)
1363
(write-object (cadr list) stream))
1365
(write-char #\' stream)
1366
(write-object (cadr list) stream))
1368
(pprint-fill stream list)))
1369
(pprint-fill stream list)))
1371
(defun pprint-setq (stream list &rest noise)
1372
(declare (ignore noise))
1373
(pprint-logical-block (stream list :prefix "(" :suffix ")")
1374
(pprint-exit-if-list-exhausted)
1375
(write-object (pprint-pop) stream)
1376
(pprint-exit-if-list-exhausted)
1377
(write-char #\space stream)
1378
(pprint-newline :miser stream)
1379
(if (and (consp (cdr list)) (consp (cddr list)))
1381
(pprint-indent :current 2 stream)
1382
(write-object (pprint-pop) stream)
1383
(pprint-exit-if-list-exhausted)
1384
(write-char #\space stream)
1385
(pprint-newline :linear stream)
1386
(pprint-indent :current -2 stream)
1387
(write-object (pprint-pop) stream)
1388
(pprint-exit-if-list-exhausted)
1389
(write-char #\space stream)
1390
(pprint-newline :linear stream))
1392
(pprint-indent :current 0 stream)
1393
(write-object (pprint-pop) stream)
1394
(pprint-exit-if-list-exhausted)
1395
(write-char #\space stream)
1396
(pprint-newline :linear stream)
1397
(write-object (pprint-pop) stream)))))
1400
(defmacro pprint-tagbody-guts (stream)
1402
(pprint-exit-if-list-exhausted)
1403
(write-char #\space ,stream)
1404
(let ((form-or-tag (pprint-pop)))
1405
(pprint-indent :block
1406
(if (atom form-or-tag) 0 1)
1408
(pprint-newline :linear ,stream)
1409
(write-object form-or-tag ,stream))))
1411
(defun pprint-tagbody (stream list &rest noise)
1412
(declare (ignore noise))
1413
(pprint-logical-block (stream list :prefix "(" :suffix ")")
1414
(pprint-exit-if-list-exhausted)
1415
(write-object (pprint-pop) stream)
1416
(pprint-tagbody-guts stream)))
1418
(defun pprint-case (stream list &rest noise)
1419
(declare (ignore noise))
1421
"~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/SI:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>")
1425
(defun pprint-defun (stream list &rest noise)
1426
(declare (ignore noise))
1428
"~:<~^~W~^ ~@_~:I~W~^ ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
1432
(defun pprint-destructuring-bind (stream list &rest noise)
1433
(declare (ignore noise))
1435
"~:<~^~W~^~3I ~_~:/SI:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>")
1438
(defun pprint-do (stream list &rest noise)
1439
(declare (ignore noise))
1440
(pprint-logical-block (stream list :prefix "(" :suffix ")")
1441
(pprint-exit-if-list-exhausted)
1442
(write-object (pprint-pop) stream)
1443
(pprint-exit-if-list-exhausted)
1444
(write-char #\space stream)
1445
(pprint-indent :current 0 stream)
1446
(funcall (formatter "~:<~@{~:<~^~W~^ ~@_~:I~W~@{ ~_~W~}~:>~^~:@_~}~:>")
1449
(pprint-exit-if-list-exhausted)
1450
(write-char #\space stream)
1451
(pprint-newline :linear stream)
1452
(pprint-linear stream (pprint-pop))
1453
(pprint-tagbody-guts stream)))
1455
(defun pprint-dolist (stream list &rest noise)
1456
(declare (ignore noise))
1457
(pprint-logical-block (stream list :prefix "(" :suffix ")")
1458
(pprint-exit-if-list-exhausted)
1459
(write-object (pprint-pop) stream)
1460
(pprint-exit-if-list-exhausted)
1461
(pprint-indent :block 3 stream)
1462
(write-char #\space stream)
1463
(pprint-newline :fill stream)
1464
(funcall (formatter "~:<~^~W~^ ~:_~:I~W~@{ ~_~W~}~:>")
1467
(pprint-tagbody-guts stream)))
1469
(defun pprint-typecase (stream list &rest noise)
1470
(declare (ignore noise))
1472
"~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>")
1476
(defun pprint-prog (stream list &rest noise)
1477
(declare (ignore noise))
1478
(pprint-logical-block (stream list :prefix "(" :suffix ")")
1479
(pprint-exit-if-list-exhausted)
1480
(write-object (pprint-pop) stream)
1481
(pprint-exit-if-list-exhausted)
1482
(write-char #\space stream)
1483
(pprint-newline :miser stream)
1484
(pprint-fill stream (pprint-pop))
1485
(pprint-tagbody-guts stream)))
1487
(defun pprint-function-call (stream list &rest noise)
1488
(declare (ignore noise))
1489
(funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>")
1494
;;;; Interface seen by regular (ugly) printer and initialization routines.
1496
(eval-when (:compile-toplevel :execute)
1497
(defconstant +magic-forms+
1498
'((lambda pprint-lambda)
1500
(block pprint-block)
1501
(catch pprint-block)
1502
(compiler-let pprint-let)
1503
(eval-when pprint-block)
1505
(function pprint-quote)
1506
(labels pprint-flet)
1509
(locally pprint-progn)
1510
(macrolet pprint-flet)
1511
(multiple-value-call pprint-block)
1512
(multiple-value-prog1 pprint-block)
1513
(progn pprint-progn)
1514
(progv pprint-progv)
1515
(quote pprint-quote)
1516
(return-from pprint-block)
1518
(symbol-macrolet pprint-let)
1519
(tagbody pprint-tagbody)
1520
(throw pprint-block)
1521
(unwind-protect pprint-block)
1526
(ctypecase pprint-typecase)
1527
(defconstant pprint-block)
1528
(define-modify-macro pprint-defun)
1529
(define-setf-expander pprint-defun)
1530
(defmacro pprint-defun)
1531
(defparameter pprint-block)
1532
(defsetf pprint-defun)
1533
(defstruct pprint-block)
1534
(deftype pprint-defun)
1535
(defun pprint-defun)
1536
(defvar pprint-block)
1537
(destructuring-bind pprint-destructuring-bind)
1540
(do-all-symbols pprint-dolist)
1541
(do-external-symbols pprint-dolist)
1542
(do-symbols pprint-dolist)
1543
(dolist pprint-dolist)
1544
(dotimes pprint-dolist)
1546
(etypecase pprint-typecase)
1547
#+nil (handler-bind ...)
1548
#+nil (handler-case ...)
1550
(multiple-value-bind pprint-progv)
1551
(multiple-value-setq pprint-block)
1552
(pprint-logical-block pprint-block)
1553
(print-unreadable-object pprint-block)
1556
(prog1 pprint-block)
1557
(prog2 pprint-progv)
1560
#+nil (restart-bind ...)
1561
#+nil (restart-case ...)
1565
(typecase pprint-typecase)
1566
(unless pprint-block)
1568
(with-compilation-unit pprint-block)
1569
#+nil (with-condition-restarts ...)
1570
(with-hash-table-iterator pprint-block)
1571
(with-input-from-string pprint-block)
1572
(with-open-file pprint-block)
1573
(with-open-stream pprint-block)
1574
(with-output-to-string pprint-block)
1575
(with-package-iterator pprint-block)
1576
(with-simple-restart pprint-block)
1577
(with-standard-io-syntax pprint-progn))))
1580
(let ((*print-pprint-dispatch* (make-pprint-dispatch-table)))
1581
;; Printers for regular types.
1582
(set-pprint-dispatch 'array #'pprint-array)
1583
(set-pprint-dispatch '(cons (and symbol (satisfies fboundp)))
1584
#'pprint-function-call -1)
1585
(set-pprint-dispatch 'cons #'pprint-fill -2)
1586
;; Cons cells with interesting things for the car.
1587
(dolist (magic-form '#.+magic-forms+)
1588
(set-pprint-dispatch `(cons (eql ,(first magic-form)))
1589
(symbol-function (second magic-form))))
1590
(setf *initial-pprint-dispatch* *print-pprint-dispatch*)
1592
(setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
1594
(setf *print-pretty* t))
added
removed
src/lsp/pprint.lsp
