src/code/early-print.lisp

   1 ;;;; 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!IMPL")
  13
  14 (file-comment
  15   "$Header$")
  16 \f
  17 ;;;; level and length abbreviations
  18
  19 (defvar *current-level* 0
  20   #!+sb-doc
  21   "The current level we are printing at, to be compared against *PRINT-LEVEL*.
  22    See the macro DESCEND-INTO for a handy interface to depth abbreviation.")
  23
  24 (defmacro descend-into ((stream) &body body)
  25   #!+sb-doc
  26   "Automatically handle *PRINT-LEVEL* abbreviation. If we are too deep, then
  27    a # is printed to STREAM and BODY is ignored."
  28   (let ((flet-name (gensym)))
  29     `(flet ((,flet-name ()
  30               ,@body))
  31        (cond ((and (null *print-readably*)
  32                    *print-level*
  33                    (>= *current-level* *print-level*))
  34               (write-char #\# ,stream))
  35              (t
  36               (let ((*current-level* (1+ *current-level*)))
  37                 (,flet-name)))))))
  38
  39 (defmacro punt-if-too-long (index stream)
  40   #!+sb-doc
  41   "Punt if INDEX is equal or larger then *PRINT-LENGTH* (and *PRINT-READABLY*
  42    is NIL) by outputting \"...\" and returning from the block named NIL."
  43   `(when (and (not *print-readably*)
  44               *print-length*
  45               (>= ,index *print-length*))
  46      (write-string "..." ,stream)
  47      (return)))