src/code/early-pprint.lisp

   1 ;;;; pretty printer stuff which has to be defined early (e.g. DEFMACROs)
   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 ;;;; user interface to the pretty printer
  15
  16 (defmacro pprint-logical-block ((stream-symbol
  17                                  object
  18                                  &rest keys
  19                                  &key (prefix nil prefixp)
  20                                       (per-line-prefix nil per-line-prefix-p)
  21                                       (suffix ""))
  22                                 &body body)
  23   "Group some output into a logical block. STREAM-SYMBOL should be either a
  24    stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer
  25    control variable *PRINT-LEVEL* is automatically handled."
  26   (let ((prefix (cond ((and prefixp per-line-prefix-p)
  27                        (error "cannot specify values for both PREFIX and PER-LINE-PREFIX."))
  28                       (prefixp prefix)
  29                       (per-line-prefix-p per-line-prefix)))
  30         (proc (make-symbol "PPRINT-BLOCK"))
  31         (list (and object (make-symbol "LIST")))
  32         (state (make-symbol "STATE"))
  33         (stream-var (case stream-symbol
  34                       ((nil) '*standard-output*)
  35                       ((t) '*terminal-io*)
  36                       (t stream-symbol)))
  37         (bindings))
  38     ;; This is not a function, but to the degree possible should have usual
  39     ;; evaluation order. No bothering with duplicated keyword args,
  40     ;; or :allow-other-keys nonsense.
  41     (unless (and (constantp prefix) (constantp suffix))
  42       (loop (multiple-value-bind (indicator value tail)
  43                 (get-properties keys '(:prefix :per-line-prefix :suffix))
  44               (if (not indicator) (return))
  45               (setq keys (cddr tail))
  46               (unless (assoc indicator bindings :test 'string=) ; dup
  47                 (let ((tmp (copy-symbol indicator)))
  48                   (setq bindings (nconc bindings (list (list tmp value))))
  49                   (if (eq indicator :suffix)
  50                       (setq suffix tmp)
  51                       (setq prefix tmp))))))
  52       (when object
  53         (let ((tmp (make-symbol "OBJ")))
  54           (setq bindings (acons tmp (list object) bindings) object tmp))))
  55     `(dx-flet ((,proc (,@(and list (list list)) ,state ,stream-var)
  56                  (declare (ignorable ,@(and list (list list))
  57                                       ,state ,stream-var))
  58                  (declare (disable-package-locks pprint-exit-if-list-exhausted
  59                                                  pprint-pop))
  60                  (macrolet ,(if object
  61                                 `((pprint-exit-if-list-exhausted ()
  62                                     '(when (null ,list) (return-from ,proc)))
  63                                   (pprint-pop ()
  64                                     '(if (pprint-length-check ,list ,state)
  65                                          (pop ,list)
  66                                          (return-from ,proc))))
  67                                 `((pprint-exit-if-list-exhausted ()
  68                                     '(return-from ,proc))
  69                                   (pprint-pop ()
  70                                     '(if (pprint-length-check* ,state)
  71                                          nil
  72                                          (return-from ,proc)))))
  73                    (declare (enable-package-locks pprint-exit-if-list-exhausted
  74                                                   pprint-pop))
  75                    ,@body)))
  76        (let ,bindings
  77          (call-logical-block-printer #',proc ,stream-symbol
  78                                      ,prefix ,per-line-prefix-p ,suffix
  79                                      ,@(if object (list object)))))))
  80
  81 (defmacro pprint-exit-if-list-exhausted ()
  82   "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
  83    if its list argument is exhausted. Can only be used inside
  84    PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
  85    PPRINT-LOGICAL-BLOCK is supplied."
  86   (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
  87           PPRINT-LOGICAL-BLOCK."))
  88
  89 (defmacro pprint-pop ()
  90   "Return the next element from LIST argument to the closest enclosing
  91    use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
  92    and *PRINT-CIRCLE*. Can only be used inside PPRINT-LOGICAL-BLOCK.
  93    If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
  94    is popped, but the *PRINT-LENGTH* testing still happens."
  95   (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))
  96
  97 ;;;; pretty streams
  98
  99 ;;; There are three different units for measuring character positions:
 100 ;;;  COLUMN - offset (if characters) from the start of the current line
 101 ;;;  INDEX  - index into the output buffer
 102 ;;;  POSN   - some position in the stream of characters cycling through
 103 ;;;           the output buffer
 104 (deftype column ()
 105   '(and fixnum unsigned-byte))
 106
 107 (defconstant initial-buffer-size 128)
 108
 109 (defconstant default-line-length 80)
 110
 111 ;; We're allowed to DXify the pretty-stream used by PPRINT-LOGICAL-BLOCK.
 112 ;;   "pprint-logical-block and the pretty printing stream it creates have
 113 ;;    dynamic extent. The consequences are undefined if, outside of this
 114 ;;    extent, output is attempted to the pretty printing stream it creates."
 115 ;; However doing that is slightly dangerous since there are a zillion ways
 116 ;; for users to get a hold of the stream and stash it somewhere.
 117 ;; Anyway, just a thought... Maybe keep a small handful in a recyclable list?
 118 (defstruct (pretty-stream (:include ansi-stream
 119                                     (out #'pretty-out)
 120                                     (sout #'pretty-sout)
 121                                     (misc #'pretty-misc))
 122                           (:constructor make-pretty-stream (target))
 123                           (:copier nil))
 124   ;; Where the output is going to finally go.
 125   (target (missing-arg) :type stream :read-only t)
 126   ;; Line length we should format to. Cached here so we don't have to keep
 127   ;; extracting it from the target stream.
 128   (line-length (or *print-right-margin*
 129                    (sb!impl::line-length target)
 130                    default-line-length)
 131                :type column
 132                :read-only t)
 133   ;; If non-nil, a function to call before performing OUT or SOUT
 134   (char-out-oneshot-hook nil :type (or null function))
 135   ;; A simple string holding all the text that has been output but not yet
 136   ;; printed.
 137   (buffer (make-string initial-buffer-size) :type (simple-array character (*)))
 138   ;; The index into BUFFER where more text should be put.
 139   (buffer-fill-pointer 0 :type index)
 140   ;; Whenever we output stuff from the buffer, we shift the remaining noise
 141   ;; over. This makes it difficult to keep references to locations in
 142   ;; the buffer. Therefore, we have to keep track of the total amount of
 143   ;; stuff that has been shifted out of the buffer.
 144   (buffer-offset 0 :type posn)
 145   ;; The column the first character in the buffer will appear in. Normally
 146   ;; zero, but if we end up with a very long line with no breaks in it we
 147   ;; might have to output part of it. Then this will no longer be zero.
 148   (buffer-start-column (or (sb!impl::charpos target) 0) :type column)
 149   ;; The line number we are currently on. Used for *PRINT-LINES*
 150   ;; abbreviations and to tell when sections have been split across
 151   ;; multiple lines.
 152   (line-number 0 :type index)
 153   ;; the value of *PRINT-LINES* captured at object creation time. We
 154   ;; use this, instead of the dynamic *PRINT-LINES*, to avoid
 155   ;; weirdness like
 156   ;;   (let ((*print-lines* 50))
 157   ;;     (pprint-logical-block ..
 158   ;;       (dotimes (i 10)
 159   ;;         (let ((*print-lines* 8))
 160   ;;           (print (aref possiblybigthings i) prettystream)))))
 161   ;; terminating the output of the entire logical blockafter 8 lines.
 162   (print-lines *print-lines* :type (or index null) :read-only t)
 163   ;; Stack of logical blocks in effect at the buffer start.
 164   (blocks (list (make-logical-block)) :type list)
 165   ;; Buffer holding the per-line prefix active at the buffer start.
 166   ;; Indentation is included in this. The length of this is stored
 167   ;; in the logical block stack.
 168   (prefix (make-string initial-buffer-size) :type (simple-array character (*)))
 169   ;; Buffer holding the total remaining suffix active at the buffer start.
 170   ;; The characters are right-justified in the buffer to make it easier
 171   ;; to output the buffer. The length is stored in the logical block
 172   ;; stack.
 173   (suffix (make-string initial-buffer-size) :type (simple-array character (*)))
 174   ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
 175   ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
 176   ;; cons. Adding things to the queue is basically (setf (cdr head) (list
 177   ;; new)) and removing them is basically (pop tail) [except that care must
 178   ;; be taken to handle the empty queue case correctly.]
 179   (queue-tail nil :type list)
 180   (queue-head nil :type list)
 181   ;; Block-start queue entries in effect at the queue head.
 182   (pending-blocks nil :type list))