pprint.lisp 67.5 KB
Newer Older
1
;;; -*- Package: PRETTY-PRINT -*-
ram's avatar
ram committed
2
3
;;;
;;; **********************************************************************
4
5
6
7
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
8
  "$Header: src/code/pprint.lisp $")
9
;;;
ram's avatar
ram committed
10
11
12
;;; **********************************************************************
;;;
;;; CMU Common Lisp pretty printer.
13
;;; Written by William Lott.  Algorithm stolen from Richard Waters' XP.
ram's avatar
ram committed
14
;;;
ram's avatar
ram committed
15
(in-package "PRETTY-PRINT")
16
17
18
(use-package "EXT")
(use-package "KERNEL")

19
20
(intl:textdomain "cmucl")

21
(export '(pretty-stream pretty-stream-p))
ram's avatar
ram committed
22
23

(in-package "LISP")
24
25
26
27
28
29
30
31
32
33
34
35
(export '(pprint-logical-block pprint-pop pprint-exit-if-list-exhausted
	  pprint-newline pprint-indent pprint-tab
	  pprint-fill pprint-linear pprint-tabular
	  copy-pprint-dispatch pprint-dispatch set-pprint-dispatch))
(in-package "PP")


;;;; Pretty streams

;;; There are three different units for measuring character positions:
;;;  COLUMN - offset (if characters) from the start of the current line.
;;;  INDEX - index into the output buffer.
36
;;;  POSN - some position in the stream of characters cycling through
37
38
39
40
41
;;;             the output buffer.
;;; 
(deftype column ()
  '(and fixnum unsigned-byte))
;;; The INDEX type is picked up from the kernel package.
42
(deftype posn ()
43
44
45
46
47
48
49
  'fixnum)

(defconstant initial-buffer-size 128)

(defconstant default-line-length 80)

(defstruct (pretty-stream
dtc's avatar
dtc committed
50
	    (:include sys:lisp-stream
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
		      (:out #'pretty-out)
		      (:sout #'pretty-sout)
		      (:misc #'pretty-misc))
	    (:constructor make-pretty-stream (target))
	    (:print-function %print-pretty-stream))
  ;;
  ;; Where the output is going to finally go.
  ;; 
  (target (required-argument) :type stream)
  ;;
  ;; Line length we should format to.  Cached here so we don't have to keep
  ;; extracting it from the target stream.
  (line-length (or *print-right-margin*
		   (lisp::line-length target)
		   default-line-length)
	       :type column)
  ;;
  ;; A simple string holding all the text that has been output but not yet
  ;; printed.
  (buffer (make-string initial-buffer-size) :type simple-string)
  ;;
  ;; The index into BUFFER where more text should be put.
  (buffer-fill-pointer 0 :type index)
  ;;
  ;; Whenever we output stuff from the buffer, we shift the remaining noise
  ;; over.  This makes it difficult to keep references to locations in
  ;; the buffer.  Therefore, we have to keep track of the total amount of
  ;; stuff that has been shifted out of the buffer.
79
  (buffer-offset 0 :type posn)
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
  ;;
  ;; The column the first character in the buffer will appear in.  Normally
  ;; zero, but if we end up with a very long line with no breaks in it we
  ;; might have to output part of it.  Then this will no longer be zero.
  (buffer-start-column (or (lisp::charpos target) 0) :type column)
  ;;
  ;; The line number we are currently on.  Used for *print-lines* abrevs and
  ;; to tell when sections have been split across multiple lines.
  (line-number 0 :type index)
  ;;
  ;; Stack of logical blocks in effect at the buffer start.
  (blocks (list (make-logical-block)) :type list)
  ;;
  ;; Buffer holding the per-line prefix active at the buffer start.
  ;; Indentation is included in this.  The length of this is stored
  ;; in the logical block stack.
  (prefix (make-string initial-buffer-size) :type simple-string)
  ;;
  ;; Buffer holding the total remaining suffix active at the buffer start.
  ;; The characters are right-justified in the buffer to make it easier
  ;; to output the buffer.  The length is stored in the logical block
  ;; stack.
  (suffix (make-string initial-buffer-size) :type simple-string)
  ;;
  ;; Queue of pending operations.  When empty, HEAD=TAIL=NIL.  Otherwise,
  ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
  ;; cons.  Adding things to the queue is basically (setf (cdr head) (list
  ;; new)) and removing them is basically (pop tail) [except that care must
  ;; be taken to handle the empty queue case correctly.]
  (queue-tail nil :type list)
  (queue-head nil :type list)
  ;;
  ;; Block-start queue entries in effect at the queue head.
  (pending-blocks nil :type list)
114
115
116
117
  ;; 
  ;; Queue of annotations to the buffer
  (annotations-tail nil :type list)
  (annotations-head nil :type list))
118
119
120
121
122
123
124
125
126

(defun %print-pretty-stream (pstream stream depth)
  (declare (ignore depth))
  #+nil
  (print-unreadable-object (pstream stream :type t :identity t))
  (format stream "#<pretty stream {~8,'0X}>"
	  (kernel:get-lisp-obj-address pstream)))


127
128
(declaim (inline index-posn posn-index posn-column))
(defun index-posn (index stream)
129
  (declare (type index index) (type pretty-stream stream)
130
	   (values posn))
131
  (+ index (pretty-stream-buffer-offset stream)))
132
133
(defun posn-index (posn stream)
  (declare (type posn posn) (type pretty-stream stream)
134
	   (values index))
135
136
137
138
139
  (- posn (pretty-stream-buffer-offset stream)))
(defun posn-column (posn stream)
  (declare (type posn posn) (type pretty-stream stream)
	   (values posn))
  (index-column (posn-index posn stream) stream))
140
141
142
143
144
145


;;;; Stream interface routines.

(defun pretty-out (stream char)
  (declare (type pretty-stream stream)
ram's avatar
ram committed
146
	   (type base-char char))
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
  (cond ((char= char #\newline)
	 (enqueue-newline stream :literal))
	(t
	 (assure-space-in-buffer stream 1)
	 (let ((fill-pointer (pretty-stream-buffer-fill-pointer stream)))
	   (setf (schar (pretty-stream-buffer stream) fill-pointer) char)
	   (setf (pretty-stream-buffer-fill-pointer stream)
		 (1+ fill-pointer))))))

(defun pretty-sout (stream string start end)
  (declare (type pretty-stream stream)
	   (type simple-string string)
	   (type index start)
	   (type (or index null) end))
  (let ((end (or end (length string))))
    (unless (= start end)
      (let ((newline (position #\newline string :start start :end end)))
	(cond
	 (newline
	  (pretty-sout stream string start newline)
	  (enqueue-newline stream :literal)
	  (pretty-sout stream string (1+ newline) end))
	 (t
	  (let ((chars (- end start)))
	    (loop
	      (let* ((available (assure-space-in-buffer stream chars))
		     (count (min available chars))
		     (fill-pointer (pretty-stream-buffer-fill-pointer stream))
		     (new-fill-ptr (+ fill-pointer count)))
		(replace (pretty-stream-buffer stream)
			 string
			 :start1 fill-pointer :end1 new-fill-ptr
			 :start2 start)
		(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
		(decf chars count)
		(when (zerop count)
		  (return))
		(incf start count))))))))))

(defun pretty-misc (stream op &optional arg1 arg2)
  (declare (ignore stream op arg1 arg2)))



;;;; Logical blocks.

(defstruct logical-block
  ;;
  ;; The column this logical block started in.
  (start-column 0 :type column)
  ;;
198
199
200
  ;; The column the current section started in.
  (section-column 0 :type column)
  ;;
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
  ;; The length of the per-line prefix.  We can't move the indentation
  ;; left of this.
  (per-line-prefix-end 0 :type index)
  ;;
  ;; The overall length of the prefix, including any indentation.
  (prefix-length 0 :type index)
  ;;
  ;; The overall length of the suffix.
  (suffix-length 0 :type index)
  ;; 
  ;; The line number 
  (section-start-line 0 :type index))

(defun really-start-logical-block (stream column prefix suffix)
  (let* ((blocks (pretty-stream-blocks stream))
	 (prev-block (car blocks))
	 (per-line-end (logical-block-per-line-prefix-end prev-block))
	 (prefix-length (logical-block-prefix-length prev-block))
	 (suffix-length (logical-block-suffix-length prev-block))
	 (block (make-logical-block
		 :start-column column
222
		 :section-column column
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
		 :per-line-prefix-end per-line-end
		 :prefix-length prefix-length
		 :suffix-length suffix-length
		 :section-start-line (pretty-stream-line-number stream))))
    (setf (pretty-stream-blocks stream) (cons block blocks))
    (set-indentation stream column)
    (when prefix
      (setf (logical-block-per-line-prefix-end block) column)
      (replace (pretty-stream-prefix stream) prefix
	       :start1 (- column (length prefix)) :end1 column))
    (when suffix
      (let* ((total-suffix (pretty-stream-suffix stream))
	     (total-suffix-len (length total-suffix))
	     (additional (length suffix))
	     (new-suffix-len (+ suffix-length additional)))
	(when (> new-suffix-len total-suffix-len)
	  (let ((new-total-suffix-len
		 (max (* total-suffix-len 2)
		      (+ suffix-length
			 (floor (* additional 5) 4)))))
	    (setf total-suffix
		  (replace (make-string new-total-suffix-len) total-suffix
			   :start1 (- new-total-suffix-len suffix-length)
			   :start2 (- total-suffix-len suffix-length)))
	    (setf total-suffix-len new-total-suffix-len)
	    (setf (pretty-stream-suffix stream) total-suffix)))
	(replace total-suffix suffix
		 :start1 (- total-suffix-len new-suffix-len)
		 :end1 (- total-suffix-len suffix-length))
252
	(setf (logical-block-suffix-length block) new-suffix-len))))
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
  nil)

(defun set-indentation (stream column)
  (let* ((prefix (pretty-stream-prefix stream))
	 (prefix-len (length prefix))
	 (block (car (pretty-stream-blocks stream)))
	 (current (logical-block-prefix-length block))
	 (minimum (logical-block-per-line-prefix-end block))
	 (column (max minimum column)))
    (when (> column prefix-len)
      (setf prefix
	    (replace (make-string (max (* prefix-len 2)
				       (+ prefix-len
					  (floor (* (- column prefix-len) 5)
						 4))))
		     prefix
		     :end1 current))
      (setf (pretty-stream-prefix stream) prefix))
    (when (> column current)
      (fill prefix #\space :start current :end column))
    (setf (logical-block-prefix-length block) column)))

(defun really-end-logical-block (stream)
  (let* ((old (pop (pretty-stream-blocks stream)))
	 (old-indent (logical-block-prefix-length old))
	 (new (car (pretty-stream-blocks stream)))
	 (new-indent (logical-block-prefix-length new)))
    (when (> new-indent old-indent)
      (fill (pretty-stream-prefix stream) #\space
	    :start old-indent :end new-indent)))
  nil)



;;;; The pending operation queue.

(defstruct queued-op
290
  (posn 0 :type posn))
291
292
293
294
295
296

(defmacro enqueue (stream type &rest args)
  (let ((constructor (intern (concatenate 'string
					  "MAKE-"
					  (symbol-name type)))))
    (once-only ((stream stream)
297
298
		(entry `(,constructor :posn
				      (index-posn
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
				       (pretty-stream-buffer-fill-pointer
					,stream)
				       ,stream)
				      ,@args))
		(op `(list ,entry))
		(head `(pretty-stream-queue-head ,stream)))
      `(progn
	 (if ,head
	     (setf (cdr ,head) ,op)
	     (setf (pretty-stream-queue-tail ,stream) ,op))
	 (setf (pretty-stream-queue-head ,stream) ,op)
	 ,entry))))

(defstruct (section-start
	    (:include queued-op))
  (depth 0 :type index)
  (section-end nil :type (or null newline block-end)))

(defstruct (newline
	    (:include section-start))
  (kind (required-argument)
	:type (member :linear :fill :miser :literal :mandatory)))

(defun enqueue-newline (stream kind)
  (let* ((depth (length (pretty-stream-pending-blocks stream)))
	 (newline (enqueue stream newline :kind kind :depth depth)))
    (dolist (entry (pretty-stream-queue-tail stream))
      (when (and (not (eq newline entry))
		 (section-start-p entry)
		 (null (section-start-section-end entry))
		 (<= depth (section-start-depth entry)))
	(setf (section-start-section-end entry) newline))))
331
  (maybe-output stream (or (eq kind :literal) (eq kind :mandatory))))
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346

(defstruct (indentation
	    (:include queued-op))
  (kind (required-argument) :type (member :block :current))
  (amount 0 :type fixnum))

(defun enqueue-indent (stream kind amount)
  (enqueue stream indentation :kind kind :amount amount))

(defstruct (block-start
	    (:include section-start))
  (block-end nil :type (or null block-end))
  (prefix nil :type (or null simple-string))
  (suffix nil :type (or null simple-string)))

347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
(defun start-logical-block (stream prefix per-line-p suffix
			    &optional prefix-p per-line-prefix-p suffix-p)
  (declare (type (or null string) prefix suffix))

  ;; If a prefix (or per-line-prefix) is explicitly given, it must be
  ;; a string.
  (when (and (or prefix-p per-line-prefix-p) (not (stringp prefix)))
    (error 'type-error
	   :datum prefix
	   :expected-type 'string))
  ;; Likewise for a suffix
  (when (and suffix-p (not (stringp suffix)))
    (error 'type-error
	   :datum suffix
	   :expected-type 'string))

  (let ((p (if prefix (coerce prefix 'simple-string) prefix)))
    (when prefix
      (pretty-sout stream p 0 (length p)))
    (let* ((pending-blocks (pretty-stream-pending-blocks stream))
	   (start (enqueue stream block-start
			   :prefix (and per-line-p p)
			   :suffix (coerce suffix 'simple-string)
			   :depth (length pending-blocks))))
      (setf (pretty-stream-pending-blocks stream)
	    (cons start pending-blocks)))))
373
374
375
376
377
378
379
380
381
382
383
384
385

(defstruct (block-end
	    (:include queued-op))
  (suffix nil :type (or null simple-string)))

(defun end-logical-block (stream)
  (let* ((start (pop (pretty-stream-pending-blocks stream)))
	 (suffix (block-start-suffix start))
	 (end (enqueue stream block-end :suffix suffix)))
    (when suffix
      (pretty-sout stream suffix 0 (length suffix)))
    (setf (block-start-block-end start) end)))

386
387
388
389
390
391
392
(defstruct (tab
	    (:include queued-op))
  (sectionp nil :type (member t nil))
  (relativep nil :type (member t nil))
  (colnum 0 :type column)
  (colinc 0 :type column))

393
(defun enqueue-tab (stream kind colnum colinc)
394
395
396
397
398
399
400
401
402
  (multiple-value-bind
      (sectionp relativep)
      (ecase kind
	(:line (values nil nil))
	(:line-relative (values nil t))
	(:section (values t nil))
	(:section-relative (values t t)))
    (enqueue stream tab :sectionp sectionp :relativep relativep
	     :colnum colnum :colinc colinc)))
403

404
405
406
407
408
409
410
411

;;;; Tab support.

(defun compute-tab-size (tab section-start column)
  (let ((origin (if (tab-sectionp tab) section-start 0))
	(colnum (tab-colnum tab))
	(colinc (tab-colinc tab)))
    (cond ((tab-relativep tab)
rtoy's avatar
rtoy committed
412
413
414
415
416
	   (unless (<= colinc 1)
	     (let ((newposn (+ (- column origin) colnum)))
	       (let ((rem (rem newposn colinc)))
		 (unless (zerop rem)
		   (incf colnum (- colinc rem))))))
417
	   colnum)
418
	  ((< column (+ colnum origin))
419
420
	   (- (+ colnum origin) column))
	  (t
421
422
423
	   (if (zerop colinc)
	       0
	       (- colinc
424
		  (rem (- column origin colnum) colinc)))))))
425
426
427
428
429

(defun index-column (index stream)
  (let ((column (pretty-stream-buffer-start-column stream))
	(section-start (logical-block-section-column
			(first (pretty-stream-blocks stream))))
430
	(end-posn (index-posn index stream)))
431
    (dolist (op (pretty-stream-queue-tail stream))
432
      (when (>= (queued-op-posn op) end-posn)
433
434
435
436
437
438
439
	(return))
      (typecase op
	(tab
	 (incf column
	       (compute-tab-size op
				 section-start
				 (+ column
440
				    (posn-index (tab-posn op)
441
442
443
						    stream)))))
	((or newline block-start)
	 (setf section-start
444
	       (+ column (posn-index (queued-op-posn op)
445
446
447
448
449
450
451
452
453
454
455
456
					 stream))))))
    (+ column index)))

(defun expand-tabs (stream through)
  (let ((insertions nil)
	(additional 0)
	(column (pretty-stream-buffer-start-column stream))
	(section-start (logical-block-section-column
			(first (pretty-stream-blocks stream)))))
    (dolist (op (pretty-stream-queue-tail stream))
      (typecase op
	(tab
457
	 (let* ((index (posn-index (tab-posn op) stream))
458
459
460
461
462
463
464
465
466
		(tabsize (compute-tab-size op
					   section-start
					   (+ column index))))
	   (unless (zerop tabsize)
	     (push (cons index tabsize) insertions)
	     (incf additional tabsize)
	     (incf column tabsize))))
	((or newline block-start)
	 (setf section-start
467
	       (+ column (posn-index (queued-op-posn op) stream)))))
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
      (when (eq op through)
	(return)))
    (when insertions
      (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
	     (new-fill-ptr (+ fill-ptr additional))
	     (buffer (pretty-stream-buffer stream))
	     (new-buffer buffer)
	     (length (length buffer))
	     (end fill-ptr))
	(when (> new-fill-ptr length)
	  (let ((new-length (max (* length 2)
				 (+ fill-ptr
				    (floor (* additional 5) 4)))))
	    (setf new-buffer (make-string new-length))
	    (setf (pretty-stream-buffer stream) new-buffer)))
	(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
	(decf (pretty-stream-buffer-offset stream) additional)
	(dolist (insertion insertions)
	  (let* ((srcpos (car insertion))
		 (amount (cdr insertion))
		 (dstpos (+ srcpos additional)))
	    (replace new-buffer buffer :start1 dstpos :start2 srcpos :end2 end)
490
	    (fill new-buffer #\space :start (- dstpos amount) :end dstpos)
491
492
493
494
	    (decf additional amount)
	    (setf end srcpos)))
	(unless (eq new-buffer buffer)
	  (replace new-buffer buffer :end1 end :end2 end))))))
495

496
497
498
499
500
501
502
503

;;;; Annotations support.

(defstruct (annotation (:include queued-op))
  (handler (constantly nil) :type function)
  (record))

(defun enqueue-annotation (stream handler record)
504
  "Insert an annotation into the pretty-printing stream STREAM.
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
HANDLER is a function, and RECORD is an arbitrary datum.  The
pretty-printing stream conceptionally queues annotations in sequence
with the characters that are printed to the stream, until the stream
has decided on the concrete layout.  When the characters are forwarded
to the target stream, annotations are invoked at the right position.
An annotation is invoked by calling the function HANDLER with the
three arguments RECORD, TARGET-STREAM, and TRUNCATEP.  The argument
TRUNCATEP is true if the text surrounding the annotation is suppressed
due to line abbreviation (see *PRINT-LINES*).
If STREAM is not a pretty-printing stream, simply call HANDLER
with the arguments RECORD, STREAM and nil."
  (enqueue stream annotation :handler handler
	   :record record))

(defun re-enqueue-annotation (stream annotation)
520
  "Insert ANNOTATION into the queue of annotations in STREAM."
521
522
523
524
525
526
527
528
  (let* ((annotation-cons (list annotation))
	 (head (pretty-stream-annotations-head stream)))
    (if head
	(setf (cdr head) annotation-cons)
	(setf (pretty-stream-annotations-tail stream) annotation-cons))
    (setf (pretty-stream-annotations-head stream) annotation-cons)))

(defun re-enqueue-annotations (stream end)
529
  "Insert all annotations in STREAM from the queue of pending
530
531
operations into the queue of annotations.  When END is non-nil, 
stop before reaching the queued-op END."
532
  #-(and)
533
534
535
536
  (loop for tail = (pretty-stream-queue-tail stream) then (cdr tail)
     while (and tail (not (eql (car tail) end)))
     when (annotation-p (car tail)) 
     do (re-enqueue-annotation stream (car tail)))
537
  #+(and)
538
539
540
541
542
543
  (do ((tail (pretty-stream-queue-tail stream) (cdr tail)))
      ((not (and tail (not (eql (car tail) end)))))
    (when (annotation-p (car tail))
      (re-enqueue-annotation stream (car tail)))))

(defun dequeue-annotation (stream &key end-posn)
544
  "Dequeue the next annotation from the queue of annotations of STREAM
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
and return it.  Return nil if there are no more annotations.  When
:END-POSN is given and the next annotation has a posn greater than
this, also return nil."
  (let ((next-annotation (car (pretty-stream-annotations-tail stream))))
    (when next-annotation
      (when (or (not end-posn)
		(<= (annotation-posn next-annotation) end-posn))
	(pop (pretty-stream-annotations-tail stream))
	(unless (pretty-stream-annotations-tail stream)
	  (setf (pretty-stream-annotations-head stream) nil))
	next-annotation))))

(defun invoke-annotation (stream annotation truncatep)
  (let ((target (pretty-stream-target stream)))
    (funcall (annotation-handler annotation)
	     (annotation-record annotation)
	     target
	     truncatep)))

(defun output-buffer-with-annotations (stream end)
565
  "Output the buffer of STREAM up to (excluding) the buffer index END.
566
567
568
569
570
When annotations are present, invoke them at the right positions."
  (let ((target (pretty-stream-target stream))
	(buffer (pretty-stream-buffer stream))
	(end-posn (index-posn end stream))
	(start 0))
571
    #-(and)
572
573
574
575
576
577
578
579
580
581
    (loop
       for annotation = (dequeue-annotation stream :end-posn end-posn)
       while annotation
       do
	 (let ((annotation-index (posn-index (annotation-posn annotation)
					     stream)))
	   (write-string buffer target :start start 
			 :end annotation-index)
	   (invoke-annotation stream annotation nil)
	   (setf start annotation-index)))
582
    #+(and)
583
584
585
586
587
588
589
590
591
592
593
594
    (do ((annotation (dequeue-annotation stream :end-posn end-posn)
		     (dequeue-annotation stream :end-posn end-posn)))
	((not annotation))
      (let ((annotation-index (posn-index (annotation-posn annotation)
					     stream)))
	   (write-string buffer target :start start 
			 :end annotation-index)
	   (invoke-annotation stream annotation nil)
	   (setf start annotation-index)))
    (write-string buffer target :start start :end end)))

(defun flush-annotations (stream end truncatep)
595
  "Invoke all annotations in STREAM up to (including) the buffer index END."
596
  (let ((end-posn (index-posn end stream)))
597
    #-(and)
598
599
600
601
    (loop
       for annotation = (dequeue-annotation stream :end-posn end-posn)
       while annotation
       do (invoke-annotation stream annotation truncatep))
602
    #+(and)
603
604
605
606
607
608
    (do ((annotation (dequeue-annotation stream :end-posn end-posn)
		     (dequeue-annotation stream :end-posn end-posn)))
	((not annotation))
      (invoke-annotation stream annotation truncatep))
    ))

609
610
611
612
613
614
615
616
617
618
619
620
621

;;;; Stuff to do the actual outputting.

(defun assure-space-in-buffer (stream want)
  (declare (type pretty-stream stream)
	   (type index want))
  (let* ((buffer (pretty-stream-buffer stream))
	 (length (length buffer))
	 (fill-ptr (pretty-stream-buffer-fill-pointer stream))
	 (available (- length fill-ptr)))
    (cond ((plusp available)
	   available)
	  ((> fill-ptr (pretty-stream-line-length stream))
622
623
	   (unless (maybe-output stream nil)
	     (output-partial-line stream))
624
625
626
627
628
629
630
631
632
633
	   (assure-space-in-buffer stream want))
	  (t
	   (let* ((new-length (max (* length 2)
				   (+ length
				      (floor (* want 5) 4))))
		  (new-buffer (make-string new-length)))
	     (setf (pretty-stream-buffer stream) new-buffer)
	     (replace new-buffer buffer :end1 fill-ptr)
	     (- new-length fill-ptr))))))

634
(defun maybe-output (stream force-newlines-p)
635
  (declare (type pretty-stream stream))
636
637
  (let ((tail (pretty-stream-queue-tail stream))
	(output-anything nil))
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
    (loop
      (unless tail
	(setf (pretty-stream-queue-head stream) nil)
	(return))
      (let ((next (pop tail)))
	(etypecase next
	  (newline
	   (when (ecase (newline-kind next)
		   ((:literal :mandatory :linear) t)
		   (:miser (misering-p stream))
		   (:fill
		    (or (misering-p stream)
			(> (pretty-stream-line-number stream)
			   (logical-block-section-start-line
			    (first (pretty-stream-blocks stream))))
			(ecase (fits-on-line-p stream
					       (newline-section-end next)
					       force-newlines-p)
			  ((t) nil)
			  ((nil) t)
			  (:dont-know
			   (return))))))
660
	     (setf output-anything t)
661
662
663
664
665
666
667
668
669
	     (output-line stream next)))
	  (indentation
	   (unless (misering-p stream)
	     (set-indentation stream
			      (+ (ecase (indentation-kind next)
				   (:block
				    (logical-block-start-column
				     (car (pretty-stream-blocks stream))))
				   (:current
670
671
				    (posn-column
				     (indentation-posn next)
672
673
674
675
676
677
678
				     stream)))
				 (indentation-amount next)))))
	  (block-start
	   (ecase (fits-on-line-p stream (block-start-section-end next)
				  force-newlines-p)
	     ((t)
	      ;; Just nuke the whole logical block and make it look like one
679
	      ;; nice long literal.  (But don't nuke annotations.)
680
681
	      (let ((end (block-start-block-end next)))
		(expand-tabs stream end)
682
		(re-enqueue-annotations stream end)
683
		(setf tail (cdr (member end tail)))))
684
685
686
	     ((nil)
	      (really-start-logical-block
	       stream
687
	       (posn-column (block-start-posn next) stream)
688
689
690
691
692
	       (block-start-prefix next)
	       (block-start-suffix next)))
	     (:dont-know
	      (return))))
	  (block-end
693
694
	   (really-end-logical-block stream))
	  (tab
695
696
697
	   (expand-tabs stream next))
	  (annotation
	   (re-enqueue-annotation stream next))))
698
699
      (setf (pretty-stream-queue-tail stream) tail))
    output-anything))
700
701
702
703
704
705
706
707
708
709

(defun misering-p (stream)
  (declare (type pretty-stream stream))
  (and *print-miser-width*
       (<= (- (pretty-stream-line-length stream)
	      (logical-block-start-column (car (pretty-stream-blocks stream))))
	   *print-miser-width*)))

(defun fits-on-line-p (stream until force-newlines-p)
  (let ((available (pretty-stream-line-length stream)))
710
    (when (and (not *print-readably*) *print-lines*
711
712
713
714
715
	       (= *print-lines* (pretty-stream-line-number stream)))
      (decf available 3) ; for the `` ..''
      (decf available (logical-block-suffix-length
		       (car (pretty-stream-blocks stream)))))
    (cond (until
716
	   (<= (posn-column (queued-op-posn until) stream) available))
717
718
719
720
721
722
723
724
725
726
727
728
729
730
	  (force-newlines-p nil)
	  ((> (index-column (pretty-stream-buffer-fill-pointer stream) stream)
	      available)
	   nil)
	  (t
	   :dont-know))))

(defun output-line (stream until)
  (declare (type pretty-stream stream)
	   (type newline until))
  (let* ((target (pretty-stream-target stream))
	 (buffer (pretty-stream-buffer stream))
	 (kind (newline-kind until))
	 (literal-p (eq kind :literal))
731
	 (amount-to-consume (posn-index (newline-posn until) stream))
732
733
734
735
736
737
738
739
740
	 (amount-to-print
	  (if literal-p
	      amount-to-consume
	      (let ((last-non-blank
		     (position #\space buffer :end amount-to-consume
			       :from-end t :test #'char/=)))
		(if last-non-blank
		    (1+ last-non-blank)
		    0)))))
741
742
    (output-buffer-with-annotations stream amount-to-print)
    (flush-annotations stream amount-to-consume nil)
743
    (let ((line-number (pretty-stream-line-number stream)))
744
      (incf line-number)
745
746
      (when (and (not *print-readably*)
		 *print-lines* (>= line-number *print-lines*))
747
	(write-string " .." target)
748
749
750
	(flush-annotations stream 
			   (pretty-stream-buffer-fill-pointer stream)
			   t)
751
752
753
754
755
756
757
758
759
760
761
762
763
	(let ((suffix-length (logical-block-suffix-length
			      (car (pretty-stream-blocks stream)))))
	  (unless (zerop suffix-length)
	    (let* ((suffix (pretty-stream-suffix stream))
		   (len (length suffix)))
	      (write-string suffix target
			    :start (- len suffix-length)
			    :end len))))
	(throw 'line-limit-abbreviation-happened t))
      (setf (pretty-stream-line-number stream) line-number)
      (write-char #\newline target)
      (setf (pretty-stream-buffer-start-column stream) 0)
      (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
764
	     (block (first (pretty-stream-blocks stream)))
765
766
767
768
	     (prefix-len
	      (if literal-p
		  (logical-block-per-line-prefix-end block)
		  (logical-block-prefix-length block)))
769
770
771
772
773
774
775
776
777
778
779
780
781
	     (shift (- amount-to-consume prefix-len))
	     (new-fill-ptr (- fill-ptr shift))
	     (new-buffer buffer)
	     (buffer-length (length buffer)))
	(when (> new-fill-ptr buffer-length)
	  (setf new-buffer
		(make-string (max (* buffer-length 2)
				  (+ buffer-length
				     (floor (* (- new-fill-ptr buffer-length)
					       5)
					    4)))))
	  (setf (pretty-stream-buffer stream) new-buffer))
	(replace new-buffer buffer
782
		 :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
783
	(replace new-buffer (pretty-stream-prefix stream)
784
		 :end1 prefix-len)
785
	(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
786
787
788
789
	(incf (pretty-stream-buffer-offset stream) shift)
	(unless literal-p
	  (setf (logical-block-section-column block) prefix-len)
	  (setf (logical-block-section-start-line block) line-number))))))
790
791
792

(defun output-partial-line (stream)
  (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
793
794
795
	 (tail (pretty-stream-queue-tail stream))
	 (count
	  (if tail
796
	      (posn-index (queued-op-posn (car tail)) stream)
797
	      fill-ptr))
798
799
	 (new-fill-ptr (- fill-ptr count))
	 (buffer (pretty-stream-buffer stream)))
800
    (when (zerop count)
801
      (error (intl:gettext "Output-partial-line called when nothing can be output.")))
802
    (output-buffer-with-annotations stream count)
803
804
805
806
807
808
    (incf (pretty-stream-buffer-start-column stream) count)
    (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr)
    (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
    (incf (pretty-stream-buffer-offset stream) count)))

(defun force-pretty-output (stream)
809
  (maybe-output stream nil)
810
  (expand-tabs stream nil)
811
812
813
  (re-enqueue-annotations stream nil)
  (output-buffer-with-annotations stream 
				  (pretty-stream-buffer-fill-pointer stream)))
814
815
816
817


;;;; Utilities.

818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
;;; WITH-PRETTY-STREAM -- internal.
;;;
(defmacro with-pretty-stream
	  ((stream-var &optional (stream-expression stream-var)) &body body)
  (let ((flet-name (gensym "WITH-PRETTY-STREAM-")))
    `(flet ((,flet-name (,stream-var)
	      ,@body))
       (let ((stream ,stream-expression))
	 (if (pretty-stream-p stream)
	     (,flet-name stream)
	     (catch 'line-limit-abbreviation-happened
	       (let ((stream (make-pretty-stream stream)))
		 (,flet-name stream)
		 (force-pretty-output stream)))))
       nil)))
ram's avatar
ram committed
833

834
835

;;;; User interface to the pretty printer.
ram's avatar
ram committed
836

837
(defmacro pprint-logical-block
838
	  ((stream-symbol object &key (prefix "" prefix-p) (per-line-prefix nil per-line-p) (suffix "" suffix-p))
839
	   &body body)
840
  "Group some output into a logical block.  STREAM-SYMBOL should be either a
841
   stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*).  The printer
842
   control variable *PRINT-LEVEL* is automatically handled."
843
  (when (and prefix-p per-line-prefix)
844
    (error (intl:gettext "Cannot specify both a prefix and a per-line-prefix.")))
845
846
847
848
849
850
851
852
853
854
855
856
857
858
  (multiple-value-bind
      (stream-var stream-expression)
      (case stream-symbol
	((nil)
	 (values '*standard-output* '*standard-output*))
	((t)
	 (values '*terminal-io* '*terminal-io*))
	(t
	 (values stream-symbol
		 (once-only ((stream stream-symbol))
		   `(case ,stream
		      ((nil) *standard-output*)
		      ((t) *terminal-io*)
		      (t ,stream))))))
859
860
861
862
863
864
865
866
    (let* ((object-var (if object (gensym) nil))
	   (block-name (gensym "PPRINT-LOGICAL-BLOCK-"))
	   (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
	   (pp-pop-name (gensym "PPRINT-POP-"))
	   (body
	    `(descend-into (,stream-var)
	       (let ((,count-name 0))
		 (declare (type index ,count-name) (ignorable ,count-name))
867
868
869
		 (start-logical-block ,stream-var ,(if prefix-p prefix per-line-prefix)
				      ,(if per-line-prefix t nil) ,suffix
				      ,prefix-p ,per-line-p ,suffix-p)
870
871
872
873
874
875
876
		 (block ,block-name
		   (flet ((,pp-pop-name ()
			    ,@(when object
				`((unless (listp ,object-var)
				    (write-string ". " ,stream-var)
				    (output-object ,object-var ,stream-var)
				    (return-from ,block-name nil))))
877
878
			    (when (and (not *print-readably*)
				       (eql ,count-name *print-length*))
879
880
881
882
883
884
			      (write-string "..." ,stream-var)
			      (return-from ,block-name nil))
			    ,@(when object
				`((when (and ,object-var
					     (plusp ,count-name)
					     (check-for-circularity
885
886
887
					      ,object-var
					      nil
					      :logical-block))
888
889
890
891
				    (write-string ". " ,stream-var)
				    (output-object ,object-var ,stream-var)
				    (return-from ,block-name nil))))
			    (incf ,count-name)
892
893
894
			    ,@(if object
				  `((pop ,object-var))
				  `(nil))))
895
		     (declare (ignorable #',pp-pop-name))
896
897
898
899
900
901
902
903
904
905
906
		     (unwind-protect
			  (macrolet ((pprint-pop ()
				       '(,pp-pop-name))
				     (pprint-exit-if-list-exhausted ()
				       ,(if object
					    `'(when (null ,object-var)
					       (return-from ,block-name nil))
					    `'(return-from ,block-name nil))))
			    ,@body)
		       (end-logical-block ,stream-var))))
		 ))))
907
908
909
910
      (when object
	(setf body
	      `(let ((,object-var ,object))
		 (if (listp ,object-var)
911
912
		     (with-circularity-detection (,object-var ,stream-var)
		       ,body)
913
914
915
		     (output-object ,object-var ,stream-var)))))
      `(with-pretty-stream (,stream-var ,stream-expression)
	 ,body))))
ram's avatar
ram committed
916

917
(defmacro pprint-exit-if-list-exhausted ()
918
  "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
919
920
921
   if it's list argument is exhausted.  Can only be used inside
   PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
   PPRINT-LOGICAL-BLOCK is supplied."
922
923
  (error (intl:gettext "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
	  PPRINT-LOGICAL-BLOCK.")))
ram's avatar
ram committed
924

925
(defmacro pprint-pop ()
926
  "Return the next element from LIST argument to the closest enclosing
927
928
929
930
   use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
   and *PRINT-CIRCLE*.  Can only be used inside PPRINT-LOGICAL-BLOCK.
   If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
   is poped, but the *PRINT-LENGTH* testing still happens."
931
  (error (intl:gettext "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK.")))
932
933
  
(defun pprint-newline (kind &optional stream)
934
  "Output a conditional newline to STREAM (which defaults to
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
   *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do
   nothing if not.  KIND can be one of:
     :LINEAR - A line break is inserted if and only if the immediatly
        containing section cannot be printed on one line.
     :MISER - Same as LINEAR, but only if ``miser-style'' is in effect.
        (See *PRINT-MISER-WIDTH*.)
     :FILL - A line break is inserted if and only if either:
       (a) the following section cannot be printed on the end of the
           current line,
       (b) the preceding section was not printed on a single line, or
       (c) the immediately containing section cannot be printed on one
           line and miser-style is in effect.
     :MANDATORY - A line break is always inserted.
   When a line break is inserted by any type of conditional newline, any
   blanks that immediately precede the conditional newline are ommitted
   from the output and indentation is introduced at the beginning of the
   next line.  (See PPRINT-INDENT.)"
  (declare (type (member :linear :miser :fill :mandatory) kind)
	   (type (or stream (member t nil)) stream)
	   (values null))
  (let ((stream (case stream
		  ((t) *terminal-io*)
		  ((nil) *standard-output*)
		  (t stream))))
959
    (when (and (pretty-stream-p stream) *print-pretty*)
960
961
962
963
      (enqueue-newline stream kind)))
  nil)

(defun pprint-indent (relative-to n &optional stream)
964
  "Specify the indentation to use in the current logical block if STREAM
965
   (which defaults to *STANDARD-OUTPUT*) is a pretty-printing stream
966
967
968
969
970
971
   and do nothing if not.  (See PPRINT-LOGICAL-BLOCK.)  N is the indention
   to use (in ems, the width of an ``m'') and RELATIVE-TO can be either:
     :BLOCK - Indent relative to the column the current logical block
        started on.
     :CURRENT - Indent relative to the current column.
   The new indention value does not take effect until the following line
972
   break.  The indention value is silently truncated to an integer."
973
  (declare (type (member :block :current) relative-to)
974
	   (type real n)
975
976
977
978
979
980
	   (type (or stream (member t nil)) stream)
	   (values null))
  (let ((stream (case stream
		  ((t) *terminal-io*)
		  ((nil) *standard-output*)
		  (t stream))))
981
    (when (and (pretty-stream-p stream) *print-pretty*)
982
983
984
      ;; CMUCL doesn't really support non-fixed-width characters, so
      ;; we silently truncate the indentation to an integer.
      (enqueue-indent stream relative-to (truncate n))))
985
986
987
  nil)

(defun pprint-tab (kind colnum colinc &optional stream)
988
  "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
   stream, perform tabbing based on KIND, otherwise do nothing.  KIND can
   be one of:
     :LINE - Tab to column COLNUM.  If already past COLNUM tab to the next
       multiple of COLINC.
     :SECTION - Same as :LINE, but count from the start of the current
       section, not the start of the line.
     :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of
       COLINC.
     :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start
       of the current section, not the start of the line."
  (declare (type (member :line :section :line-relative :section-relative) kind)
	   (type unsigned-byte colnum colinc)
	   (type (or stream (member t nil)) stream)
	   (values null))
  (let ((stream (case stream
		  ((t) *terminal-io*)
		  ((nil) *standard-output*)
		  (t stream))))
1007
    (when (and (pretty-stream-p stream) *print-pretty*)
1008
1009
1010
1011
      (enqueue-tab stream kind colnum colinc)))
  nil)

(defun pprint-fill (stream list &optional (colon? t) atsign?)
1012
  "Output LIST to STREAM putting :FILL conditional newlines between each
1013
1014
1015
1016
1017
   element.  If COLON? is NIL (defaults to T), then no parens are printed
   around the output.  ATSIGN? is ignored (but allowed so that PPRINT-FILL
   can be used with the ~/.../ format directive."
  (declare (ignore atsign?))
  (pprint-logical-block (stream list
1018
1019
				:prefix (if colon? "(" "")
				:suffix (if colon? ")" ""))
1020
1021
1022
1023
1024
1025
1026
1027
    (pprint-exit-if-list-exhausted)
    (loop
      (output-object (pprint-pop) stream)
      (pprint-exit-if-list-exhausted)
      (write-char #\space stream)
      (pprint-newline :fill stream))))

(defun pprint-linear (stream list &optional (colon? t) atsign?)
1028
  "Output LIST to STREAM putting :LINEAR conditional newlines between each
1029
1030
1031
1032
1033
   element.  If COLON? is NIL (defaults to T), then no parens are printed
   around the output.  ATSIGN? is ignored (but allowed so that PPRINT-LINEAR
   can be used with the ~/.../ format directive."
  (declare (ignore atsign?))
  (pprint-logical-block (stream list
1034
1035
				:prefix (if colon? "(" "")
				:suffix (if colon? ")" ""))
1036
1037
1038
1039
1040
1041
1042
1043
    (pprint-exit-if-list-exhausted)
    (loop
      (output-object (pprint-pop) stream)
      (pprint-exit-if-list-exhausted)
      (write-char #\space stream)
      (pprint-newline :linear stream))))

(defun pprint-tabular (stream list &optional (colon? t) atsign? tabsize)
1044
  "Output LIST to STREAM tabbing to the next column that is an even multiple
1045
1046
1047
1048
1049
1050
   of TABSIZE (which defaults to 16) between each element.  :FILL style
   conditional newlines are also output between each element.  If COLON? is
   NIL (defaults to T), then no parens are printed around the output.
   ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with
   the ~/.../ format directive."
  (declare (ignore atsign?))
rtoy's avatar
rtoy committed
1051
  (pprint-logical-block (stream list
1052
1053
				:prefix (if colon? "(" "")
				:suffix (if colon? ")" ""))
rtoy's avatar
rtoy committed
1054
1055
1056
1057
    (pprint-exit-if-list-exhausted)
    (loop
       (output-object (pprint-pop) stream)
       (pprint-exit-if-list-exhausted)
1058
       (write-char #\space stream)
rtoy's avatar
rtoy committed
1059
1060
       (pprint-tab :section-relative 0 (or tabsize 16) stream)
       (pprint-newline :fill stream))))
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087


;;;; Pprint-dispatch tables.

(defvar *initial-pprint-dispatch*)
(defvar *building-initial-table* nil)

(defstruct (pprint-dispatch-entry
	    (:print-function %print-pprint-dispatch-entry))
  ;;
  ;; The type specifier for this entry.
  (type (required-argument) :type t)
  ;;
  ;; A function to test to see if an object is of this time.  Pretty must
  ;; just (lambda (obj) (typep object type)) except that we handle the
  ;; CONS type specially so that (cons (member foo)) works.  We don't
  ;; bother computing this for entries in the CONS hash table, because
  ;; we don't need it.
  (test-fn nil :type (or function null))
  ;;
  ;; The priority for this guy.
  (priority 0 :type real)
  ;;
  ;; T iff one of the original entries.
  (initial-p *building-initial-table* :type (member t nil))
  ;;
  ;; And the associated function.
1088
  (function (required-argument) :type (or symbol function)))
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138

(defun %print-pprint-dispatch-entry (entry stream depth)
  (declare (ignore depth))
  (print-unreadable-object (entry stream :type t)
    (format stream "Type=~S, priority=~S~@[ [Initial]~]"
	    (pprint-dispatch-entry-type entry)
	    (pprint-dispatch-entry-priority entry)
	    (pprint-dispatch-entry-initial-p entry))))

(defstruct (pprint-dispatch-table
	    (:print-function %print-pprint-dispatch-table))
  ;;
  ;; A list of all the entries (except for CONS entries below) in highest
  ;; to lowest priority.
  (entries nil :type list)
  ;;
  ;; A hash table mapping things to entries for type specifiers of the
  ;; form (CONS (MEMBER <thing>)).  If the type specifier is of this form,
  ;; we put it in this hash table instead of the regular entries table.
  (cons-entries (make-hash-table :test #'eql)))

(defun %print-pprint-dispatch-table (table stream depth)
  (declare (ignore depth))
  (print-unreadable-object (table stream :type t :identity t)))

(defun cons-type-specifier-p (spec)
  (and (consp spec)
       (eq (car spec) 'cons)
       (cdr spec)
       (null (cddr spec))
       (let ((car (cadr spec)))
	 (and (consp car)
	      (let ((carcar (car car)))
		(or (eq carcar 'member)
		    (eq carcar 'eql)))
	      (cdr car)
	      (null (cddr car))))))

(defun entry< (e1 e2)
  (declare (type pprint-dispatch-entry e1 e2))
  (if (pprint-dispatch-entry-initial-p e1)
      (if (pprint-dispatch-entry-initial-p e2)
	  (< (pprint-dispatch-entry-priority e1)
	     (pprint-dispatch-entry-priority e2))
	  t)
      (if (pprint-dispatch-entry-initial-p e2)
	  nil
	  (< (pprint-dispatch-entry-priority e1)
	     (pprint-dispatch-entry-priority e2)))))

1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149

(macrolet ((frob (x)
	     `(cons ',x #'(lambda (object) ,x))))
  (defvar *precompiled-pprint-dispatch-funs*
    (list (frob (typep object 'array))
	  (frob (and (consp object)
		     (and (typep (car object) 'symbol)
			  (typep (car object) '(satisfies fboundp)))))
	  (frob (typep object 'cons)))))


1150
(defun compute-test-fn (type)
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
  (let ((was-cons nil))
    (labels ((compute-test-expr (type object)
	       (if (listp type)
		   (case (car type)
		     (cons
		      (setq was-cons t)
		      (destructuring-bind
			  (&optional (car nil car-p) (cdr nil cdr-p))
			  (cdr type)
			`(and (consp ,object)
			      ,@(when car-p
				  `(,(compute-test-expr
				      car `(car ,object))))
			      ,@(when cdr-p
				  `(,(compute-test-expr
				      cdr `(cdr ,object)))))))
		     (not
		      (destructuring-bind (type) (cdr type)
			`(not ,(compute-test-expr type object))))
		     (and
		      `(and ,@(mapcar #'(lambda (type)
					  (compute-test-expr type object))
				      (cdr type))))
		     (or
		      `(or ,@(mapcar #'(lambda (type)
					 (compute-test-expr type object))
				     (cdr type))))
		     (t
		      `(typep ,object ',type)))
		   `(typep ,object ',type))))
      (let ((expr (compute-test-expr type 'object)))
	(cond ((cdr (assoc expr *precompiled-pprint-dispatch-funs*
			   :test #'equal)))
	      ((fboundp 'compile)
	       (compile nil `(lambda (object) ,expr)))
	      (was-cons
1187
	       (warn (intl:gettext "CONS PPRINT dispatch ignored w/o compiler loaded:~%  ~S")
1188
1189
1190
1191
1192
1193
		     type)
	       #'(lambda (object) (declare (ignore object)) nil))
	      (t
	       (let ((ttype (kernel:specifier-type type)))
		 #'(lambda (object) (kernel:%typep object ttype)))))))))

1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227

(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
  (declare (type (or pprint-dispatch-table null) table))
  (let* ((orig (or table *initial-pprint-dispatch*))
	 (new (make-pprint-dispatch-table
	       :entries (copy-list (pprint-dispatch-table-entries orig))))
	 (new-cons-entries (pprint-dispatch-table-cons-entries new)))
    (maphash #'(lambda (key value)
		 (setf (gethash key new-cons-entries) value))
	     (pprint-dispatch-table-cons-entries orig))
    new))

(defun pprint-dispatch (object &optional (table *print-pprint-dispatch*))
  (declare (type (or pprint-dispatch-table null) table))
  (let* ((table (or table *initial-pprint-dispatch*))
	 (cons-entry
	  (and (consp object)
	       (gethash (car object)
			(pprint-dispatch-table-cons-entries table))))
	 (entry
	  (dolist (entry (pprint-dispatch-table-entries table) cons-entry)
	    (when (and cons-entry
		       (entry< entry cons-entry))
	      (return cons-entry))
	    (when (funcall (pprint-dispatch-entry-test-fn entry) object)
	      (return entry)))))
    (if entry
	(values (pprint-dispatch-entry-function entry) t)
	(values #'(lambda (stream object)
		    (output-ugly-object object stream))
		nil))))

(defun set-pprint-dispatch (type function &optional
			    (priority 0) (table *print-pprint-dispatch*))
1228
  (declare (type (or null symbol function) function)
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
	   (type real priority)
	   (type pprint-dispatch-table table))
  (if function
      (if (cons-type-specifier-p type)
	  (setf (gethash (second (second type))
			 (pprint-dispatch-table-cons-entries table))
		(make-pprint-dispatch-entry :type type :priority priority
					    :function function))
	  (let ((list (delete type (pprint-dispatch-table-entries table)
			      :key #'pprint-dispatch-entry-type
			      :test #'equal))
		(entry (make-pprint-dispatch-entry
			:type type :test-fn (compute-test-fn type)
			:priority priority :function function)))
	    (do ((prev nil next)
		 (next list (cdr next)))
		((null next)
		 (if prev
		     (setf (cdr prev) (list entry))
		     (setf list (list entry))))
	      (when (entry< (car next) entry)
		(if prev
		    (setf (cdr prev) (cons entry next))
		    (setf list (cons entry next)))
		(return)))
	    (setf (pprint-dispatch-table-entries table) list)))
      (if (cons-type-specifier-p type)
	  (remhash (second (second type))
		   (pprint-dispatch-table-cons-entries table))
	  (setf (pprint-dispatch-table-entries table)
		(delete type (pprint-dispatch-table-entries table)
			:key #'pprint-dispatch-entry-type
			:test #'equal))))
  nil)


1265
1266
1267
1268
1269
1270
1271
1272
1273
(defun array-readably-printable-p (array)
  (and (eq (array-element-type array) t)
       (let ((zero (position 0 (array-dimensions array)))
             (number (position 0 (array-dimensions array)
                               :test (complement #'eql)
                               :from-end t)))
         (or (null zero) (null number) (> zero number)))))


1274
1275
1276
1277
1278
1279
1280
;;;; Standard pretty-printing routines.

(defun pprint-array (stream array)
  (cond ((or (and (null *print-array*) (null *print-readably*))
	     (stringp array)
	     (bit-vector-p array))
	 (output-ugly-object array stream))
1281
1282
	((and *print-readably*
	      (not (lisp::array-readably-printable-p array)))
1283
	 (pprint-raw-array stream array))
1284
1285
1286
1287
1288
1289
	((vectorp array)
	 (pprint-vector stream array))
	(t
	 (pprint-multi-dim-array stream array))))

(defun pprint-vector (stream vector)
1290
  (pprint-logical-block (stream nil :prefix "#(" :suffix ")")
1291
1292
1293
1294
    (dotimes (i (length vector))
      (unless (zerop i)
	(write-char #\space stream)
	(pprint-newline :fill stream))
1295
      (pprint-pop)
1296
      (output-object (aref vector i) stream))))
1297

1298
(defun pprint-array-contents (stream array)
1299
1300
1301
1302
1303
1304
  (lisp::with-array-data ((data array) (start) (end))
    (declare (ignore end))
    (labels ((output-guts (stream index dimensions)
	       (if (null dimensions)
		   (output-object (aref data index) stream)
		   (pprint-logical-block
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
		    (stream nil :prefix "(" :suffix ")")
		    (let ((dim (car dimensions)))
		      (unless (zerop dim)
			(let* ((dims (cdr dimensions))
			       (index index)
			       (step (reduce #'* dims))
			       (count 0))
			  (loop				
			   (pprint-pop)
			   (output-guts stream index dims)
			   (when (= (incf count) dim)
			     (return))
			   (write-char #\space stream)
			   (pprint-newline (if dims :linear :fill)
					   stream)
			   (incf index step)))))))))
1321
      (output-guts stream start (array-dimensions array)))))
1322

1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
(defun pprint-multi-dim-array (stream array)
  (funcall (formatter "#~DA") stream (array-rank array))
  (pprint-array-contents stream array))

(defun pprint-raw-array (stream array)
  (write-string "#A" stream)
  (pprint-logical-block (stream nil :prefix "(" :suffix ")")
    (output-object (array-element-type array) stream)
    (write-char #\Space stream)
    (pprint-newline :fill stream)
    (output-object (array-dimensions array) stream)
    (write-char #\Space stream)
    (pprint-newline :fill stream)
    (pprint-array-contents stream array)))

1338
1339
(defun pprint-lambda-list (stream lambda-list &rest noise)
  (declare (ignore noise))
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
  (when (and (consp lambda-list)
	     (member (car lambda-list) lisp::*bq-tokens*))
    ;; if this thing looks like a backquoty thing, then we don't want
    ;; to destructure it, we want to output it straight away.  [ this
    ;; is the exception to the normal processing: if we did this
    ;; generally we would find lambda lists such as (FUNCTION FOO)
    ;; being printed as #'FOO ]  -- CSR, 2003-12-07
    (output-object lambda-list stream)
    (return-from pprint-lambda-list nil))

1350
1351
1352
1353
1354
  (pprint-logical-block (stream lambda-list :prefix "(" :suffix ")")
    (let ((state :required)
	  (first t))
      (loop
	(pprint-exit-if-list-exhausted)
1355
1356
	(unless first
	  (write-char #\space stream))
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
	(let ((arg (pprint-pop)))
	  (unless first
	    (case arg
	      (&optional
	       (setf state :optional)
	       (pprint-newline :linear stream))
	      ((&rest &body)
	       (setf state :required)
	       (pprint-newline :linear stream))
	      (&key
	       (setf state :key)
	       (pprint-newline :linear stream))
	      (&aux
	       (setf state :optional)
	       (pprint-newline :linear stream))
	      (t
	       (pprint-newline :fill stream))))
	  (ecase state
	    (:required
	     (pprint-lambda-list stream arg))
	    ((:optional :key)
	     (pprint-logical-block
		 (stream arg :prefix "(" :suffix ")")
	       (pprint-exit-if-list-exhausted)
	       (if (eq state :key)
		   (pprint-logical-block
		       (stream (pprint-pop) :prefix "(" :suffix ")")
		     (pprint-exit-if-list-exhausted)
		     (output-object (pprint-pop) stream)
		     (pprint-exit-if-list-exhausted)
		     (write-char #\space stream)
		     (pprint-newline :fill stream)
		     (pprint-lambda-list stream (pprint-pop))
		     (loop
		       (pprint-exit-if-list-exhausted)
		       (write-char #\space stream)
		       (pprint-newline :fill stream)
		       (output-object (pprint-pop) stream)))
		   (pprint-lambda-list stream (pprint-pop)))
	       (loop
		 (pprint-exit-if-list-exhausted)
		 (write-char #\space stream)
		 (pprint-newline :linear stream)
		 (output-object (pprint-pop) stream))))))
	(setf first nil)))))

(defun pprint-lambda (stream list &rest noise)
  (declare (ignore noise))
  (funcall (formatter
	    "~:<~^~W~^~3I ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
	   stream list))

(defun pprint-block (stream list &rest noise)
  (declare (ignore noise))
  (funcall (formatter "~:<~^~W~^~3I ~:_~W~1I~@{ ~_~W~}~:>") stream list))

(defun pprint-flet (stream list &rest noise)
  (declare (ignore noise))
1415
1416
1417
1418
1419
1420
1421
1422
1423
  ;; If the second element of the list is not a list, then we don't
  ;; really have a flet/labels form, so let's just print it as a
  ;; list. (This happens when the list is the name an flet/labels in a
  ;; function.
  (if (listp (second list))
      (funcall (formatter
		"~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
	       stream
	       list)
1424
      (funcall (formatter "~@:<~{~W~^ ~:_~}~:>")
1425
	       stream list)))
1426
1427
1428

(defun pprint-let (stream list &rest noise)
  (declare (ignore noise))
1429
  (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>")
1430
1431
1432
1433
1434
	   stream
	   list))

(defun pprint-progn (stream list &rest noise)
  (declare (ignore noise))
1435
1436
1437
1438
  #+nil
  (funcall (formatter "~:<~^~W~@{ ~_~W~}~:>") stream list)
  (funcall (formatter "~:<~^~W~1I~@{ ~@:_~W~}~:>") stream list)
  )
1439
1440
1441
1442
1443
1444

(defun pprint-progv (stream list &rest noise)
  (declare (ignore noise))
  (funcall (formatter "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>")
	   stream list))

1445
1446
(defun pprint-multiple-value-bind (stream list &rest noise)
  (declare (ignore noise))
1447
  (funcall (formatter "~:<~^~W~^~5I ~:_~W~^~3I ~:@_~W~1I~@{ ~:@_~W~}~:>")
1448
1449
1450
1451
1452
1453
1454
	   stream list))

(defun pprint-handler-bind (stream list &rest noise)
  (declare (ignore noise))
  (funcall (formatter "~:<~^~W~3I ~:_~W~1I~@{ ~:@_~W~}~:>")
	   stream list))
  
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
(defun pprint-quote (stream list &rest noise)
  (declare (ignore noise))
  (if (and (consp list)
	   (consp (cdr list))
	   (null (cddr list)))
      (case (car list)
	(function
	 (write-string "#'" stream)
	 (output-object (cadr list) stream))
	(quote
	 (write-char #\' stream)
	 (output-object (cadr list) stream))
	(t
	 (pprint-fill stream list)))
      (pprint-fill stream list)))

(defun pprint-setq (stream list &rest noise)
  (declare (ignore noise))
  (pprint-logical-block (stream list :prefix "(" :suffix ")")
    (pprint-exit-if-list-exhausted)
    (output-object (pprint-pop) stream)
    (pprint-exit-if-list-exhausted)
    (write-char #\space stream)
    (pprint-newline :miser stream)
1479
    (if (and (consp (cdr list)) (consp (cddr list)))
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
	(loop
	  (pprint-indent :current 2 stream)
	  (output-object (pprint-pop) stream)
	  (pprint-exit-if-list-exhausted)
	  (write-char #\space stream)
	  (pprint-newline :linear stream)
	  (pprint-indent :current -2 stream)
	  (output-object (pprint-pop) stream)
	  (pprint-exit-if-list-exhausted)
	  (write-char #\space stream)
	  (pprint-newline :linear stream))
	(progn
	  (pprint-indent :current 0 stream)
	  (output-object (pprint-pop) stream)
	  (pprint-exit-if-list-exhausted)
	  (write-char #\space stream)
	  (pprint-newline :linear stream)
	  (output-object (pprint-pop) stream)))))
	  
(defmacro pprint-tagbody-guts (stream)
  `(loop
     (pprint-exit-if-list-exhausted)
     (write-char #\space ,stream)
     (let ((form-or-tag (pprint-pop)))
       (pprint-indent :block 
		      (if (atom form-or-tag) 0 1)
		      ,stream)
       (pprint-newline :linear ,stream)
       (output-object form-or-tag ,stream))))

(defun pprint-tagbody (stream list &rest noise)
  (declare (ignore noise))
  (pprint-logical-block (stream list :prefix "(" :suffix ")")
    (pprint-exit-if-list-exhausted)
    (output-object (pprint-pop) stream)
    (pprint-tagbody-guts stream)))

(defun pprint-case (stream list &rest noise)
  (declare (ignore noise))
  (funcall (formatter
	    "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/PP:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>")
	   stream
	   list))

1524
1525
1526
1527
1528
(defun pprint-cond (stream list &rest noise)
  (declare (ignore noise))
  (funcall (formatter "~:<~W~^~1I~:@_~@{~:<~^~W~^~:@_~@{~W~^~:@_~}~:>~^~:@_~}~:>")
	   stream list))

1529
1530
(defun pprint-declare (stream list &rest noise)
  (declare (ignore noise))
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
  (pprint-logical-block (stream list :prefix "(" :suffix ")")
    ;; Output "declare"
    (output-object (pprint-pop) stream)
    (pprint-exit-if-list-exhausted)
    (pprint-newline :miser stream)
    (write-char #\space stream)
    (pprint-indent :current 0 stream)
    ;; Print out each spec.
    (loop
       (let ((spec (pprint-pop)))
	 ;; If the spec begins with TYPE, we indent it so that vars
	 ;; are lined up after the actual type.  Otherwise, we just
	 ;; make them all line up after the first symbol of the
	 ;; spec.
	 (pprint-logical-block (stream spec :prefix "(" :suffix ")")
	   (when (eq (car spec) 'type)
	     (output-object (pprint-pop) stream)
	     (pprint-exit-if-list-exhausted)
	     (pprint-newline :miser stream)
	     (write-char #\space stream))
	   (output-object (pprint-pop) stream)
	   (pprint-exit-if-list-exhausted)
	   (pprint-newline :miser stream)
	   (write-char #\space stream)
	   (pprint-indent :current 0 stream)
	   (loop
	      (output-object (pprint-pop) stream)
	      (pprint-exit-if-list-exhausted)
	      (write-char #\space stream)
	      (pprint-newline :fill stream))))
       (pprint-exit-if-list-exhausted)
1562
       (write-char #\space stream)
1563
       (pprint-newline :linear stream))))
1564