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