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