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 (unless (sb-impl::!c-runtime-noinform-p)
  37   (write-string "; Removing placeholder PRINT-OBJECT ...")
  38   (force-output))
  39 (let ((*print-pretty* t)) ; use pretty printer dispatch table, not PRINT-OBJECT
  40   (fmakunbound 'print-object)
  41   (defgeneric print-object (object stream))
  42   (!install-cross-compiled-methods 'print-object))
  43 (unless (sb-impl::!c-runtime-noinform-p)
  44   (write-string " done
  45 "))
  46 \f
  47 ;;;; PRINT-OBJECT methods for objects from PCL classes
  48 ;;;;
  49
  50 (defmethod print-object ((object standard-object) stream)
  51   (print-unreadable-object (object stream :type t :identity t)))
  52
  53 (defmethod print-object ((object funcallable-standard-object) stream)
  54   (print-unreadable-object (object stream :type t :identity t)))
  55
  56 (defmethod print-object ((method standard-method) stream)
  57   (if (slot-boundp method '%generic-function)
  58       (print-unreadable-object (method stream :type t :identity t)
  59         (let ((generic-function (method-generic-function method))
  60               (*print-length* 50))
  61           (format stream "~:[~*~;~/sb-ext:print-symbol-with-prefix/ ~]~{~S ~}~:S"
  62                   generic-function
  63                   (and generic-function
  64                        (generic-function-name generic-function))
  65                   (method-qualifiers method)
  66                   (if generic-function
  67                       (unparse-specializers generic-function (method-specializers method))
  68                       (method-specializers method)))))
  69       (call-next-method)))
  70
  71 (defmethod print-object ((method standard-accessor-method) stream)
  72   (if (slot-boundp method '%generic-function)
  73       (print-unreadable-object (method stream :type t :identity t)
  74         (let ((generic-function (method-generic-function method)))
  75           (format stream "~/sb-ext:print-symbol-with-prefix/, slot:~S, ~:S"
  76                   (and generic-function
  77                        (generic-function-name generic-function))
  78                   (accessor-method-slot-name method)
  79                   (if generic-function
  80                       (unparse-specializers generic-function (method-specializers method))
  81                       (method-specializers method)))))
  82       (call-next-method)))
  83
  84 (defmethod print-object ((mc standard-method-combination) stream)
  85   (print-unreadable-object (mc stream :type t :identity t)
  86     (format stream "~S ~:S"
  87             (slot-value-for-printing mc 'type-name)
  88             (slot-value-for-printing mc 'options))))
  89
  90 (defun named-object-print-function (instance stream
  91                                     &optional (properly-named-p t)
  92                                               (extra nil extra-p))
  93   (cond ((slot-boundp instance 'name) ; case (1): named
  94          (let ((name (slot-value instance 'name)))
  95            (print-unreadable-object
  96                (instance stream :type t :identity (not properly-named-p))
  97              (format stream "~/sb-ext:print-symbol-with-prefix/~:[~:; ~:S~]"
  98                      name extra-p extra))))
  99         ((not extra-p) ; case (2): empty body to avoid an extra space
 100          (print-unreadable-object (instance stream :type t :identity t)))
 101         (t ; case (3). no name, but extra data - show #<unbound slot> and data
 102          (print-unreadable-object (instance stream :type t :identity t)
 103            (format stream "#<unbound slot> ~:S" extra)))))
 104
 105 (defmethod print-object ((class class) stream)
 106   ;; Use a similar concept as in OUTPUT-FUN.
 107   (if (slot-boundp class 'name)
 108       (let* ((name (class-name class))
 109              (proper-p (and (symbolp name) (eq (find-class name nil) class))))
 110         (print-unreadable-object (class stream :type t :identity (not proper-p))
 111           (print-symbol-with-prefix stream name)))
 112       ;; "#<CLASS #<unbound slot> {122D1141}>" is ugly. Don't show that.
 113       (print-unreadable-object (class stream :type t :identity t))))
 114
 115 (defmethod print-object ((slotd slot-definition) stream)
 116   (named-object-print-function slotd stream))
 117
 118 (defmethod print-object ((generic-function standard-generic-function) stream)
 119   (multiple-value-call 'named-object-print-function
 120     generic-function
 121     stream
 122     (and (slot-boundp generic-function 'name)
 123          (let ((name (slot-value generic-function 'name)))
 124            (and (legal-fun-name-p name)
 125                 (fboundp name)
 126                 (eq (fdefinition name) generic-function))))
 127     (if (slot-boundp generic-function 'methods)
 128         (list (length (generic-function-methods generic-function)))
 129         (values))))
 130
 131 (defmethod print-object ((cache cache) stream)
 132   (print-unreadable-object (cache stream :type t :identity t)
 133     (multiple-value-bind (lines-used lines-total) (cache-statistics cache)
 134       (format stream
 135               "~D key~:P~:[~;, value~], ~D/~D lines~@[ (LF ~,,2F%)~], depth ~D/~D"
 136               (cache-key-count cache)
 137               (cache-value cache)
 138               lines-used
 139               lines-total
 140               (when (plusp lines-total) (/ lines-used lines-total))
 141               (cache-depth cache)
 142               (cache-limit cache)))))
 143
 144 (defmethod print-object ((dfun-info dfun-info) stream)
 145   (declare (type stream stream))
 146   (print-unreadable-object (dfun-info stream :type t :identity t)))
 147
 148 (defmethod print-object ((ctor ctor) stream)
 149   (print-unreadable-object (ctor stream :type t)
 150     (format stream "~S ~:S" (ctor-class-or-name ctor) (ctor-initargs ctor)))
 151   ctor)
 152
 153 (defmethod print-object ((obj class-precedence-description) stream)
 154   (print-unreadable-object (obj stream :type t)
 155     (format stream "~D" (cpd-count obj))))
 156
 157 (defmethod print-object ((self specializer-with-object) stream)
 158   (if (and (slot-exists-p self 'object) (slot-boundp self 'object))
 159       (print-unreadable-object (self stream :type t)
 160         (write (slot-value self 'object) :stream stream))
 161       (print-unreadable-object (self stream :type t :identity t))))
 162
 163 sb-c::
 164 (defmethod print-object ((self policy) stream)
 165   (if *print-readably*
 166       (call-next-method)
 167       (print-unreadable-object (self stream :type t)
 168         (write (policy-to-decl-spec self) :stream stream))))
 169
 170 sb-kernel::(progn
 171 (defmethod print-object ((condition type-error) stream)
 172   (if (and *print-escape*
 173            (slot-boundp condition 'expected-type)
 174            (slot-boundp condition 'datum))
 175       (flet ((maybe-string (thing)
 176                (ignore-errors
 177                  (write-to-string thing :lines 1 :readably nil :array nil :pretty t))))
 178         (let ((type (maybe-string (type-error-expected-type condition)))
 179               (datum (maybe-string (type-error-datum condition))))
 180           (if (and type datum)
 181               (print-unreadable-object (condition stream :type t)
 182                 (format stream "~@<expected-type: ~A ~_datum: ~A~:@>"
 183                         type datum))
 184               (call-next-method))))
 185       (call-next-method)))
 186
 187 (defmethod print-object ((condition cell-error) stream)
 188   (if (and *print-escape* (slot-boundp condition 'name))
 189       (print-unreadable-object (condition stream :type t :identity t)
 190         (princ (cell-error-name condition) stream))
 191       (call-next-method)))
 192
 193 (defmethod print-object :around ((o reference-condition) s)
 194   (call-next-method)
 195   (unless (or *print-escape* *print-readably*)
 196     (when (and *print-condition-references*
 197                (reference-condition-references o))
 198       (format s "~&See also:~%")
 199       (pprint-logical-block (s nil :per-line-prefix "  ")
 200         (do* ((rs (reference-condition-references o) (cdr rs))
 201               (r (car rs) (car rs)))
 202              ((null rs))
 203           (print-reference r s)
 204           (unless (null (cdr rs))
 205             (terpri s)))))))) ; end PROGN
 206
 207 ;;; Ordinary DEFMETHOD should be used from here on out.
 208 ;;; This variable actually has some semantics to being unbound.
 209 ;;; FIXME: see if we can eliminate the associated hack in 'methods.lisp'
 210 (makunbound '*!delayed-defmethod-args*)