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:lisp-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 (required-argument) :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-string)
  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* abrevs and
  60   ;; to tell when sections have been split across multiple lines.
  61   (line-number 0 :type index)
  62   ;; Stack of logical blocks in effect at the buffer start.
  63   (blocks (list (make-logical-block)) :type list)
  64   ;; Buffer holding the per-line prefix active at the buffer start.
  65   ;; Indentation is included in this. The length of this is stored
  66   ;; in the logical block stack.
  67   (prefix (make-string initial-buffer-size) :type simple-string)
  68   ;; Buffer holding the total remaining suffix active at the buffer start.
  69   ;; The characters are right-justified in the buffer to make it easier
  70   ;; to output the buffer. The length is stored in the logical block
  71   ;; stack.
  72   (suffix (make-string initial-buffer-size) :type simple-string)
  73   ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
  74   ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
  75   ;; cons. Adding things to the queue is basically (setf (cdr head) (list
  76   ;; new)) and removing them is basically (pop tail) [except that care must
  77   ;; be taken to handle the empty queue case correctly.]
  78   (queue-tail nil :type list)
  79   (queue-head nil :type list)
  80   ;; Block-start queue entries in effect at the queue head.
  81   (pending-blocks nil :type list))
  82 (def!method print-object ((pstream pretty-stream) stream)
  83   ;; FIXME: CMU CL had #+NIL'ed out this code and done a hand-written
  84   ;; FORMAT hack instead. Make sure that this code actually works instead
  85   ;; of falling into infinite regress or something.
  86   (print-unreadable-object (pstream stream :type t :identity t)))
  87
  88 #!-sb-fluid (declaim (inline index-posn posn-index posn-column))
  89 (defun index-posn (index stream)
  90   (declare (type index index) (type pretty-stream stream)
  91            (values posn))
  92   (+ index (pretty-stream-buffer-offset stream)))
  93 (defun posn-index (posn stream)
  94   (declare (type posn posn) (type pretty-stream stream)
  95            (values index))
  96   (- posn (pretty-stream-buffer-offset stream)))
  97 (defun posn-column (posn stream)
  98   (declare (type posn posn) (type pretty-stream stream)
  99            (values posn))
 100   (index-column (posn-index posn stream) stream))
 101
 102 ;;; Is it OK to do pretty printing on this stream at this time?
 103 (defun print-pretty-on-stream-p (stream)
 104   (and (pretty-stream-p stream)
 105        *print-pretty*))
 106 \f
 107 ;;;; stream interface routines
 108
 109 (defun pretty-out (stream char)
 110   (declare (type pretty-stream stream)
 111            (type base-char char))
 112   (cond ((char= char #\newline)
 113          (enqueue-newline stream :literal))
 114         (t
 115          (ensure-space-in-buffer stream 1)
 116          (let ((fill-pointer (pretty-stream-buffer-fill-pointer stream)))
 117            (setf (schar (pretty-stream-buffer stream) fill-pointer) char)
 118            (setf (pretty-stream-buffer-fill-pointer stream)
 119                  (1+ fill-pointer))))))
 120
 121 (defun pretty-sout (stream string start end)
 122   (declare (type pretty-stream stream)
 123            (type simple-string string)
 124            (type index start)
 125            (type (or index null) end))
 126   (let ((end (or end (length string))))
 127     (unless (= start end)
 128       (let ((newline (position #\newline string :start start :end end)))
 129         (cond
 130          (newline
 131           (pretty-sout stream string start newline)
 132           (enqueue-newline stream :literal)
 133           (pretty-sout stream string (1+ newline) end))
 134          (t
 135           (let ((chars (- end start)))
 136             (loop
 137               (let* ((available (ensure-space-in-buffer stream chars))
 138                      (count (min available chars))
 139                      (fill-pointer (pretty-stream-buffer-fill-pointer stream))
 140                      (new-fill-ptr (+ fill-pointer count)))
 141                 (replace (pretty-stream-buffer stream)
 142                          string
 143                          :start1 fill-pointer :end1 new-fill-ptr
 144                          :start2 start)
 145                 (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
 146                 (decf chars count)
 147                 (when (zerop count)
 148                   (return))
 149                 (incf start count))))))))))
 150
 151 (defun pretty-misc (stream op &optional arg1 arg2)
 152   (declare (ignore stream op arg1 arg2)))
 153 \f
 154 ;;;; logical blocks
 155
 156 (defstruct (logical-block (:copier nil))
 157   ;; The column this logical block started in.
 158   (start-column 0 :type column)
 159   ;; The column the current section started in.
 160   (section-column 0 :type column)
 161   ;; The length of the per-line prefix. We can't move the indentation
 162   ;; left of this.
 163   (per-line-prefix-end 0 :type index)
 164   ;; The overall length of the prefix, including any indentation.
 165   (prefix-length 0 :type index)
 166   ;; The overall length of the suffix.
 167   (suffix-length 0 :type index)
 168   ;; The line number
 169   (section-start-line 0 :type index))
 170
 171 (defun really-start-logical-block (stream column prefix suffix)
 172   (let* ((blocks (pretty-stream-blocks stream))
 173          (prev-block (car blocks))
 174          (per-line-end (logical-block-per-line-prefix-end prev-block))
 175          (prefix-length (logical-block-prefix-length prev-block))
 176          (suffix-length (logical-block-suffix-length prev-block))
 177          (block (make-logical-block
 178                  :start-column column
 179                  :section-column column
 180                  :per-line-prefix-end per-line-end
 181                  :prefix-length prefix-length
 182                  :suffix-length suffix-length
 183                  :section-start-line (pretty-stream-line-number stream))))
 184     (setf (pretty-stream-blocks stream) (cons block blocks))
 185     (set-indentation stream column)
 186     (when prefix
 187       (setf (logical-block-per-line-prefix-end block) column)
 188       (replace (pretty-stream-prefix stream) prefix
 189                :start1 (- column (length prefix)) :end1 column))
 190     (when suffix
 191       (let* ((total-suffix (pretty-stream-suffix stream))
 192              (total-suffix-len (length total-suffix))
 193              (additional (length suffix))
 194              (new-suffix-len (+ suffix-length additional)))
 195         (when (> new-suffix-len total-suffix-len)
 196           (let ((new-total-suffix-len
 197                  (max (* total-suffix-len 2)
 198                       (+ suffix-length
 199                          (floor (* additional 5) 4)))))
 200             (setf total-suffix
 201                   (replace (make-string new-total-suffix-len) total-suffix
 202                            :start1 (- new-total-suffix-len suffix-length)
 203                            :start2 (- total-suffix-len suffix-length)))
 204             (setf total-suffix-len new-total-suffix-len)
 205             (setf (pretty-stream-suffix stream) total-suffix)))
 206         (replace total-suffix suffix
 207                  :start1 (- total-suffix-len new-suffix-len)
 208                  :end1 (- total-suffix-len suffix-length))
 209         (setf (logical-block-suffix-length block) new-suffix-len))))
 210   nil)
 211
 212 (defun set-indentation (stream column)
 213   (let* ((prefix (pretty-stream-prefix stream))
 214          (prefix-len (length prefix))
 215          (block (car (pretty-stream-blocks stream)))
 216          (current (logical-block-prefix-length block))
 217          (minimum (logical-block-per-line-prefix-end block))
 218          (column (max minimum column)))
 219     (when (> column prefix-len)
 220       (setf prefix
 221             (replace (make-string (max (* prefix-len 2)
 222                                        (+ prefix-len
 223                                           (floor (* (- column prefix-len) 5)
 224                                                  4))))
 225                      prefix
 226                      :end1 current))
 227       (setf (pretty-stream-prefix stream) prefix))
 228     (when (> column current)
 229       (fill prefix #\space :start current :end column))
 230     (setf (logical-block-prefix-length block) column)))
 231
 232 (defun really-end-logical-block (stream)
 233   (let* ((old (pop (pretty-stream-blocks stream)))
 234          (old-indent (logical-block-prefix-length old))
 235          (new (car (pretty-stream-blocks stream)))
 236          (new-indent (logical-block-prefix-length new)))
 237     (when (> new-indent old-indent)
 238       (fill (pretty-stream-prefix stream) #\space
 239             :start old-indent :end new-indent)))
 240   nil)
 241 \f
 242 ;;;; the pending operation queue
 243
 244 (defstruct (queued-op (:constructor nil)
 245                       (:copier nil))
 246   (posn 0 :type posn))
 247
 248 (defmacro enqueue (stream type &rest args)
 249   (let ((constructor (symbolicate "MAKE-" type)))
 250     (once-only ((stream stream)
 251                 (entry `(,constructor :posn
 252                                       (index-posn
 253                                        (pretty-stream-buffer-fill-pointer
 254                                         ,stream)
 255                                        ,stream)
 256                                       ,@args))
 257                 (op `(list ,entry))
 258                 (head `(pretty-stream-queue-head ,stream)))
 259       `(progn
 260          (if ,head
 261              (setf (cdr ,head) ,op)
 262              (setf (pretty-stream-queue-tail ,stream) ,op))
 263          (setf (pretty-stream-queue-head ,stream) ,op)
 264          ,entry))))
 265
 266 (defstruct (section-start (:include queued-op)
 267                           (:constructor nil)
 268                           (:copier nil))
 269   (depth 0 :type index)
 270   (section-end nil :type (or null newline block-end)))
 271
 272 (defstruct (newline (:include section-start)
 273                     (:copier nil))
 274   (kind (required-argument)
 275         :type (member :linear :fill :miser :literal :mandatory)))
 276
 277 (defun enqueue-newline (stream kind)
 278   (let* ((depth (length (pretty-stream-pending-blocks stream)))
 279          (newline (enqueue stream newline :kind kind :depth depth)))
 280     (dolist (entry (pretty-stream-queue-tail stream))
 281       (when (and (not (eq newline entry))
 282                  (section-start-p entry)
 283                  (null (section-start-section-end entry))
 284                  (<= depth (section-start-depth entry)))
 285         (setf (section-start-section-end entry) newline))))
 286   (maybe-output stream (or (eq kind :literal) (eq kind :mandatory))))
 287
 288 (defstruct (indentation (:include queued-op)
 289                         (:copier nil))
 290   (kind (required-argument) :type (member :block :current))
 291   (amount 0 :type fixnum))
 292
 293 (defun enqueue-indent (stream kind amount)
 294   (enqueue stream indentation :kind kind :amount amount))
 295
 296 (defstruct (block-start (:include section-start)
 297                         (:copier nil))
 298   (block-end nil :type (or null block-end))
 299   (prefix nil :type (or null simple-string))
 300   (suffix nil :type (or null simple-string)))
 301
 302 (defun start-logical-block (stream prefix per-line-p suffix)
 303   ;; (In the PPRINT-LOGICAL-BLOCK form which calls us,
 304   ;; :PREFIX and :PER-LINE-PREFIX have hairy defaulting behavior,
 305   ;; and might end up being NIL.)
 306   (declare (type (or null string prefix)))
 307   ;; (But the defaulting behavior of PPRINT-LOGICAL-BLOCK :SUFFIX is
 308   ;; trivial, so it should always be a string.)
 309   (declare (type string suffix))
 310   (when prefix
 311     (pretty-sout stream prefix 0 (length prefix)))
 312   (let* ((pending-blocks (pretty-stream-pending-blocks stream))
 313          (start (enqueue stream block-start
 314                          :prefix (and per-line-p prefix)
 315                          :suffix suffix
 316                          :depth (length pending-blocks))))
 317     (setf (pretty-stream-pending-blocks stream)
 318           (cons start pending-blocks))))
 319
 320 (defstruct (block-end (:include queued-op)
 321                       (:copier nil))
 322   (suffix nil :type (or null simple-string)))
 323
 324 (defun end-logical-block (stream)
 325   (let* ((start (pop (pretty-stream-pending-blocks stream)))
 326          (suffix (block-start-suffix start))
 327          (end (enqueue stream block-end :suffix suffix)))
 328     (when suffix
 329       (pretty-sout stream suffix 0 (length suffix)))
 330     (setf (block-start-block-end start) end)))
 331
 332 (defstruct (tab (:include queued-op)
 333                 (:copier nil))
 334   (sectionp nil :type (member t nil))
 335   (relativep nil :type (member t nil))
 336   (colnum 0 :type column)
 337   (colinc 0 :type column))
 338
 339 (defun enqueue-tab (stream kind colnum colinc)
 340   (multiple-value-bind (sectionp relativep)
 341       (ecase kind
 342         (:line (values nil nil))
 343         (:line-relative (values nil t))
 344         (:section (values t nil))
 345         (:section-relative (values t t)))
 346     (enqueue stream tab :sectionp sectionp :relativep relativep
 347              :colnum colnum :colinc colinc)))
 348 \f
 349 ;;;; tab support
 350
 351 (defun compute-tab-size (tab section-start column)
 352   (let ((origin (if (tab-sectionp tab) section-start 0))
 353         (colnum (tab-colnum tab))
 354         (colinc (tab-colinc tab)))
 355     (cond ((tab-relativep tab)
 356            (unless (<= colinc 1)
 357              (let ((newposn (+ column colnum)))
 358                (let ((rem (rem newposn colinc)))
 359                  (unless (zerop rem)
 360                    (incf colnum (- colinc rem))))))
 361            colnum)
 362           ((<= column (+ colnum origin))
 363            (- (+ colnum origin) column))
 364           (t
 365            (- colinc
 366               (rem (- column origin) colinc))))))
 367
 368 (defun index-column (index stream)
 369   (let ((column (pretty-stream-buffer-start-column stream))
 370         (section-start (logical-block-section-column
 371                         (first (pretty-stream-blocks stream))))
 372         (end-posn (index-posn index stream)))
 373     (dolist (op (pretty-stream-queue-tail stream))
 374       (when (>= (queued-op-posn op) end-posn)
 375         (return))
 376       (typecase op
 377         (tab
 378          (incf column
 379                (compute-tab-size op
 380                                  section-start
 381                                  (+ column
 382                                     (posn-index (tab-posn op)
 383                                                     stream)))))
 384         ((or newline block-start)
 385          (setf section-start
 386                (+ column (posn-index (queued-op-posn op)
 387                                          stream))))))
 388     (+ column index)))
 389
 390 (defun expand-tabs (stream through)
 391   (let ((insertions nil)
 392         (additional 0)
 393         (column (pretty-stream-buffer-start-column stream))
 394         (section-start (logical-block-section-column
 395                         (first (pretty-stream-blocks stream)))))
 396     (dolist (op (pretty-stream-queue-tail stream))
 397       (typecase op
 398         (tab
 399          (let* ((index (posn-index (tab-posn op) stream))
 400                 (tabsize (compute-tab-size op
 401                                            section-start
 402                                            (+ column index))))
 403            (unless (zerop tabsize)
 404              (push (cons index tabsize) insertions)
 405              (incf additional tabsize)
 406              (incf column tabsize))))
 407         ((or newline block-start)
 408          (setf section-start
 409                (+ column (posn-index (queued-op-posn op) stream)))))
 410       (when (eq op through)
 411         (return)))
 412     (when insertions
 413       (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
 414              (new-fill-ptr (+ fill-ptr additional))
 415              (buffer (pretty-stream-buffer stream))
 416              (new-buffer buffer)
 417              (length (length buffer))
 418              (end fill-ptr))
 419         (when (> new-fill-ptr length)
 420           (let ((new-length (max (* length 2)
 421                                  (+ fill-ptr
 422                                     (floor (* additional 5) 4)))))
 423             (setf new-buffer (make-string new-length))
 424             (setf (pretty-stream-buffer stream) new-buffer)))
 425         (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
 426         (decf (pretty-stream-buffer-offset stream) additional)
 427         (dolist (insertion insertions)
 428           (let* ((srcpos (car insertion))
 429                  (amount (cdr insertion))
 430                  (dstpos (+ srcpos additional)))
 431             (replace new-buffer buffer :start1 dstpos :start2 srcpos :end2 end)
 432             (fill new-buffer #\space :start (- dstpos amount) :end dstpos)
 433             (decf additional amount)
 434             (setf end srcpos)))
 435         (unless (eq new-buffer buffer)
 436           (replace new-buffer buffer :end1 end :end2 end))))))
 437 \f
 438 ;;;; stuff to do the actual outputting
 439
 440 (defun ensure-space-in-buffer (stream want)
 441   (declare (type pretty-stream stream)
 442            (type index want))
 443   (let* ((buffer (pretty-stream-buffer stream))
 444          (length (length buffer))
 445          (fill-ptr (pretty-stream-buffer-fill-pointer stream))
 446          (available (- length fill-ptr)))
 447     (cond ((plusp available)
 448            available)
 449           ((> fill-ptr (pretty-stream-line-length stream))
 450            (unless (maybe-output stream nil)
 451              (output-partial-line stream))
 452            (ensure-space-in-buffer stream want))
 453           (t
 454            (let* ((new-length (max (* length 2)
 455                                    (+ length
 456                                       (floor (* want 5) 4))))
 457                   (new-buffer (make-string new-length)))
 458              (setf (pretty-stream-buffer stream) new-buffer)
 459              (replace new-buffer buffer :end1 fill-ptr)
 460              (- new-length fill-ptr))))))
 461
 462 (defun maybe-output (stream force-newlines-p)
 463   (declare (type pretty-stream stream))
 464   (let ((tail (pretty-stream-queue-tail stream))
 465         (output-anything nil))
 466     (loop
 467       (unless tail
 468         (setf (pretty-stream-queue-head stream) nil)
 469         (return))
 470       (let ((next (pop tail)))
 471         (etypecase next
 472           (newline
 473            (when (ecase (newline-kind next)
 474                    ((:literal :mandatory :linear) t)
 475                    (:miser (misering-p stream))
 476                    (:fill
 477                     (or (misering-p stream)
 478                         (> (pretty-stream-line-number stream)
 479                            (logical-block-section-start-line
 480                             (first (pretty-stream-blocks stream))))
 481                         (ecase (fits-on-line-p stream
 482                                                (newline-section-end next)
 483                                                force-newlines-p)
 484                           ((t) nil)
 485                           ((nil) t)
 486                           (:dont-know
 487                            (return))))))
 488              (setf output-anything t)
 489              (output-line stream next)))
 490           (indentation
 491            (unless (misering-p stream)
 492              (set-indentation stream
 493                               (+ (ecase (indentation-kind next)
 494                                    (:block
 495                                     (logical-block-start-column
 496                                      (car (pretty-stream-blocks stream))))
 497                                    (:current
 498                                     (posn-column
 499                                      (indentation-posn next)
 500                                      stream)))
 501                                  (indentation-amount next)))))
 502           (block-start
 503            (ecase (fits-on-line-p stream (block-start-section-end next)
 504                                   force-newlines-p)
 505              ((t)
 506               ;; Just nuke the whole logical block and make it look
 507               ;; like one nice long literal.
 508               (let ((end (block-start-block-end next)))
 509                 (expand-tabs stream end)
 510                 (setf tail (cdr (member end tail)))))
 511              ((nil)
 512               (really-start-logical-block
 513                stream
 514                (posn-column (block-start-posn next) stream)
 515                (block-start-prefix next)
 516                (block-start-suffix next)))
 517              (:dont-know
 518               (return))))
 519           (block-end
 520            (really-end-logical-block stream))
 521           (tab
 522            (expand-tabs stream next))))
 523       (setf (pretty-stream-queue-tail stream) tail))
 524     output-anything))
 525
 526 (defun misering-p (stream)
 527   (declare (type pretty-stream stream))
 528   (and *print-miser-width*
 529        (<= (- (pretty-stream-line-length stream)
 530               (logical-block-start-column (car (pretty-stream-blocks stream))))
 531            *print-miser-width*)))
 532
 533 (defun fits-on-line-p (stream until force-newlines-p)
 534   (let ((available (pretty-stream-line-length stream)))
 535     (when (and (not *print-readably*) *print-lines*
 536                (= *print-lines* (pretty-stream-line-number stream)))
 537       (decf available 3) ; for the `` ..''
 538       (decf available (logical-block-suffix-length
 539                        (car (pretty-stream-blocks stream)))))
 540     (cond (until
 541            (<= (posn-column (queued-op-posn until) stream) available))
 542           (force-newlines-p nil)
 543           ((> (index-column (pretty-stream-buffer-fill-pointer stream) stream)
 544               available)
 545            nil)
 546           (t
 547            :dont-know))))
 548
 549 (defun output-line (stream until)
 550   (declare (type pretty-stream stream)
 551            (type newline until))
 552   (let* ((target (pretty-stream-target stream))
 553          (buffer (pretty-stream-buffer stream))
 554          (kind (newline-kind until))
 555          (literal-p (eq kind :literal))
 556          (amount-to-consume (posn-index (newline-posn until) stream))
 557          (amount-to-print
 558           (if literal-p
 559               amount-to-consume
 560               (let ((last-non-blank
 561                      (position #\space buffer :end amount-to-consume
 562                                :from-end t :test #'char/=)))
 563                 (if last-non-blank
 564                     (1+ last-non-blank)
 565                     0)))))
 566     (write-string buffer target :end amount-to-print)
 567     (let ((line-number (pretty-stream-line-number stream)))
 568       (incf line-number)
 569       (when (and (not *print-readably*)
 570                  *print-lines* (>= line-number *print-lines*))
 571         (write-string " .." target)
 572         (let ((suffix-length (logical-block-suffix-length
 573                               (car (pretty-stream-blocks stream)))))
 574           (unless (zerop suffix-length)
 575             (let* ((suffix (pretty-stream-suffix stream))
 576                    (len (length suffix)))
 577               (write-string suffix target
 578                             :start (- len suffix-length)
 579                             :end len))))
 580         (throw 'line-limit-abbreviation-happened t))
 581       (setf (pretty-stream-line-number stream) line-number)
 582       (write-char #\newline target)
 583       (setf (pretty-stream-buffer-start-column stream) 0)
 584       (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
 585              (block (first (pretty-stream-blocks stream)))
 586              (prefix-len
 587               (if literal-p
 588                   (logical-block-per-line-prefix-end block)
 589                   (logical-block-prefix-length block)))
 590              (shift (- amount-to-consume prefix-len))
 591              (new-fill-ptr (- fill-ptr shift))
 592              (new-buffer buffer)
 593              (buffer-length (length buffer)))
 594         (when (> new-fill-ptr buffer-length)
 595           (setf new-buffer
 596                 (make-string (max (* buffer-length 2)
 597                                   (+ buffer-length
 598                                      (floor (* (- new-fill-ptr buffer-length)
 599                                                5)
 600                                             4)))))
 601           (setf (pretty-stream-buffer stream) new-buffer))
 602         (replace new-buffer buffer
 603                  :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
 604         (replace new-buffer (pretty-stream-prefix stream)
 605                  :end1 prefix-len)
 606         (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
 607         (incf (pretty-stream-buffer-offset stream) shift)
 608         (unless literal-p
 609           (setf (logical-block-section-column block) prefix-len)
 610           (setf (logical-block-section-start-line block) line-number))))))
 611
 612 (defun output-partial-line (stream)
 613   (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
 614          (tail (pretty-stream-queue-tail stream))
 615          (count
 616           (if tail
 617               (posn-index (queued-op-posn (car tail)) stream)
 618               fill-ptr))
 619          (new-fill-ptr (- fill-ptr count))
 620          (buffer (pretty-stream-buffer stream)))
 621     (when (zerop count)
 622       (error "Output-partial-line called when nothing can be output."))
 623     (write-string buffer (pretty-stream-target stream)
 624                   :start 0 :end count)
 625     (incf (pretty-stream-buffer-start-column stream) count)
 626     (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr)
 627     (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
 628     (incf (pretty-stream-buffer-offset stream) count)))
 629
 630 (defun force-pretty-output (stream)
 631   (maybe-output stream nil)
 632   (expand-tabs stream nil)
 633   (write-string (pretty-stream-buffer stream)
 634                 (pretty-stream-target stream)
 635                 :end (pretty-stream-buffer-fill-pointer stream)))
 636 \f
 637 ;;;; user interface to the pretty printer
 638
 639 (defun pprint-newline (kind &optional stream)
 640   #!+sb-doc
 641   "Output a conditional newline to STREAM (which defaults to
 642    *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do
 643    nothing if not. KIND can be one of:
 644      :LINEAR - A line break is inserted if and only if the immediatly
 645         containing section cannot be printed on one line.
 646      :MISER - Same as LINEAR, but only if ``miser-style'' is in effect.
 647         (See *PRINT-MISER-WIDTH*.)
 648      :FILL - A line break is inserted if and only if either:
 649        (a) the following section cannot be printed on the end of the
 650            current line,
 651        (b) the preceding section was not printed on a single line, or
 652        (c) the immediately containing section cannot be printed on one
 653            line and miser-style is in effect.
 654      :MANDATORY - A line break is always inserted.
 655    When a line break is inserted by any type of conditional newline, any
 656    blanks that immediately precede the conditional newline are ommitted
 657    from the output and indentation is introduced at the beginning of the
 658    next line. (See PPRINT-INDENT.)"
 659   (declare (type (member :linear :miser :fill :mandatory) kind)
 660            (type (or stream (member t nil)) stream)
 661            (values null))
 662   (let ((stream (case stream
 663                   ((t) *terminal-io*)
 664                   ((nil) *standard-output*)
 665                   (t stream))))
 666     (when (print-pretty-on-stream-p stream)
 667       (enqueue-newline stream kind)))
 668   nil)
 669
 670 (defun pprint-indent (relative-to n &optional stream)
 671   #!+sb-doc
 672   "Specify the indentation to use in the current logical block if STREAM
 673    (which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream
 674    and do nothing if not. (See PPRINT-LOGICAL-BLOCK.)  N is the indention
 675    to use (in ems, the width of an ``m'') and RELATIVE-TO can be either:
 676      :BLOCK - Indent relative to the column the current logical block
 677         started on.
 678      :CURRENT - Indent relative to the current column.
 679    The new indention value does not take effect until the following line
 680    break."
 681   (declare (type (member :block :current) relative-to)
 682            (type integer n)
 683            (type (or stream (member t nil)) stream)
 684            (values null))
 685   (let ((stream (case stream
 686                   ((t) *terminal-io*)
 687                   ((nil) *standard-output*)
 688                   (t stream))))
 689     (when (print-pretty-on-stream-p stream)
 690       (enqueue-indent stream relative-to n)))
 691   nil)
 692
 693 (defun pprint-tab (kind colnum colinc &optional stream)
 694   #!+sb-doc
 695   "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing
 696    stream, perform tabbing based on KIND, otherwise do nothing. KIND can
 697    be one of:
 698      :LINE - Tab to column COLNUM. If already past COLNUM tab to the next
 699        multiple of COLINC.
 700      :SECTION - Same as :LINE, but count from the start of the current
 701        section, not the start of the line.
 702      :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of
 703        COLINC.
 704      :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start
 705        of the current section, not the start of the line."
 706   (declare (type (member :line :section :line-relative :section-relative) kind)
 707            (type unsigned-byte colnum colinc)
 708            (type (or stream (member t nil)) stream)
 709            (values null))
 710   (let ((stream (case stream
 711                   ((t) *terminal-io*)
 712                   ((nil) *standard-output*)
 713                   (t stream))))
 714     (when (print-pretty-on-stream-p stream)
 715       (enqueue-tab stream kind colnum colinc)))
 716   nil)
 717
 718 (defun pprint-fill (stream list &optional (colon? t) atsign?)
 719   #!+sb-doc
 720   "Output LIST to STREAM putting :FILL conditional newlines between each
 721    element. If COLON? is NIL (defaults to T), then no parens are printed
 722    around the output. ATSIGN? is ignored (but allowed so that PPRINT-FILL
 723    can be used with the ~/.../ format directive."
 724   (declare (ignore atsign?))
 725   (pprint-logical-block (stream list
 726                                 :prefix (if colon? "(" "")
 727                                 :suffix (if colon? ")" ""))
 728     (pprint-exit-if-list-exhausted)
 729     (loop
 730       (output-object (pprint-pop) stream)
 731       (pprint-exit-if-list-exhausted)
 732       (write-char #\space stream)
 733       (pprint-newline :fill stream))))
 734
 735 (defun pprint-linear (stream list &optional (colon? t) atsign?)
 736   #!+sb-doc
 737   "Output LIST to STREAM putting :LINEAR conditional newlines between each
 738    element. If COLON? is NIL (defaults to T), then no parens are printed
 739    around the output. ATSIGN? is ignored (but allowed so that PPRINT-LINEAR
 740    can be used with the ~/.../ format directive."
 741   (declare (ignore atsign?))
 742   (pprint-logical-block (stream list
 743                                 :prefix (if colon? "(" "")
 744                                 :suffix (if colon? ")" ""))
 745     (pprint-exit-if-list-exhausted)
 746     (loop
 747       (output-object (pprint-pop) stream)
 748       (pprint-exit-if-list-exhausted)
 749       (write-char #\space stream)
 750       (pprint-newline :linear stream))))
 751
 752 (defun pprint-tabular (stream list &optional (colon? t) atsign? tabsize)
 753   #!+sb-doc
 754   "Output LIST to STREAM tabbing to the next column that is an even multiple
 755    of TABSIZE (which defaults to 16) between each element. :FILL style
 756    conditional newlines are also output between each element. If COLON? is
 757    NIL (defaults to T), then no parens are printed around the output.
 758    ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with
 759    the ~/.../ format directive."
 760   (declare (ignore atsign?))
 761   (pprint-logical-block (stream list
 762                                 :prefix (if colon? "(" "")
 763                                 :suffix (if colon? ")" ""))
 764     (pprint-exit-if-list-exhausted)
 765     (loop
 766       (output-object (pprint-pop) stream)
 767       (pprint-exit-if-list-exhausted)
 768       (write-char #\space stream)
 769       (pprint-tab :section-relative 0 (or tabsize 16) stream)
 770       (pprint-newline :fill stream))))
 771 \f
 772 ;;;; pprint-dispatch tables
 773
 774 (defvar *initial-pprint-dispatch*)
 775 (defvar *building-initial-table* nil)
 776
 777 (defstruct (pprint-dispatch-entry (:copier nil))
 778   ;; The type specifier for this entry.
 779   (type (required-argument) :type t)
 780   ;; A function to test to see whether an object is of this time. Pretty must
 781   ;; just (lambda (obj) (typep object type)) except that we handle the
 782   ;; CONS type specially so that (cons (member foo)) works. We don't
 783   ;; bother computing this for entries in the CONS hash table, because
 784   ;; we don't need it.
 785   (test-fn nil :type (or function null))
 786   ;; The priority for this guy.
 787   (priority 0 :type real)
 788   ;; T iff one of the original entries.
 789   (initial-p *building-initial-table* :type (member t nil))
 790   ;; And the associated function.
 791   (function (required-argument) :type function))
 792 (def!method print-object ((entry pprint-dispatch-entry) stream)
 793   (print-unreadable-object (entry stream :type t)
 794     (format stream "type=~S, priority=~S~@[ [initial]~]"
 795             (pprint-dispatch-entry-type entry)
 796             (pprint-dispatch-entry-priority entry)
 797             (pprint-dispatch-entry-initial-p entry))))
 798
 799 (defstruct (pprint-dispatch-table (:copier nil))
 800   ;; A list of all the entries (except for CONS entries below) in highest
 801   ;; to lowest priority.
 802   (entries nil :type list)
 803   ;; A hash table mapping things to entries for type specifiers of the
 804   ;; form (CONS (MEMBER <thing>)). If the type specifier is of this form,
 805   ;; we put it in this hash table instead of the regular entries table.
 806   (cons-entries (make-hash-table :test 'eql)))
 807 (def!method print-object ((table pprint-dispatch-table) stream)
 808   (print-unreadable-object (table stream :type t :identity t)))
 809
 810 (defun cons-type-specifier-p (spec)
 811   (and (consp spec)
 812        (eq (car spec) 'cons)
 813        (cdr spec)
 814        (null (cddr spec))
 815        (let ((car (cadr spec)))
 816          (and (consp car)
 817               (let ((carcar (car car)))
 818                 (or (eq carcar 'member)
 819                     (eq carcar 'eql)))
 820               (cdr car)
 821               (null (cddr car))))))
 822
 823 (defun entry< (e1 e2)
 824   (declare (type pprint-dispatch-entry e1 e2))
 825   (if (pprint-dispatch-entry-initial-p e1)
 826       (if (pprint-dispatch-entry-initial-p e2)
 827           (< (pprint-dispatch-entry-priority e1)
 828              (pprint-dispatch-entry-priority e2))
 829           t)
 830       (if (pprint-dispatch-entry-initial-p e2)
 831           nil
 832           (< (pprint-dispatch-entry-priority e1)
 833              (pprint-dispatch-entry-priority e2)))))
 834
 835 (macrolet ((frob (x)
 836              `(cons ',x #'(lambda (object) ,x))))
 837   (defvar *precompiled-pprint-dispatch-funs*
 838     (list (frob (typep object 'array))
 839           (frob (and (consp object)
 840                      (and (typep (car object) 'symbol)
 841                           (typep (car object) '(satisfies fboundp)))))
 842           (frob (typep object 'cons)))))
 843
 844 (defun compute-test-fn (type)
 845   (let ((was-cons nil))
 846     (labels ((compute-test-expr (type object)
 847                (if (listp type)
 848                    (case (car type)
 849                      (cons
 850                       (setq was-cons t)
 851                       (destructuring-bind
 852                           (&optional (car nil car-p) (cdr nil cdr-p))
 853                           (cdr type)
 854                         `(and (consp ,object)
 855                               ,@(when car-p
 856                                   `(,(compute-test-expr
 857                                       car `(car ,object))))
 858                               ,@(when cdr-p
 859                                   `(,(compute-test-expr
 860                                       cdr `(cdr ,object)))))))
 861                      (not
 862                       (destructuring-bind (type) (cdr type)
 863                         `(not ,(compute-test-expr type object))))
 864                      (and
 865                       `(and ,@(mapcar #'(lambda (type)
 866                                           (compute-test-expr type object))
 867                                       (cdr type))))
 868                      (or
 869                       `(or ,@(mapcar #'(lambda (type)
 870                                          (compute-test-expr type object))
 871                                      (cdr type))))
 872                      (t
 873                       `(typep ,object ',type)))
 874                    `(typep ,object ',type))))
 875       (let ((expr (compute-test-expr type 'object)))
 876         (cond ((cdr (assoc expr *precompiled-pprint-dispatch-funs*
 877                            :test #'equal)))
 878               (t
 879                (compile nil `(lambda (object) ,expr))))))))
 880
 881 (defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
 882   (declare (type (or pprint-dispatch-table null) table))
 883   (let* ((orig (or table *initial-pprint-dispatch*))
 884          (new (make-pprint-dispatch-table
 885                :entries (copy-list (pprint-dispatch-table-entries orig))))
 886          (new-cons-entries (pprint-dispatch-table-cons-entries new)))
 887     (maphash #'(lambda (key value)
 888                  (setf (gethash key new-cons-entries) value))
 889              (pprint-dispatch-table-cons-entries orig))
 890     new))
 891
 892 (defun pprint-dispatch (object &optional (table *print-pprint-dispatch*))
 893   (declare (type (or pprint-dispatch-table null) table))
 894   (let* ((table (or table *initial-pprint-dispatch*))
 895          (cons-entry
 896           (and (consp object)
 897                (gethash (car object)
 898                         (pprint-dispatch-table-cons-entries table))))
 899          (entry
 900           (dolist (entry (pprint-dispatch-table-entries table) cons-entry)
 901             (when (and cons-entry
 902                        (entry< entry cons-entry))
 903               (return cons-entry))
 904             (when (funcall (pprint-dispatch-entry-test-fn entry) object)
 905               (return entry)))))
 906     (if entry
 907         (values (pprint-dispatch-entry-function entry) t)
 908         (values #'(lambda (stream object)
 909                     (output-ugly-object object stream))
 910                 nil))))
 911
 912 (defun set-pprint-dispatch (type function &optional
 913                             (priority 0) (table *print-pprint-dispatch*))
 914   (declare (type (or null function) function)
 915            (type real priority)
 916            (type pprint-dispatch-table table))
 917   (if function
 918       (if (cons-type-specifier-p type)
 919           (setf (gethash (second (second type))
 920                          (pprint-dispatch-table-cons-entries table))
 921                 (make-pprint-dispatch-entry :type type :priority priority
 922                                             :function function))
 923           (let ((list (delete type (pprint-dispatch-table-entries table)
 924                               :key #'pprint-dispatch-entry-type
 925                               :test #'equal))
 926                 (entry (make-pprint-dispatch-entry
 927                         :type type :test-fn (compute-test-fn type)
 928                         :priority priority :function function)))
 929             (do ((prev nil next)
 930                  (next list (cdr next)))
 931                 ((null next)
 932                  (if prev
 933                      (setf (cdr prev) (list entry))
 934                      (setf list (list entry))))
 935               (when (entry< (car next) entry)
 936                 (if prev
 937                     (setf (cdr prev) (cons entry next))
 938                     (setf list (cons entry next)))
 939                 (return)))
 940             (setf (pprint-dispatch-table-entries table) list)))
 941       (if (cons-type-specifier-p type)
 942           (remhash (second (second type))
 943                    (pprint-dispatch-table-cons-entries table))
 944           (setf (pprint-dispatch-table-entries table)
 945                 (delete type (pprint-dispatch-table-entries table)
 946                         :key #'pprint-dispatch-entry-type
 947                         :test #'equal))))
 948   nil)
 949 \f
 950 ;;;; standard pretty-printing routines
 951
 952 (defun pprint-array (stream array)
 953   (cond ((or (and (null *print-array*) (null *print-readably*))
 954              (stringp array)
 955              (bit-vector-p array))
 956          (output-ugly-object array stream))
 957         ((and *print-readably* (not (eq (array-element-type array) t)))
 958          (let ((*print-readably* nil))
 959            (error 'print-not-readable :object array)))
 960         ((vectorp array)
 961          (pprint-vector stream array))
 962         (t
 963          (pprint-multi-dim-array stream array))))
 964
 965 (defun pprint-vector (stream vector)
 966   (pprint-logical-block (stream nil :prefix "#(" :suffix ")")
 967     (dotimes (i (length vector))
 968       (unless (zerop i)
 969         (format stream " ~:_"))
 970       (pprint-pop)
 971       (output-object (aref vector i) stream))))
 972
 973 (defun pprint-multi-dim-array (stream array)
 974   (funcall (formatter "#~DA") stream (array-rank array))
 975   (with-array-data ((data array) (start) (end))
 976     (declare (ignore end))
 977     (labels ((output-guts (stream index dimensions)
 978                (if (null dimensions)
 979                    (output-object (aref data index) stream)
 980                    (pprint-logical-block
 981                        (stream nil :prefix "(" :suffix ")")
 982                      (let ((dim (car dimensions)))
 983                        (unless (zerop dim)
 984                          (let* ((dims (cdr dimensions))
 985                                 (index index)
 986                                 (step (reduce #'* dims))
 987                                 (count 0))
 988                            (loop
 989                              (pprint-pop)
 990                              (output-guts stream index dims)
 991                              (when (= (incf count) dim)
 992                                (return))
 993                              (write-char #\space stream)
 994                              (pprint-newline (if dims :linear :fill)
 995                                              stream)
 996                              (incf index step)))))))))
 997       (output-guts stream start (array-dimensions array)))))
 998
 999 (defun pprint-lambda-list (stream lambda-list &rest noise)
1000   (declare (ignore noise))
1001   (pprint-logical-block (stream lambda-list :prefix "(" :suffix ")")
1002     (let ((state :required)
1003           (first t))
1004       (loop
1005         (pprint-exit-if-list-exhausted)
1006         (unless first
1007           (write-char #\space stream))
1008         (let ((arg (pprint-pop)))
1009           (unless first
1010             (case arg
1011               (&optional
1012                (setf state :optional)
1013                (pprint-newline :linear stream))
1014               ((&rest &body)
1015                (setf state :required)
1016                (pprint-newline :linear stream))
1017               (&key
1018                (setf state :key)
1019                (pprint-newline :linear stream))
1020               (&aux
1021                (setf state :optional)
1022                (pprint-newline :linear stream))
1023               (t
1024                (pprint-newline :fill stream))))
1025           (ecase state
1026             (:required
1027              (pprint-lambda-list stream arg))
1028             ((:optional :key)
1029              (pprint-logical-block
1030                  (stream arg :prefix "(" :suffix ")")
1031                (pprint-exit-if-list-exhausted)
1032                (if (eq state :key)
1033                    (pprint-logical-block
1034                        (stream (pprint-pop) :prefix "(" :suffix ")")
1035                      (pprint-exit-if-list-exhausted)
1036                      (output-object (pprint-pop) stream)
1037                      (pprint-exit-if-list-exhausted)
1038                      (write-char #\space stream)
1039                      (pprint-newline :fill stream)
1040                      (pprint-lambda-list stream (pprint-pop))
1041                      (loop
1042                        (pprint-exit-if-list-exhausted)
1043                        (write-char #\space stream)
1044                        (pprint-newline :fill stream)
1045                        (output-object (pprint-pop) stream)))
1046                    (pprint-lambda-list stream (pprint-pop)))
1047                (loop
1048                  (pprint-exit-if-list-exhausted)
1049                  (write-char #\space stream)
1050                  (pprint-newline :linear stream)
1051                  (output-object (pprint-pop) stream))))))
1052         (setf first nil)))))
1053
1054 (defun pprint-lambda (stream list &rest noise)
1055   (declare (ignore noise))
1056   (funcall (formatter
1057             ;; KLUDGE: This format string, and other format strings which also
1058             ;; refer to SB!PRETTY, rely on the current SBCL not-quite-ANSI
1059             ;; behavior of FORMATTER in order to make code which survives the
1060             ;; transition when SB!PRETTY is renamed to SB-PRETTY after cold
1061             ;; init. (ANSI says that the FORMATTER functions should be
1062             ;; equivalent to the format string, but the SBCL FORMATTER
1063             ;; functions contain references to package objects, not package
1064             ;; names, so they keep right on going if the packages are renamed.)
1065             ;; If our FORMATTER behavior is ever made more compliant, the code
1066             ;; here will have to change. -- WHN 19991207
1067             "~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
1068            stream
1069            list))
1070
1071 (defun pprint-block (stream list &rest noise)
1072   (declare (ignore noise))
1073   (funcall (formatter "~:<~^~W~^~3I ~:_~W~1I~@{ ~_~W~}~:>") stream list))
1074
1075 (defun pprint-flet (stream list &rest noise)
1076   (declare (ignore noise))
1077   (funcall (formatter
1078             "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
1079            stream
1080            list))
1081
1082 (defun pprint-let (stream list &rest noise)
1083   (declare (ignore noise))
1084   (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>")
1085            stream
1086            list))
1087
1088 (defun pprint-progn (stream list &rest noise)
1089   (declare (ignore noise))
1090   (funcall (formatter "~:<~^~W~@{ ~_~W~}~:>") stream list))
1091
1092 (defun pprint-progv (stream list &rest noise)
1093   (declare (ignore noise))
1094   (funcall (formatter "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>")
1095            stream list))
1096
1097 (defun pprint-quote (stream list &rest noise)
1098   (declare (ignore noise))
1099   (if (and (consp list)
1100            (consp (cdr list))
1101            (null (cddr list)))
1102       (case (car list)
1103         (function
1104          (write-string "#'" stream)
1105          (output-object (cadr list) stream))
1106         (quote
1107          (write-char #\' stream)
1108          (output-object (cadr list) stream))
1109         (t
1110          (pprint-fill stream list)))
1111       (pprint-fill stream list)))
1112
1113 (defun pprint-setq (stream list &rest noise)
1114   (declare (ignore noise))
1115   (pprint-logical-block (stream list :prefix "(" :suffix ")")
1116     (pprint-exit-if-list-exhausted)
1117     (output-object (pprint-pop) stream)
1118     (pprint-exit-if-list-exhausted)
1119     (write-char #\space stream)
1120     (pprint-newline :miser stream)
1121     (if (and (consp (cdr list)) (consp (cddr list)))
1122         (loop
1123           (pprint-indent :current 2 stream)
1124           (output-object (pprint-pop) stream)
1125           (pprint-exit-if-list-exhausted)
1126           (write-char #\space stream)
1127           (pprint-newline :linear stream)
1128           (pprint-indent :current -2 stream)
1129           (output-object (pprint-pop) stream)
1130           (pprint-exit-if-list-exhausted)
1131           (write-char #\space stream)
1132           (pprint-newline :linear stream))
1133         (progn
1134           (pprint-indent :current 0 stream)
1135           (output-object (pprint-pop) stream)
1136           (pprint-exit-if-list-exhausted)
1137           (write-char #\space stream)
1138           (pprint-newline :linear stream)
1139           (output-object (pprint-pop) stream)))))
1140
1141 ;;; FIXME: could become SB!XC:DEFMACRO wrapped in EVAL-WHEN (COMPILE EVAL)
1142 (defmacro pprint-tagbody-guts (stream)
1143   `(loop
1144      (pprint-exit-if-list-exhausted)
1145      (write-char #\space ,stream)
1146      (let ((form-or-tag (pprint-pop)))
1147        (pprint-indent :block
1148                       (if (atom form-or-tag) 0 1)
1149                       ,stream)
1150        (pprint-newline :linear ,stream)
1151        (output-object form-or-tag ,stream))))
1152
1153 (defun pprint-tagbody (stream list &rest noise)
1154   (declare (ignore noise))
1155   (pprint-logical-block (stream list :prefix "(" :suffix ")")
1156     (pprint-exit-if-list-exhausted)
1157     (output-object (pprint-pop) stream)
1158     (pprint-tagbody-guts stream)))
1159
1160 (defun pprint-case (stream list &rest noise)
1161   (declare (ignore noise))
1162   (funcall (formatter
1163             "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/SB!PRETTY:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>")
1164            stream
1165            list))
1166
1167 (defun pprint-defun (stream list &rest noise)
1168   (declare (ignore noise))
1169   (funcall (formatter
1170             "~:<~^~W~^ ~@_~:I~W~^ ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
1171            stream
1172            list))
1173
1174 (defun pprint-destructuring-bind (stream list &rest noise)
1175   (declare (ignore noise))
1176   (funcall (formatter
1177             "~:<~^~W~^~3I ~_~:/SB!PRETTY:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>")
1178            stream list))
1179
1180 (defun pprint-do (stream list &rest noise)
1181   (declare (ignore noise))
1182   (pprint-logical-block (stream list :prefix "(" :suffix ")")
1183     (pprint-exit-if-list-exhausted)
1184     (output-object (pprint-pop) stream)
1185     (pprint-exit-if-list-exhausted)
1186     (write-char #\space stream)
1187     (pprint-indent :current 0 stream)
1188     (funcall (formatter "~:<~@{~:<~^~W~^ ~@_~:I~W~@{ ~_~W~}~:>~^~:@_~}~:>")
1189              stream
1190              (pprint-pop))
1191     (pprint-exit-if-list-exhausted)
1192     (write-char #\space stream)
1193     (pprint-newline :linear stream)
1194     (pprint-linear stream (pprint-pop))
1195     (pprint-tagbody-guts stream)))
1196
1197 (defun pprint-dolist (stream list &rest noise)
1198   (declare (ignore noise))
1199   (pprint-logical-block (stream list :prefix "(" :suffix ")")
1200     (pprint-exit-if-list-exhausted)
1201     (output-object (pprint-pop) stream)
1202     (pprint-exit-if-list-exhausted)
1203     (pprint-indent :block 3 stream)
1204     (write-char #\space stream)
1205     (pprint-newline :fill stream)
1206     (funcall (formatter "~:<~^~W~^ ~:_~:I~W~@{ ~_~W~}~:>")
1207              stream
1208              (pprint-pop))
1209     (pprint-tagbody-guts stream)))
1210
1211 (defun pprint-typecase (stream list &rest noise)
1212   (declare (ignore noise))
1213   (funcall (formatter
1214             "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>")
1215            stream
1216            list))
1217
1218 (defun pprint-prog (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-fill stream (pprint-pop))
1227     (pprint-tagbody-guts stream)))
1228
1229 (defun pprint-function-call (stream list &rest noise)
1230   (declare (ignore noise))
1231   (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>")
1232            stream
1233            list))
1234 \f
1235 ;;;; the interface seen by regular (ugly) printer and initialization routines
1236
1237 ;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when *PRINT-PRETTY* is
1238 ;;; bound to T.
1239 (defun output-pretty-object (object stream)
1240   (with-pretty-stream (stream)
1241     (funcall (pprint-dispatch object) stream object)))
1242
1243 (defun !pprint-cold-init ()
1244   (/show0 "entering !PPRINT-COLD-INIT")
1245   (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))
1246   (let ((*print-pprint-dispatch* *initial-pprint-dispatch*)
1247         (*building-initial-table* t))
1248     ;; printers for regular types
1249     (/show0 "doing SET-PPRINT-DISPATCH for regular types")
1250     (set-pprint-dispatch 'array #'pprint-array)
1251     (set-pprint-dispatch '(cons (and symbol (satisfies fboundp)))
1252                          #'pprint-function-call -1)
1253     (set-pprint-dispatch 'cons #'pprint-fill -2)
1254     ;; cons cells with interesting things for the car
1255     (/show0 "doing SET-PPRINT-DISPATCH for CONS with interesting CAR")
1256
1257     (dolist (magic-form '((lambda pprint-lambda)
1258
1259                           ;; special forms
1260                           (block pprint-block)
1261                           (catch pprint-block)
1262                           (eval-when pprint-block)
1263                           (flet pprint-flet)
1264                           (function pprint-quote)
1265                           (labels pprint-flet)
1266                           (let pprint-let)
1267                           (let* pprint-let)
1268                           (locally pprint-progn)
1269                           (macrolet pprint-flet)
1270                           (multiple-value-call pprint-block)
1271                           (multiple-value-prog1 pprint-block)
1272                           (progn pprint-progn)
1273                           (progv pprint-progv)
1274                           (quote pprint-quote)
1275                           (return-from pprint-block)
1276                           (setq pprint-setq)
1277                           (symbol-macrolet pprint-let)
1278                           (tagbody pprint-tagbody)
1279                           (throw pprint-block)
1280                           (unwind-protect pprint-block)
1281
1282                           ;; macros
1283                           (case pprint-case)
1284                           (ccase pprint-case)
1285                           (ctypecase pprint-typecase)
1286                           (defconstant pprint-block)
1287                           (define-modify-macro pprint-defun)
1288                           (define-setf-expander pprint-defun)
1289                           (defmacro pprint-defun)
1290                           (defparameter pprint-block)
1291                           (defsetf pprint-defun)
1292                           (defstruct pprint-block)
1293                           (deftype pprint-defun)
1294                           (defun pprint-defun)
1295                           (defvar pprint-block)
1296                           (destructuring-bind pprint-destructuring-bind)
1297                           (do pprint-do)
1298                           (do* pprint-do)
1299                           (do-all-symbols pprint-dolist)
1300                           (do-external-symbols pprint-dolist)
1301                           (do-symbols pprint-dolist)
1302                           (dolist pprint-dolist)
1303                           (dotimes pprint-dolist)
1304                           (ecase pprint-case)
1305                           (etypecase pprint-typecase)
1306                           #+nil (handler-bind ...)
1307                           #+nil (handler-case ...)
1308                           #+nil (loop ...)
1309                           (multiple-value-bind pprint-progv)
1310                           (multiple-value-setq pprint-block)
1311                           (pprint-logical-block pprint-block)
1312                           (print-unreadable-object pprint-block)
1313                           (prog pprint-prog)
1314                           (prog* pprint-prog)
1315                           (prog1 pprint-block)
1316                           (prog2 pprint-progv)
1317                           (psetf pprint-setq)
1318                           (psetq pprint-setq)
1319                           #+nil (restart-bind ...)
1320                           #+nil (restart-case ...)
1321                           (setf pprint-setq)
1322                           (step pprint-progn)
1323                           (time pprint-progn)
1324                           (typecase pprint-typecase)
1325                           (unless pprint-block)
1326                           (when pprint-block)
1327                           (with-compilation-unit pprint-block)
1328                           #+nil (with-condition-restarts ...)
1329                           (with-hash-table-iterator pprint-block)
1330                           (with-input-from-string pprint-block)
1331                           (with-open-file pprint-block)
1332                           (with-open-stream pprint-block)
1333                           (with-output-to-string pprint-block)
1334                           (with-package-iterator pprint-block)
1335                           (with-simple-restart pprint-block)
1336                           (with-standard-io-syntax pprint-progn)))
1337
1338       (set-pprint-dispatch `(cons (eql ,(first magic-form)))
1339                            (symbol-function (second magic-form))))
1340
1341     ;; other pretty-print init forms
1342     (/show0 "about to call !BACKQ-PP-COLD-INIT")
1343     (sb!impl::!backq-pp-cold-init)
1344     (/show0 "leaving !PPRINT-COLD-INIT"))
1345
1346   (setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
1347   (setf *pretty-printer* #'output-pretty-object)
1348   (setf *print-pretty* t))