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       (sb-impl::*print-object-is-disabled-p* t))
  46   (fmakunbound 'print-object)
  47   (defgeneric print-object (object stream))
  48   (defmethod print-object ((x t) stream)
  49     (if *print-pretty*
  50         (pprint-logical-block (stream nil)
  51           (print-unreadable-object (x stream :type t :identity t)))
  52         (print-unreadable-object (x stream :type t :identity t)))))
  53 (/show0 "done replacing placeholder PRINT-OBJECT with DEFGENERIC")
  54 \f
  55 ;;;; a hook called by the printer to take care of dispatching to PRINT-OBJECT
  56 ;;;; for appropriate FUNCALLABLE-INSTANCE objects
  57
  58 ;;; Now that CLOS is working, we can replace our old temporary placeholder code
  59 ;;; for writing funcallable instances with permanent code:
  60 (defun sb-impl::printed-as-funcallable-standard-class (object stream)
  61   (when (funcallable-standard-class-p (class-of object))
  62     (print-object object stream)
  63     t))
  64 \f
  65 ;;;; PRINT-OBJECT methods for objects from PCL classes
  66 ;;;;
  67 ;;;; FIXME: Perhaps these should be moved back alongside the definitions of
  68 ;;;; the classes they print. (Bootstrapping problems could be avoided by
  69 ;;;; using DEF!METHOD to do this.)
  70
  71 (defmethod print-object ((method standard-method) stream)
  72   (print-unreadable-object (method stream :type t :identity t)
  73     (if (slot-boundp method '%generic-function)
  74         (let ((generic-function (method-generic-function method)))
  75           (format stream "~S ~{~S ~}~:S"
  76                   (and generic-function
  77                        (generic-function-name generic-function))
  78                   (method-qualifiers method)
  79                   (if generic-function
  80                       (unparse-specializers generic-function (method-specializers method))
  81                       (method-specializers method))))
  82         ;; FIXME: Why do we do CALL-NEXT-METHOD in this method (and
  83         ;; in the PRINT-OBJECT STANDARD-ACCESSOR-METHOD method too)?
  84         (call-next-method))))
  85
  86 (defmethod print-object ((method standard-accessor-method) stream)
  87   (print-unreadable-object (method stream :type t :identity t)
  88     (if (slot-boundp method '%generic-function)
  89         (let ((generic-function (method-generic-function method)))
  90           (format stream "~S, slot:~S, ~:S"
  91                   (and generic-function
  92                        (generic-function-name generic-function))
  93                   (accessor-method-slot-name method)
  94                   (if generic-function
  95                       (unparse-specializers generic-function (method-specializers method))
  96                       (method-specializers method))))
  97         (call-next-method))))
  98
  99 (defmethod print-object ((mc standard-method-combination) stream)
 100   (print-unreadable-object (mc stream :type t :identity t)
 101     (format stream
 102             "~S ~S"
 103             (slot-value-or-default mc 'type-name)
 104             (slot-value-or-default mc 'options))))
 105
 106 (defun named-object-print-function (instance stream
 107                                     &optional (extra nil extra-p))
 108   (let ((name (slot-value-or-default instance 'name)))
 109     (print-unreadable-object (instance stream :type t :identity (not name))
 110       (if extra-p
 111           (format stream "~S ~:S" name extra)
 112           (format stream "~S" name)))))
 113
 114 (defmethod print-object ((class class) stream)
 115   (named-object-print-function class stream))
 116
 117 (defmethod print-object ((slotd slot-definition) stream)
 118   (named-object-print-function slotd stream))
 119
 120 (defmethod print-object ((generic-function standard-generic-function) stream)
 121   (named-object-print-function
 122     generic-function
 123     stream
 124     (if (slot-boundp generic-function 'methods)
 125         (list (length (generic-function-methods generic-function)))
 126         "?")))
 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 ((wrapper wrapper) stream)
 143   (print-unreadable-object (wrapper stream :type t :identity t)
 144     (prin1 (wrapper-class wrapper) stream)))
 145
 146 (defmethod print-object ((dfun-info dfun-info) stream)
 147   (declare (type stream stream))
 148   (print-unreadable-object (dfun-info stream :type t :identity t)))
 149
 150 (defmethod print-object ((ctor ctor) stream)
 151   (print-unreadable-object (ctor stream :type t)
 152     (format stream "~S ~:S" (ctor-class-or-name ctor) (ctor-initargs ctor)))
 153   ctor)