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 (defmethod slots-to-inspect ((class slot-class) (object slot-object))
  30   (class-slots class))
  31
  32 (defmethod describe-object ((object slot-object) stream)
  33
  34   (fresh-line stream)
  35
  36   (let* ((class (class-of object))
  37          (slotds (slots-to-inspect class object))
  38          (max-slot-name-length 0)
  39          (instance-slotds ())
  40          (class-slotds ())
  41          (other-slotds ()))
  42
  43     (format stream "~&~@<~S ~_is an instance of class ~S.~:>" object class)
  44
  45     ;; Figure out a good width for the slot-name column.
  46     (flet ((adjust-slot-name-length (name)
  47              (setq max-slot-name-length
  48                    (max max-slot-name-length
  49                         (length (the string (symbol-name name)))))))
  50       (dolist (slotd slotds)
  51         (adjust-slot-name-length (slot-definition-name slotd))
  52         (case (slot-definition-allocation slotd)
  53           (:instance (push slotd instance-slotds))
  54           (:class  (push slotd class-slotds))
  55           (otherwise (push slotd other-slotds))))
  56       (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30)))
  57
  58     ;; Now that we know the width, we can print.
  59     (flet ((describe-slot (name value &optional (allocation () alloc-p))
  60              (if alloc-p
  61                  (format stream
  62                          "~& ~A ~S ~VT  ~S"
  63                          name allocation (+ max-slot-name-length 7) value)
  64                  (format stream
  65                          "~& ~A~VT  ~S"
  66                          name max-slot-name-length value))))
  67       (when instance-slotds
  68         (format stream "~&The following slots have :INSTANCE allocation:")
  69         (dolist (slotd (nreverse instance-slotds))
  70           (describe-slot
  71            (slot-definition-name slotd)
  72            (slot-value-or-default object
  73                                   (slot-definition-name slotd)))))
  74       (when class-slotds
  75         (format stream "~&The following slots have :CLASS allocation:")
  76         (dolist (slotd (nreverse class-slotds))
  77           (describe-slot
  78            (slot-definition-name slotd)
  79            (slot-value-or-default object
  80                                   (slot-definition-name slotd)))))
  81       (when other-slotds
  82         (format stream "~&The following slots have allocation as shown:")
  83         (dolist (slotd (nreverse other-slotds))
  84           (describe-slot
  85            (slot-definition-name slotd)
  86            (slot-value-or-default object
  87                                   (slot-definition-name slotd))
  88            (slot-definition-allocation slotd))))))
  89
  90   (terpri stream))
  91
  92 (defmethod describe-object ((fun standard-generic-function) stream)
  93   (format stream "~&~A is a generic function." fun)
  94   (format stream "~&Its arguments are:~&  ~S"
  95           (generic-function-pretty-arglist fun))
  96   (let ((methods (generic-function-methods fun)))
  97     (if (null methods)
  98         (format stream "~&It has no methods.~%")
  99         (let ((gf-name (generic-function-name fun)))
 100           (format stream "Its methods are:")
 101           (dolist (method methods)
 102             (format stream "~2%    (~A ~{~S ~}~:S) =>"
 103                     gf-name
 104                     (method-qualifiers method)
 105                     (unparse-specializers method))
 106             (describe (or (method-fast-function method)
 107                           (method-function method))
 108                       stream))))))
 109
 110 (defmethod describe-object ((class class) stream)
 111   (flet ((pretty-class (c) (or (class-name c) c)))
 112     (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
 113       (ft "~&~S is a class. It is an instance of ~S."
 114           class (pretty-class (class-of class)))
 115       (let ((name (class-name class)))
 116         (if name
 117             (if (eq class (find-class name nil))
 118                 (ft "~&Its proper name is ~S." name)
 119                 (ft "~&Its name is ~S, but this is not a proper name." name))
 120             (ft "It has no name (the name is NIL).~%")))
 121       (ft "~&~@<The direct superclasses are: ~:S, and the direct~%~
 122            subclasses are: ~:S. The class precedence list is:~2I~_~S~I~_~
 123            There are ~S methods specialized for this class.~:>~%"
 124           (mapcar #'pretty-class (class-direct-superclasses class))
 125           (mapcar #'pretty-class (class-direct-subclasses class))
 126           (mapcar #'pretty-class (class-precedence-list class))
 127           (length (specializer-direct-methods class))))))
 128
 129 (defmethod describe-object ((package package) stream)
 130   (format stream "~&~S is a ~S." package (type-of package))
 131   (format stream
 132           "~@[~&~@<It has nicknames ~2I~{~:_~S~^ ~}~:>~]"
 133           (package-nicknames package))
 134   (let* ((internal (package-internal-symbols package))
 135          (internal-count (- (package-hashtable-size internal)
 136                             (package-hashtable-free internal)))
 137          (external (package-external-symbols package))
 138          (external-count (- (package-hashtable-size external)
 139                             (package-hashtable-free external))))
 140     (format stream
 141             "~&It has ~S internal and ~S external symbols."
 142             internal-count external-count))
 143   (flet (;; Turn a list of packages into something a human likes
 144          ;; to read.
 145          (humanize (package-list)
 146            (sort (mapcar #'package-name package-list) #'string<)))
 147     (format stream
 148             "~@[~&~@<It uses packages named ~2I~{~:_~S~^ ~}~:>~]"
 149             (humanize (package-use-list package)))
 150     (format stream
 151             "~@[~&~@<It is used by packages named ~2I~{~:_~S~^ ~}~:>~]"
 152             (humanize (package-used-by-list package))))
 153   (terpri stream))