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                                 &environment env)
  41   #!+sb-doc
  42   "Group some output into a logical block. STREAM-SYMBOL should be either a
  43    stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer
  44    control variable *PRINT-LEVEL* is automatically handled."
  45   (when (and prefixp per-line-prefix-p)
  46     (error "cannot specify values for both PREFIX and PER-LINE-PREFIX."))
  47   (multiple-value-bind (stream-var stream-expression)
  48       (case stream-symbol
  49         ((nil)
  50          (values '*standard-output* '*standard-output*))
  51         ((t)
  52          (values '*terminal-io* '*terminal-io*))
  53         (t
  54          (values stream-symbol
  55                  (once-only ((stream stream-symbol))
  56                    `(case ,stream
  57                       ((nil) *standard-output*)
  58                       ((t) *terminal-io*)
  59                       (t ,stream))))))
  60     (let* ((object-var (if object (gensym) nil))
  61            (block-name (sb!xc:gensym "PPRINT-LOGICAL-BLOCK-"))
  62            (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
  63            (pp-pop-name (sb!xc:gensym "PPRINT-POP-"))
  64            (body
  65             ;; FIXME: It looks as though PPRINT-LOGICAL-BLOCK might
  66             ;; expand into a boatload of code, since DESCEND-INTO is a
  67             ;; macro too. It might be worth looking at this to make
  68             ;; sure it's not too bloated, since PPRINT-LOGICAL-BLOCK
  69             ;; is called many times from system pretty-printing code.
  70             ;;
  71             ;; FIXME: I think pprint-logical-block is broken wrt
  72             ;; argument order, multiple evaluation, etc. of its
  73             ;; keyword (:PREFIX, :PER-LINE-PREFIX and :SUFFIX)
  74             ;; arguments.  Dunno if that's legal.
  75             `(descend-into (,stream-var)
  76                (let ((,count-name 0))
  77                  (declare (type index ,count-name) (ignorable ,count-name))
  78                  ,@(when (and (or prefixp per-line-prefix-p)
  79                               (not (sb!int:constant-typep
  80                                     (or prefix per-line-prefix)
  81                                     'string
  82                                     env)))
  83                      `((unless (typep ,(or prefix per-line-prefix) 'string)
  84                          (error 'type-error
  85                                 :datum ,(or prefix per-line-prefix)
  86                                 :expected-type 'string))))
  87                  ,@(when (and suffixp
  88                               (not (sb!int:constant-typep suffix 'string env)))
  89                      `((unless (typep ,suffix 'string)
  90                          (error 'type-error
  91                                 :datum ,suffix
  92                                 :expected-type 'string))))
  93                  (start-logical-block ,stream-var
  94                                       ,(if (or prefixp per-line-prefix-p)
  95                                            (or prefix per-line-prefix)
  96                                            nil)
  97                                       ,(if per-line-prefix-p t nil)
  98                                       ,suffix)
  99                  (block ,block-name
 100                    (flet ((,pp-pop-name ()
 101                             ,@(when object
 102                                 `((unless (listp ,object-var)
 103                                     (write-string ". " ,stream-var)
 104                                     (output-object ,object-var ,stream-var)
 105                                     (return-from ,block-name nil))))
 106                             (when (and (not *print-readably*)
 107                                        (eql ,count-name *print-length*))
 108                               (write-string "..." ,stream-var)
 109                               (return-from ,block-name nil))
 110                             ,@(when object
 111                                 `((when (and ,object-var
 112                                              (plusp ,count-name)
 113                                              (check-for-circularity
 114                                               ,object-var
 115                                               nil
 116                                               :logical-block))
 117                                     (write-string ". " ,stream-var)
 118                                     (output-object ,object-var ,stream-var)
 119                                     (return-from ,block-name nil))))
 120                             (incf ,count-name)
 121                             ,@(if object
 122                                   `((pop ,object-var))
 123                                   `(nil))))
 124                      (declare (ignorable (function ,pp-pop-name)))
 125                      (locally
 126                          (declare (disable-package-locks
 127                                    pprint-pop pprint-exit-if-list-exhausted))
 128                        (macrolet ((pprint-pop ()
 129                                     '(,pp-pop-name))
 130                                   (pprint-exit-if-list-exhausted ()
 131                                     ,(if object
 132                                          `'(when (null ,object-var)
 133                                             (return-from ,block-name nil))
 134                                          `'(return-from ,block-name nil))))
 135                          (declare (enable-package-locks
 136                                    pprint-pop pprint-exit-if-list-exhausted))
 137                          ,@body))))
 138                  ;; FIXME: Don't we need UNWIND-PROTECT to ensure this
 139                  ;; always gets executed?
 140                  (end-logical-block ,stream-var)))))
 141       (when object
 142         (setf body
 143               `(let ((,object-var ,object))
 144                  (if (listp ,object-var)
 145                      (with-circularity-detection (,object-var ,stream-var)
 146                        ,body)
 147                      (output-object ,object-var ,stream-var)))))
 148       `(with-pretty-stream (,stream-var ,stream-expression)
 149          ,body))))
 150
 151 (defmacro pprint-exit-if-list-exhausted ()
 152   #!+sb-doc
 153   "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
 154    if its list argument is exhausted. Can only be used inside
 155    PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
 156    PPRINT-LOGICAL-BLOCK is supplied."
 157   (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
 158           PPRINT-LOGICAL-BLOCK."))
 159
 160 (defmacro pprint-pop ()
 161   #!+sb-doc
 162   "Return the next element from LIST argument to the closest enclosing
 163    use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
 164    and *PRINT-CIRCLE*. Can only be used inside PPRINT-LOGICAL-BLOCK.
 165    If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
 166    is popped, but the *PRINT-LENGTH* testing still happens."
 167   (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))