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