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 (file-comment
  15   "$Header$")
  16 \f
  17 ;;;; utilities
  18
  19 (defmacro with-pretty-stream ((stream-var
  20                                &optional (stream-expression stream-var))
  21                               &body body)
  22   (let ((flet-name (gensym "WITH-PRETTY-STREAM-")))
  23     `(flet ((,flet-name (,stream-var)
  24               ,@body))
  25        (let ((stream ,stream-expression))
  26          (if (pretty-stream-p stream)
  27              (,flet-name stream)
  28              (catch 'line-limit-abbreviation-happened
  29                (let ((stream (make-pretty-stream stream)))
  30                  (,flet-name stream)
  31                  (force-pretty-output stream)))))
  32        nil)))
  33 \f
  34 ;;;; user interface to the pretty printer
  35
  36 (defmacro pprint-logical-block ((stream-symbol
  37                                  object
  38                                  &key
  39                                  prefix
  40                                  per-line-prefix
  41                                  (suffix ""))
  42                                 &body body)
  43   #!+sb-doc
  44   "Group some output into a logical block. STREAM-SYMBOL should be either a
  45    stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer
  46    control variable *PRINT-LEVEL* is automatically handled."
  47   (when (and prefix per-line-prefix)
  48     (error "cannot specify both PREFIX and a PER-LINE-PREFIX values"))
  49   (multiple-value-bind (stream-var stream-expression)
  50       (case stream-symbol
  51         ((nil)
  52          (values '*standard-output* '*standard-output*))
  53         ((t)
  54          (values '*terminal-io* '*terminal-io*))
  55         (t
  56          (values stream-symbol
  57                  (once-only ((stream stream-symbol))
  58                    `(case ,stream
  59                       ((nil) *standard-output*)
  60                       ((t) *terminal-io*)
  61                       (t ,stream))))))
  62     (let* ((object-var (if object (gensym) nil))
  63            (block-name (gensym "PPRINT-LOGICAL-BLOCK-"))
  64            (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
  65            (pp-pop-name (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             `(descend-into (,stream-var)
  73                (let ((,count-name 0))
  74                  (declare (type index ,count-name) (ignorable ,count-name))
  75                  (start-logical-block ,stream-var
  76                                       (the (or null string)
  77                                         ,(or prefix per-line-prefix))
  78                                       ,(if per-line-prefix t nil)
  79                                       (the string ,suffix))
  80                  (block ,block-name
  81                    (flet ((,pp-pop-name ()
  82                             ,@(when object
  83                                 `((unless (listp ,object-var)
  84                                     (write-string ". " ,stream-var)
  85                                     (output-object ,object-var ,stream-var)
  86                                     (return-from ,block-name nil))))
  87                             (when (and (not *print-readably*)
  88                                        (eql ,count-name *print-length*))
  89                               (write-string "..." ,stream-var)
  90                               (return-from ,block-name nil))
  91                             ,@(when object
  92                                 `((when (and ,object-var
  93                                              (plusp ,count-name)
  94                                              (check-for-circularity
  95                                               ,object-var))
  96                                     (write-string ". " ,stream-var)
  97                                     (output-object ,object-var ,stream-var)
  98                                     (return-from ,block-name nil))))
  99                             (incf ,count-name)
 100                             ,@(when object
 101                                 `((pop ,object-var)))))
 102                      (declare (ignorable #',pp-pop-name))
 103                      (macrolet ((pprint-pop ()
 104                                   '(,pp-pop-name))
 105                                 (pprint-exit-if-list-exhausted ()
 106                                   ,(if object
 107                                        `'(when (null ,object-var)
 108                                            (return-from ,block-name nil))
 109                                        `'(return-from ,block-name nil))))
 110                        ,@body)))
 111                  ;; FIXME: Don't we need UNWIND-PROTECT to ensure this
 112                  ;; always gets executed?
 113                  (end-logical-block ,stream-var)))))
 114       (when object
 115         (setf body
 116               `(let ((,object-var ,object))
 117                  (if (listp ,object-var)
 118                      ,body
 119                      (output-object ,object-var ,stream-var)))))
 120       `(with-pretty-stream (,stream-var ,stream-expression)
 121          ,body))))
 122
 123 (defmacro pprint-exit-if-list-exhausted ()
 124   #!+sb-doc
 125   "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
 126    if its list argument is exhausted. Can only be used inside
 127    PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
 128    PPRINT-LOGICAL-BLOCK is supplied."
 129   (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
 130           PPRINT-LOGICAL-BLOCK."))
 131
 132 (defmacro pprint-pop ()
 133   #!+sb-doc
 134   "Return the next element from LIST argument to the closest enclosing
 135    use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
 136    and *PRINT-CIRCLE*. Can only be used inside PPRINT-LOGICAL-BLOCK.
 137    If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
 138    is popped, but the *PRINT-LENGTH* testing still happens."
 139   (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))