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 (/show0 "about to replace placeholder PRINT-OBJECT with DEFGENERIC")
  37 (let (;; (If we don't suppress /SHOW printing while the printer is
  38       ;; crippled here, it becomes really easy to crash the bootstrap
  39       ;; sequence by adding /SHOW statements e.g. to the compiler,
  40       ;; which kinda defeats the purpose of /SHOW being a harmless
  41       ;; tracing-style statement.)
  42       #+sb-show (*/show* nil)
  43       ;; (another workaround for the problem of debugging while the
  44       ;; printer is disabled here)
  45       ;; FIXME: the way to do this is bind print-pprint-dispatch
  46       ;; to an "emergency fallback" table. Give it sane entries for
  47       ;; CONDITION, STRUCTURE-OBJECT, INSTANCE, and T.
  48       ;; Bind *print-pretty* to T for the duration of these forms,
  49       ;; and then we no longer need this extra state variable.
  50       (sb-impl::*print-object-is-disabled-p* t))
  51   (fmakunbound 'print-object)
  52   (defgeneric print-object (object stream))
  53   (defmethod print-object ((x t) stream)
  54     (if *print-pretty*
  55         (pprint-logical-block (stream nil)
  56           (print-unreadable-object (x stream :type t :identity t)))
  57         (print-unreadable-object (x stream :type t :identity t)))))
  58 (/show0 "done replacing placeholder PRINT-OBJECT with DEFGENERIC")
  59 \f
  60 ;;;; a hook called by the printer to take care of dispatching to PRINT-OBJECT
  61 ;;;; for appropriate FUNCALLABLE-INSTANCE objects
  62
  63 ;;; Now that CLOS is working, we can replace our old temporary placeholder code
  64 ;;; for writing funcallable instances with permanent code:
  65 (fmakunbound 'sb-impl::printed-as-funcallable-standard-class)
  66 (defun sb-impl::printed-as-funcallable-standard-class (object stream)
  67   (when (funcallable-standard-class-p (class-of object))
  68     (print-object object stream)
  69     t))
  70 \f
  71 ;;;; PRINT-OBJECT methods for objects from PCL classes
  72 ;;;;
  73
  74 (defmethod print-object ((method standard-method) stream)
  75   (if (slot-boundp method '%generic-function)
  76       (print-unreadable-object (method stream :type t :identity t)
  77         (let ((generic-function (method-generic-function method))
  78               (*print-length* 50))
  79           (format stream "~:[~*~;~/sb-impl::print-symbol-with-prefix/ ~]~{~S ~}~:S"
  80                   generic-function
  81                   (and generic-function
  82                        (generic-function-name generic-function))
  83                   (method-qualifiers method)
  84                   (if generic-function
  85                       (unparse-specializers generic-function (method-specializers method))
  86                       (method-specializers method)))))
  87       (call-next-method)))
  88
  89 (defmethod print-object ((method standard-accessor-method) stream)
  90   (if (slot-boundp method '%generic-function)
  91       (print-unreadable-object (method stream :type t :identity t)
  92         (let ((generic-function (method-generic-function method)))
  93           (format stream "~/sb-impl::print-symbol-with-prefix/, slot:~S, ~:S"
  94                   (and generic-function
  95                        (generic-function-name generic-function))
  96                   (accessor-method-slot-name method)
  97                   (if generic-function
  98                       (unparse-specializers generic-function (method-specializers method))
  99                       (method-specializers method)))))
 100       (call-next-method)))
 101
 102 (defmethod print-object ((mc standard-method-combination) stream)
 103   (print-unreadable-object (mc stream :type t :identity t)
 104     (format stream "~S ~:S"
 105             (slot-value-for-printing mc 'type-name)
 106             (slot-value-for-printing mc 'options))))
 107
 108 (defun named-object-print-function (instance stream
 109                                     &optional (properly-named-p t)
 110                                               (extra nil extra-p))
 111   (cond ((slot-boundp instance 'name) ; case (1): named
 112          (let ((name (slot-value instance 'name)))
 113            (print-unreadable-object
 114                (instance stream :type t :identity (not properly-named-p))
 115              (format stream "~/sb-impl::print-symbol-with-prefix/~:[~:; ~:S~]"
 116                      name extra-p extra))))
 117         ((not extra-p) ; case (2): empty body to avoid an extra space
 118          (print-unreadable-object (instance stream :type t :identity t)))
 119         (t ; case (3). no name, but extra data - show #<unbound slot> and data
 120          (print-unreadable-object (instance stream :type t :identity t)
 121            (format stream "#<unbound slot> ~:S" extra)))))
 122
 123 (defmethod print-object ((class class) stream)
 124   ;; Use a similar concept as in OUTPUT-FUN.
 125   (if (slot-boundp class 'name)
 126       (let* ((name (class-name class))
 127              (proper-p (and (symbolp name) (eq (find-class name nil) class))))
 128         (print-unreadable-object (class stream :type t :identity (not proper-p))
 129           (print-symbol-with-prefix stream name)))
 130       ;; "#<CLASS #<unbound slot> {122D1141}>" is ugly. Don't show that.
 131       (print-unreadable-object (class stream :type t :identity t))))
 132
 133 (defmethod print-object ((slotd slot-definition) stream)
 134   (named-object-print-function slotd stream))
 135
 136 (defmethod print-object ((generic-function standard-generic-function) stream)
 137   (multiple-value-call 'named-object-print-function
 138     generic-function
 139     stream
 140     (and (slot-boundp generic-function 'name)
 141          (let ((name (slot-value generic-function 'name)))
 142            (and (legal-fun-name-p name)
 143                 (fboundp name)
 144                 (eq (fdefinition name) generic-function))))
 145     (if (slot-boundp generic-function 'methods)
 146         (list (length (generic-function-methods generic-function)))
 147         (values))))
 148
 149 (defmethod print-object ((cache cache) stream)
 150   (print-unreadable-object (cache stream :type t :identity t)
 151     (multiple-value-bind (lines-used lines-total max-depth depth-limit)
 152         (cache-statistics cache)
 153       (format stream
 154               "~D key~P, ~:[no value~;value~], ~D/~D lines, depth ~D/~D"
 155               (cache-key-count cache)
 156               (cache-key-count cache)
 157               (cache-value cache)
 158               lines-used
 159               lines-total
 160               max-depth
 161               depth-limit))))
 162
 163 (defmethod print-object ((dfun-info dfun-info) stream)
 164   (declare (type stream stream))
 165   (print-unreadable-object (dfun-info stream :type t :identity t)))
 166
 167 (defmethod print-object ((ctor ctor) stream)
 168   (print-unreadable-object (ctor stream :type t)
 169     (format stream "~S ~:S" (ctor-class-or-name ctor) (ctor-initargs ctor)))
 170   ctor)
 171
 172 (defmethod print-object ((obj class-precedence-description) stream)
 173   (print-unreadable-object (obj stream :type t)
 174     (format stream "~D" (cpd-count obj))))
 175
 176 (defmethod print-object ((self eql-specializer) stream)
 177   (let ((have-obj (slot-boundp self 'object)))
 178     (print-unreadable-object (self stream :type t :identity (not have-obj))
 179       (when have-obj
 180         (write (slot-value self 'object) :stream stream)))))
 181
 182 sb-c::
 183 (defmethod print-object ((self policy) stream)
 184   (if *print-readably*
 185       (call-next-method)
 186       (print-unreadable-object (self stream :type t)
 187         (write (policy-to-decl-spec self) :stream stream))))
 188
 189 (!incorporate-cross-compiled-methods 'print-object :except '(t condition))
 190
 191 ;;; Print-object methods on subtypes of CONDITION can't be cross-compiled
 192 ;;; until CLOS is fully working. Compile them now.
 193 #.`(progn
 194      ,@(mapcar (lambda (args)
 195                  `(setf (slot-value (defmethod ,@(cdr args)) 'source)
 196                         ,(car args)))
 197                *!delayed-defmethod-args*))
 198
 199 ;;; Ordinary DEFMETHOD should be used from here on out.
 200 ;;; This variable actually has some semantics to being unbound.
 201 ;;; FIXME: see if we can eliminate the associated hack in 'methods.lisp'
 202 (makunbound '*!delayed-defmethod-args*)