src/code/host-pprint.lisp

   1 ;;;; Common Lisp pretty printer definitions that need to be on the
   2 ;;;; host
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!PRETTY")
  14
  15 ;; This comes early so that fndb can use PPRINT-DISPATCH-TABLE as
  16 ;; a type-specifier.
  17 (sb!xc:defstruct (pprint-dispatch-table
  18                   (:conc-name pp-dispatch-)
  19                   (:constructor make-pprint-dispatch-table (&optional entries))
  20                   (:copier nil) ; needs a deep copy
  21                   (:predicate nil))
  22   ;; A list of all the entries (except for CONS entries below) in highest
  23   ;; to lowest priority.
  24   (entries nil :type list)
  25   ;; A hash table mapping things to entries for type specifiers of the
  26   ;; form (CONS (MEMBER <thing>)). If the type specifier is of this form,
  27   ;; we put it in this hash table instead of the regular entries table.
  28   (cons-entries (make-hash-table :test 'eql) :read-only t)
  29   ;; NIL if this this table can't match any numeric type.
  30   ;; The conservative value is T.
  31   (number-matchable-p nil))
  32
  33 (declaim (freeze-type pprint-dispatch-table))
  34
  35 #+sb-xc
  36 (defmethod print-object ((table pprint-dispatch-table) stream)
  37   (print-unreadable-object (table stream :type t :identity t)))
  38
  39 ;;; These structures are mutually referential and we want to compile their
  40 ;;; type-checks efficiently. Essentially the way to do that is define
  41 ;;; each structure during both make-host passes. This is a KLUDGE.
  42
  43 (sb!xc:deftype posn () 'fixnum)
  44
  45 (sb!xc:defstruct (queued-op (:constructor nil)
  46                             (:copier nil))
  47   (posn 0 :type posn))
  48
  49 (sb!xc:defstruct (block-end (:include queued-op)
  50                             (:copier nil))
  51   (suffix nil :type (or null simple-string)))
  52
  53 (sb!xc:defstruct (section-start (:include queued-op)
  54                                 (:constructor nil)
  55                                 (:copier nil))
  56   (depth 0 :type index)
  57   (section-end nil :type (or null newline block-end)))
  58
  59 (sb!xc:defstruct (newline (:include section-start)
  60                           (:copier nil))
  61   (kind (missing-arg)
  62         :type (member :linear :fill :miser :literal :mandatory)))