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 (sb-int:file-comment
  29   "$Header$")
  30
  31 (in-package "SB-PCL")
  32 \f
  33 ;;;; the PRINT-OBJECT generic function
  34
  35 ;;; Blow away the old non-generic function placeholder which was used by the
  36 ;;; printer doing bootstrapping, and immediately replace it with some new
  37 ;;; printing logic, so that the Lisp printer stays crippled only for the
  38 ;;; shortest necessary time.
  39 (let (;; (If we don't suppress /SHOW printing while the printer is
  40       ;; crippled here, it becomes really easy to crash the bootstrap
  41       ;; sequence by adding /SHOW statements e.g. to the compiler,
  42       ;; which kinda defeats the purpose of /SHOW being a harmless
  43       ;; tracing-style statement.)
  44       #+sb-show (sb-int:*/show* nil))
  45   (fmakunbound 'print-object)
  46   (defgeneric print-object (object stream))
  47   (defmethod print-object ((x t) stream)
  48     (print-unreadable-object (x stream :type t :identity t))))
  49 \f
  50 ;;;; a hook called by the printer to take care of dispatching to PRINT-OBJECT
  51 ;;;; for appropriate FUNCALLABLE-INSTANCE objects
  52
  53 ;;; Now that CLOS is working, we can replace our old temporary placeholder code
  54 ;;; for writing funcallable instances with permanent code:
  55 (defun sb-impl::printed-as-funcallable-standard-class (object stream)
  56   (when (funcallable-standard-class-p (class-of object))
  57     (print-object object stream)
  58     t))
  59 \f
  60 ;;;; PRINT-OBJECT methods for objects from PCL classes
  61 ;;;;
  62 ;;;; FIXME: Perhaps these should be moved back alongside the definitions of
  63 ;;;; the classes they print. (Bootstrapping problems could be avoided by
  64 ;;;; using DEF!METHOD to do this.)
  65
  66 (defmethod print-object ((method standard-method) stream)
  67   (print-unreadable-object (method stream :type t :identity t)
  68     (if (slot-boundp method 'generic-function)
  69         (let ((generic-function (method-generic-function method)))
  70           (format stream "~S ~{~S ~}~:S"
  71                   (and generic-function
  72                        (generic-function-name generic-function))
  73                   (method-qualifiers method)
  74                   (unparse-specializers method)))
  75         ;; FIXME: Why do we do CALL-NEXT-METHOD in this method (and
  76         ;; in the PRINT-OBJECT STANDARD-ACCESSOR-METHOD method too)?
  77         (call-next-method))))
  78
  79 (defmethod print-object ((method standard-accessor-method) stream)
  80   (print-unreadable-object (method stream :type t :identity t)
  81     (if (slot-boundp method 'generic-function)
  82         (let ((generic-function (method-generic-function method)))
  83           (format stream "~S, slot:~S, ~:S"
  84                   (and generic-function
  85                        (generic-function-name generic-function))
  86                   (accessor-method-slot-name method)
  87                   (unparse-specializers method)))
  88         (call-next-method))))
  89
  90 (defmethod print-object ((mc standard-method-combination) stream)
  91   (print-unreadable-object (mc stream :type t :identity t)
  92     (format stream
  93             "~S ~S"
  94             (slot-value-or-default mc 'type)
  95             (slot-value-or-default mc 'options))))
  96
  97 (defun named-object-print-function (instance stream
  98                                     &optional (extra nil extra-p))
  99   (print-unreadable-object (instance stream :type t)
 100     (if extra-p
 101         (format stream
 102                 "~S ~:S"
 103                 (slot-value-or-default instance 'name)
 104                 extra)
 105         (format stream
 106                 "~S"
 107                 (slot-value-or-default instance 'name)))))
 108
 109 (defmethod print-object ((class class) stream)
 110   (named-object-print-function class stream))
 111
 112 (defmethod print-object ((slotd slot-definition) stream)
 113   (named-object-print-function slotd stream))
 114
 115 (defmethod print-object ((generic-function generic-function) stream)
 116   (named-object-print-function
 117     generic-function
 118     stream
 119     (if (slot-boundp generic-function 'methods)
 120         (list (length (generic-function-methods generic-function)))
 121         "?")))
 122
 123 (defmethod print-object ((constructor constructor) stream)
 124   (print-unreadable-object (constructor stream :type t :identity t)
 125     (format stream
 126             "~S (~S)"
 127             (slot-value-or-default constructor 'name)
 128             (slot-value-or-default constructor 'code-type))))
 129
 130 (defmethod print-object ((cache cache) stream)
 131   (print-unreadable-object (cache stream :type t :identity t)
 132     (format stream
 133             "~D ~S ~D"
 134             (cache-nkeys cache)
 135             (cache-valuep cache)
 136             (cache-nlines cache))))
 137
 138 (defmethod print-object ((wrapper wrapper) stream)
 139   (print-unreadable-object (wrapper stream :type t :identity t)
 140     (prin1 (wrapper-class wrapper) stream)))
 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)))