src/pcl/describe.lisp

   1 ;;;; that part of the DESCRIBE mechanism which is based on code from
   2 ;;;; PCL
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6
   7 ;;;; This software is derived from software originally released by Xerox
   8 ;;;; Corporation. Copyright and release statements follow. Later modifications
   9 ;;;; to the software are in the public domain and are provided with
  10 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  11 ;;;; information.
  12
  13 ;;;; copyright information from original PCL sources:
  14 ;;;;
  15 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  16 ;;;; All rights reserved.
  17 ;;;;
  18 ;;;; Use and copying of this software and preparation of derivative works based
  19 ;;;; upon this software are permitted. Any distribution of this software or
  20 ;;;; derivative works must comply with all applicable United States export
  21 ;;;; control laws.
  22 ;;;;
  23 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  24 ;;;; warranty about the software, its performance or its conformity to any
  25 ;;;; specification.
  26
  27 (in-package "SB-PCL")
  28
  29 (sb-int:file-comment
  30   "$Header$")
  31
  32 (defmethod slots-to-inspect ((class slot-class) (object slot-object))
  33   (class-slots class))
  34
  35 (defmethod describe-object ((object slot-object) stream)
  36
  37   (let* ((class (class-of object))
  38          (slotds (slots-to-inspect class object))
  39          (max-slot-name-length 0)
  40          (instance-slotds ())
  41          (class-slotds ())
  42          (other-slotds ()))
  43
  44     (flet ((adjust-slot-name-length (name)
  45              (setq max-slot-name-length
  46                    (max max-slot-name-length
  47                         (length (the string (symbol-name name))))))
  48            (describe-slot (name value &optional (allocation () alloc-p))
  49              (if alloc-p
  50                  (format stream
  51                          "~% ~A ~S ~VT  ~S"
  52                          name allocation (+ max-slot-name-length 7) value)
  53                  (format stream
  54                          "~% ~A~VT  ~S"
  55                          name max-slot-name-length value))))
  56
  57       ;; Figure out a good width for the slot-name column.
  58       (dolist (slotd slotds)
  59         (adjust-slot-name-length (slot-definition-name slotd))
  60         (case (slot-definition-allocation slotd)
  61           (:instance (push slotd instance-slotds))
  62           (:class  (push slotd class-slotds))
  63           (otherwise (push slotd other-slotds))))
  64       (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))
  65       (format stream "~%~S is an instance of class ~S." object class)
  66
  67       ;; Now that we know the width, we can print.
  68       (when instance-slotds
  69         (format stream "~% The following slots have :INSTANCE allocation:")
  70         (dolist (slotd (nreverse instance-slotds))
  71           (describe-slot
  72            (slot-definition-name slotd)
  73            (slot-value-or-default object
  74                                   (slot-definition-name slotd)))))
  75       (when class-slotds
  76         (format stream "~% The following slots have :CLASS allocation:")
  77         (dolist (slotd (nreverse class-slotds))
  78           (describe-slot
  79            (slot-definition-name slotd)
  80            (slot-value-or-default object
  81                                   (slot-definition-name slotd)))))
  82       (when other-slotds
  83         (format stream "~% The following slots have allocation as shown:")
  84         (dolist (slotd (nreverse other-slotds))
  85           (describe-slot
  86            (slot-definition-name slotd)
  87            (slot-value-or-default object
  88                                   (slot-definition-name slotd))
  89            (slot-definition-allocation slotd)))))))
  90
  91 (defvar *describe-metaobjects-as-objects-p* nil)
  92
  93 (defmethod describe-object ((fun standard-generic-function) stream)
  94   (format stream "~A is a generic function.~%" fun)
  95   (format stream "Its arguments are:~%  ~S~%"
  96           (generic-function-pretty-arglist fun))
  97   (format stream "Its methods are:")
  98   (dolist (method (generic-function-methods fun))
  99     (format stream "~2%    ~{~S ~}~:S =>~%"
 100             (method-qualifiers method)
 101             (unparse-specializers method))
 102     (describe-object (or (method-fast-function method)
 103                          (method-function method))
 104                      stream))
 105   (when *describe-metaobjects-as-objects-p*
 106     (call-next-method)))
 107
 108 (defmethod describe-object ((class class) stream)
 109   (flet ((pretty-class (c) (or (class-name c) c)))
 110     (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
 111       (ft "~&~S is a class, it is an instance of ~S.~%"
 112           class (pretty-class (class-of class)))
 113       (let ((name (class-name class)))
 114         (if name
 115             (if (eq class (find-class name nil))
 116                 (ft "Its proper name is ~S.~%" name)
 117                 (ft "Its name is ~S, but this is not a proper name.~%" name))
 118             (ft "It has no name (the name is NIL).~%")))
 119       (ft "The direct superclasses are: ~:S, and the direct~%~
 120            subclasses are: ~:S. The class precedence list is:~%~S~%~
 121            There are ~D methods specialized for this class."
 122           (mapcar #'pretty-class (class-direct-superclasses class))
 123           (mapcar #'pretty-class (class-direct-subclasses class))
 124           (mapcar #'pretty-class (class-precedence-list class))
 125           (length (specializer-direct-methods class)))))
 126   (when *describe-metaobjects-as-objects-p*
 127     (call-next-method)))
 128
 129 (defmethod describe-object ((package package) stream)
 130   (pprint-logical-block (stream nil)
 131     (format stream "~&~S is a ~S." package (type-of package))
 132     (format stream
 133             "~@[~&It has nicknames ~{~:_~S~^ ~}~]"
 134             (package-nicknames package))
 135     (let* ((internal (sb-impl::package-internal-symbols package))
 136            (internal-count (- (sb-impl::package-hashtable-size internal)
 137                               (sb-impl::package-hashtable-free internal)))
 138            (external (sb-impl::package-external-symbols package))
 139            (external-count (- (sb-impl::package-hashtable-size external)
 140                               (sb-impl::package-hashtable-free external))))
 141       (format stream
 142               "~&It has ~S internal and ~S external symbols."
 143               internal-count external-count))
 144     (format stream
 145             "~@[~&It uses ~{~:_~S~^ ~}~]"
 146             (package-use-list package))
 147     (format stream
 148             "~@[~&It is used by ~{~:_~S~^ ~}~]"
 149             (package-used-by-list package))))