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