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 \f
  14 ;;;; utilities
  15
  16 (defmacro with-pretty-stream ((stream-var
  17                                &optional (stream-expression stream-var))
  18                               &body body)
  19   (let ((flet-name (sb!xc:gensym "WITH-PRETTY-STREAM")))
  20     `(flet ((,flet-name (,stream-var)
  21               ,@body))
  22        (let ((stream ,stream-expression))
  23          (if (pretty-stream-p stream)
  24              (,flet-name stream)
  25              (catch 'line-limit-abbreviation-happened
  26                (let ((stream (make-pretty-stream stream)))
  27                  (,flet-name stream)
  28                  (force-pretty-output stream)))))
  29        nil)))
  30 \f
  31 ;;;; user interface to the pretty printer
  32
  33 (defmacro pprint-logical-block ((stream-symbol
  34                                  object
  35                                  &key
  36                                  (prefix nil prefixp)
  37                                  (per-line-prefix nil per-line-prefix-p)
  38                                  (suffix "" suffixp))
  39                                 &body body)
  40   #!+sb-doc
  41   "Group some output into a logical block. STREAM-SYMBOL should be either a
  42    stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer
  43    control variable *PRINT-LEVEL* is automatically handled."
  44   (let ((prefix (cond ((and prefixp per-line-prefix-p)
  45                        (error "cannot specify values for both PREFIX and PER-LINE-PREFIX."))
  46                       (prefixp prefix)
  47                       (per-line-prefix-p per-line-prefix))))
  48     (let ((object-var (if object (gensym) nil)))
  49       (once-only ((prefix-var prefix) (suffix-var suffix))
  50         (multiple-value-bind (stream-var stream-expression)
  51             (case stream-symbol
  52               ((nil)
  53                (values '*standard-output* '*standard-output*))
  54               ((t)
  55                (values '*terminal-io* '*terminal-io*))
  56               (t
  57                (values stream-symbol
  58                        (once-only ((stream stream-symbol))
  59                          `(case ,stream
  60                             ((nil) *standard-output*)
  61                             ((t) *terminal-io*)
  62                             (t ,stream))))))
  63           (let* ((block-name (sb!xc:gensym "PPRINT-LOGICAL-BLOCK-"))
  64                  (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
  65                  (pp-pop-name (sb!xc:gensym "PPRINT-POP-"))
  66                  (body
  67                   ;; FIXME: It looks as though PPRINT-LOGICAL-BLOCK might
  68                   ;; expand into a boatload of code, since DESCEND-INTO is a
  69                   ;; macro too. It might be worth looking at this to make
  70                   ;; sure it's not too bloated, since PPRINT-LOGICAL-BLOCK
  71                   ;; is called many times from system pretty-printing code.
  72                   ;;
  73                   ;; FIXME: I think pprint-logical-block is broken wrt
  74                   ;; argument order, multiple evaluation, etc. of its
  75                   ;; keyword (:PREFIX, :PER-LINE-PREFIX and :SUFFIX)
  76                   ;; arguments.  Dunno if that's legal.
  77                   `(descend-into (,stream-var)
  78                      (let ((,count-name 0))
  79                        (declare (type index ,count-name) (ignorable ,count-name))
  80                        ,@(when (or prefixp per-line-prefix-p)
  81                                `((declare (string ,prefix-var))))
  82                        ,@(when (and suffixp)
  83                                `((declare (string ,suffix-var))))
  84                        (start-logical-block ,stream-var
  85                                             ,prefix-var
  86                                             ,(if per-line-prefix-p t nil)
  87                                             ,suffix-var)
  88                        (block ,block-name
  89                          (flet ((,pp-pop-name ()
  90                                   ,@(when object
  91                                      `((unless (listp-for-pprint ,object-var)
  92                                          (return-from ,block-name
  93                                            (%pprint-dotted-tail ,object-var
  94                                                                 ,stream-var)))))
  95                                   (when (and (not *print-readably*)
  96                                              (eql ,count-name *print-length*))
  97                                     (write-string "..." ,stream-var)
  98                                     (return-from ,block-name nil))
  99                                   ,@(when object
 100                                           `((when (and ,object-var
 101                                                        (plusp ,count-name)
 102                                                        (check-for-circularity
 103                                                         ,object-var
 104                                                         nil
 105                                                         :logical-block))
 106                                               (write-string ". " ,stream-var)
 107                                               (output-object ,object-var ,stream-var)
 108                                               (return-from ,block-name nil))))
 109                                   (incf ,count-name)
 110                                   ,@(if object
 111                                         `((pop ,object-var))
 112                                         `(nil))))
 113                            (declare (ignorable (function ,pp-pop-name)))
 114                            (locally
 115                                (declare (disable-package-locks
 116                                          pprint-pop pprint-exit-if-list-exhausted))
 117                              (macrolet ((pprint-pop ()
 118                                           '(,pp-pop-name))
 119                                         (pprint-exit-if-list-exhausted ()
 120                                           ,(if object
 121                                                `'(when (null ,object-var)
 122                                                   (return-from ,block-name nil))
 123                                                `'(return-from ,block-name nil))))
 124                                (declare (enable-package-locks
 125                                          pprint-pop pprint-exit-if-list-exhausted))
 126                                ,@body))))
 127                        ;; FIXME: Don't we need UNWIND-PROTECT to ensure this
 128                        ;; always gets executed?
 129                        (end-logical-block ,stream-var)))))
 130             (when object
 131               (setf body
 132                     `(let ((,object-var ,object))
 133                        (if (listp ,object-var)
 134                            (with-circularity-detection (,object-var ,stream-var)
 135                              ,body)
 136                            (output-object ,object-var ,stream-var)))))
 137             `(with-pretty-stream (,stream-var ,stream-expression)
 138                ,body)))))))
 139
 140 (defmacro pprint-exit-if-list-exhausted ()
 141   #!+sb-doc
 142   "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
 143    if its list argument is exhausted. Can only be used inside
 144    PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
 145    PPRINT-LOGICAL-BLOCK is supplied."
 146   (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
 147           PPRINT-LOGICAL-BLOCK."))
 148
 149 (defmacro pprint-pop ()
 150   #!+sb-doc
 151   "Return the next element from LIST argument to the closest enclosing
 152    use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
 153    and *PRINT-CIRCLE*. Can only be used inside PPRINT-LOGICAL-BLOCK.
 154    If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
 155    is popped, but the *PRINT-LENGTH* testing still happens."
 156   (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))
 157
 158 ;; utilities needed by PPRINT-POP
 159 ;; Consider (A . `(,B C)) = (A QUASIQUOTE ,B C)
 160 ;; We have to detect this and print as the form on the left since pretty commas
 161 ;; with no containing #\` will fail at read-time due to a nesting error.
 162 ;; There isn't an equivalent of *BACKQUOTE-DEPTH* for output streams so we
 163 ;; can't revert to printing the comma as #S(SB-IMPL::COMMA ...)
 164 (declaim (inline listp-for-pprint))
 165 (defun listp-for-pprint (x)
 166   (and (listp x) (not (and (eq (car x) 'quasiquote) (singleton-p (cdr x))))))
 167 (defun %pprint-dotted-tail (obj stream)
 168   (write-string ". " stream)
 169   (output-object obj stream)
 170   nil)