src/code/pprint.lisp

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