src/pcl/print-object.lisp

   1 ;;;; some basic PRINT-OBJECT functionality
   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 software originally released by Xerox
   7 ;;;; Corporation. Copyright and release statements follow. Later modifications
   8 ;;;; to the software are in the public domain and are provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  10 ;;;; information.
  11
  12 ;;;; Some of the text in this file was originally taken from various files of
  13 ;;;; the PCL system from Xerox Corporation, which carried the following
  14 ;;;; copyright information:
  15 ;;;;
  16 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  17 ;;;; All rights reserved.
  18 ;;;;
  19 ;;;; Use and copying of this software and preparation of derivative works based
  20 ;;;; upon this software are permitted. Any distribution of this software or
  21 ;;;; derivative works must comply with all applicable United States export
  22 ;;;; control laws.
  23 ;;;;
  24 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  25 ;;;; warranty about the software, its performance or its conformity to any
  26 ;;;; specification.
  27
  28 (in-package "SB-PCL")
  29 \f
  30 ;;;; the PRINT-OBJECT generic function
  31
  32 ;;; Blow away the old non-generic function placeholder which was used
  33 ;;; by the printer doing bootstrapping, and immediately replace it
  34 ;;; with some new printing logic, so that the Lisp printer stays
  35 ;;; crippled only for the shortest necessary time.
  36 (write-string "; Removing placeholder PRINT-OBJECT ...") (force-output)
  37 (let ((*print-pretty* t)) ; use pretty printer dispatch table, not PRINT-OBJECT
  38   (fmakunbound 'print-object)
  39   (defgeneric print-object (object stream))
  40   (!incorporate-cross-compiled-methods 'print-object))
  41 (write-string " done
  42 ")
  43 \f
  44 ;;;; PRINT-OBJECT methods for objects from PCL classes
  45 ;;;;
  46
  47 (defmethod print-object ((object standard-object) stream)
  48   (print-unreadable-object (object stream :type t :identity t)))
  49
  50 (defmethod print-object ((object funcallable-standard-object) stream)
  51   (print-unreadable-object (object stream :type t :identity t)))
  52
  53 (defmethod print-object ((method standard-method) stream)
  54   (if (slot-boundp method '%generic-function)
  55       (print-unreadable-object (method stream :type t :identity t)
  56         (let ((generic-function (method-generic-function method))
  57               (*print-length* 50))
  58           (format stream "~:[~*~;~/sb-impl::print-symbol-with-prefix/ ~]~{~S ~}~:S"
  59                   generic-function
  60                   (and generic-function
  61                        (generic-function-name generic-function))
  62                   (method-qualifiers method)
  63                   (if generic-function
  64                       (unparse-specializers generic-function (method-specializers method))
  65                       (method-specializers method)))))
  66       (call-next-method)))
  67
  68 (defmethod print-object ((method standard-accessor-method) stream)
  69   (if (slot-boundp method '%generic-function)
  70       (print-unreadable-object (method stream :type t :identity t)
  71         (let ((generic-function (method-generic-function method)))
  72           (format stream "~/sb-impl::print-symbol-with-prefix/, slot:~S, ~:S"
  73                   (and generic-function
  74                        (generic-function-name generic-function))
  75                   (accessor-method-slot-name method)
  76                   (if generic-function
  77                       (unparse-specializers generic-function (method-specializers method))
  78                       (method-specializers method)))))
  79       (call-next-method)))
  80
  81 (defmethod print-object ((mc standard-method-combination) stream)
  82   (print-unreadable-object (mc stream :type t :identity t)
  83     (format stream "~S ~:S"
  84             (slot-value-for-printing mc 'type-name)
  85             (slot-value-for-printing mc 'options))))
  86
  87 (defun named-object-print-function (instance stream
  88                                     &optional (properly-named-p t)
  89                                               (extra nil extra-p))
  90   (cond ((slot-boundp instance 'name) ; case (1): named
  91          (let ((name (slot-value instance 'name)))
  92            (print-unreadable-object
  93                (instance stream :type t :identity (not properly-named-p))
  94              (format stream "~/sb-impl::print-symbol-with-prefix/~:[~:; ~:S~]"
  95                      name extra-p extra))))
  96         ((not extra-p) ; case (2): empty body to avoid an extra space
  97          (print-unreadable-object (instance stream :type t :identity t)))
  98         (t ; case (3). no name, but extra data - show #<unbound slot> and data
  99          (print-unreadable-object (instance stream :type t :identity t)
 100            (format stream "#<unbound slot> ~:S" extra)))))
 101
 102 (defmethod print-object ((class class) stream)
 103   ;; Use a similar concept as in OUTPUT-FUN.
 104   (if (slot-boundp class 'name)
 105       (let* ((name (class-name class))
 106              (proper-p (and (symbolp name) (eq (find-class name nil) class))))
 107         (print-unreadable-object (class stream :type t :identity (not proper-p))
 108           (print-symbol-with-prefix stream name)))
 109       ;; "#<CLASS #<unbound slot> {122D1141}>" is ugly. Don't show that.
 110       (print-unreadable-object (class stream :type t :identity t))))
 111
 112 (defmethod print-object ((slotd slot-definition) stream)
 113   (named-object-print-function slotd stream))
 114
 115 (defmethod print-object ((generic-function standard-generic-function) stream)
 116   (multiple-value-call 'named-object-print-function
 117     generic-function
 118     stream
 119     (and (slot-boundp generic-function 'name)
 120          (let ((name (slot-value generic-function 'name)))
 121            (and (legal-fun-name-p name)
 122                 (fboundp name)
 123                 (eq (fdefinition name) generic-function))))
 124     (if (slot-boundp generic-function 'methods)
 125         (list (length (generic-function-methods generic-function)))
 126         (values))))
 127
 128 (defmethod print-object ((cache cache) stream)
 129   (print-unreadable-object (cache stream :type t :identity t)
 130     (multiple-value-bind (lines-used lines-total max-depth depth-limit)
 131         (cache-statistics cache)
 132       (format stream
 133               "~D key~P, ~:[no value~;value~], ~D/~D lines, depth ~D/~D"
 134               (cache-key-count cache)
 135               (cache-key-count cache)
 136               (cache-value cache)
 137               lines-used
 138               lines-total
 139               max-depth
 140               depth-limit))))
 141
 142 (defmethod print-object ((dfun-info dfun-info) stream)
 143   (declare (type stream stream))
 144   (print-unreadable-object (dfun-info stream :type t :identity t)))
 145
 146 (defmethod print-object ((ctor ctor) stream)
 147   (print-unreadable-object (ctor stream :type t)
 148     (format stream "~S ~:S" (ctor-class-or-name ctor) (ctor-initargs ctor)))
 149   ctor)
 150
 151 (defmethod print-object ((obj class-precedence-description) stream)
 152   (print-unreadable-object (obj stream :type t)
 153     (format stream "~D" (cpd-count obj))))
 154
 155 (defmethod print-object ((self specializer-with-object) stream)
 156   (if (and (slot-exists-p self 'object) (slot-boundp self 'object))
 157       (print-unreadable-object (self stream :type t)
 158         (write (slot-value self 'object) :stream stream))
 159       (print-unreadable-object (self stream :type t :identity t))))
 160
 161 sb-c::
 162 (defmethod print-object ((self policy) stream)
 163   (if *print-readably*
 164       (call-next-method)
 165       (print-unreadable-object (self stream :type t)
 166         (write (policy-to-decl-spec self) :stream stream))))
 167
 168 sb-kernel::(progn
 169 (defmethod print-object ((condition type-error) stream)
 170   (if (and *print-escape*
 171            (slot-boundp condition 'expected-type)
 172            (slot-boundp condition 'datum))
 173       (flet ((maybe-string (thing)
 174                (ignore-errors
 175                  (write-to-string thing :lines 1 :readably nil :array nil :pretty t))))
 176         (let ((type (maybe-string (type-error-expected-type condition)))
 177               (datum (maybe-string (type-error-datum condition))))
 178           (if (and type datum)
 179               (print-unreadable-object (condition stream :type t)
 180                 (format stream "~@<expected-type: ~A ~_datum: ~A~:@>"
 181                         type datum))
 182               (call-next-method))))
 183       (call-next-method)))
 184
 185 (defmethod print-object ((condition cell-error) stream)
 186   (if (and *print-escape* (slot-boundp condition 'name))
 187       (print-unreadable-object (condition stream :type t :identity t)
 188         (princ (cell-error-name condition) stream))
 189       (call-next-method)))
 190
 191 (defmethod print-object :around ((o reference-condition) s)
 192   (call-next-method)
 193   (unless (or *print-escape* *print-readably*)
 194     (when (and *print-condition-references*
 195                (reference-condition-references o))
 196       (format s "~&See also:~%")
 197       (pprint-logical-block (s nil :per-line-prefix "  ")
 198         (do* ((rs (reference-condition-references o) (cdr rs))
 199               (r (car rs) (car rs)))
 200              ((null rs))
 201           (print-reference r s)
 202           (unless (null (cdr rs))
 203             (terpri s)))))))) ; end PROGN
 204
 205 ;;; Ordinary DEFMETHOD should be used from here on out.
 206 ;;; This variable actually has some semantics to being unbound.
 207 ;;; FIXME: see if we can eliminate the associated hack in 'methods.lisp'
 208 (makunbound '*!delayed-defmethod-args*)