1 ;;;; that part of the DESCRIBE mechanism which is based on code from
4 ;;;; This software is part of the SBCL system. See the README file for
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
13 ;;;; copyright information from original PCL sources:
15 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
16 ;;;; All rights reserved.
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
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
32 (defmethod slots-to-inspect ((class slot-class) (object slot-object))
35 (defmethod describe-object ((object slot-object) stream)
37 (let* ((class (class-of object))
38 (slotds (slots-to-inspect class object))
39 (max-slot-name-length 0)
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))
52 name allocation (+ max-slot-name-length 7) value)
55 name max-slot-name-length value))))
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)
67 ;; Now that we know the width, we can print.
69 (format stream "~% The following slots have :INSTANCE allocation:")
70 (dolist (slotd (nreverse instance-slotds))
72 (slot-definition-name slotd)
73 (slot-value-or-default object
74 (slot-definition-name slotd)))))
76 (format stream "~% The following slots have :CLASS allocation:")
77 (dolist (slotd (nreverse class-slotds))
79 (slot-definition-name slotd)
80 (slot-value-or-default object
81 (slot-definition-name slotd)))))
83 (format stream "~% The following slots have allocation as shown:")
84 (dolist (slotd (nreverse other-slotds))
86 (slot-definition-name slotd)
87 (slot-value-or-default object
88 (slot-definition-name slotd))
89 (slot-definition-allocation slotd)))))))
91 (defvar *describe-metaobjects-as-objects-p* nil)
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))
105 (when *describe-metaobjects-as-objects-p*
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)))
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*
129 (defmethod describe-object ((package package) stream)
130 (pprint-logical-block (stream nil)
131 (format stream "~&~S is a ~S." package (type-of package))
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))))
142 "~&It has ~S internal and ~S external symbols."
143 internal-count external-count))
145 "~@[~&It uses ~{~:_~S~^ ~}~]"
146 (package-use-list package))
148 "~@[~&It is used by ~{~:_~S~^ ~}~]"
149 (package-used-by-list package))))