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."))