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
29 (defmethod slots-to-inspect ((class slot-class) (object slot-object))
32 (defmethod describe-object ((object slot-object) stream)
36 (let* ((class (class-of object))
37 (slotds (slots-to-inspect class object))
38 (max-slot-name-length 0)
43 (format stream "~&~@<~S ~_is an instance of class ~S.~:>" object class)
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)))
58 ;; Now that we know the width, we can print.
59 (flet ((describe-slot (name value &optional (allocation () alloc-p))
63 name allocation (+ max-slot-name-length 7) value)
66 name max-slot-name-length value))))
68 (format stream "~&The following slots have :INSTANCE allocation:")
69 (dolist (slotd (nreverse instance-slotds))
71 (slot-definition-name slotd)
72 (slot-value-or-default object
73 (slot-definition-name slotd)))))
75 (format stream "~&The following slots have :CLASS allocation:")
76 (dolist (slotd (nreverse class-slotds))
78 (slot-definition-name slotd)
79 (slot-value-or-default object
80 (slot-definition-name slotd)))))
82 (format stream "~&The following slots have allocation as shown:")
83 (dolist (slotd (nreverse other-slotds))
85 (slot-definition-name slotd)
86 (slot-value-or-default object
87 (slot-definition-name slotd))
88 (slot-definition-allocation slotd))))))
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)))
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) =>"
104 (method-qualifiers method)
105 (unparse-specializers method))
106 (describe (or (method-fast-function method)
107 (method-function method))
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)))
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.~@:>"
121 (ft "~&~@<It has no name (the name is NIL).~@:>")))
122 (ft "~&~@<The direct superclasses are: ~:S, and the direct ~
123 subclasses are: ~:S.~I~_The class is ~:[not ~;~]finalized~
124 ~:[. ~;; its class precedence list is:~2I~_~:*~S.~]~I~_~
125 There ~[are~;is~:;are~] ~:*~S method~:P specialized for ~
127 (mapcar #'pretty-class (class-direct-superclasses class))
128 (mapcar #'pretty-class (class-direct-subclasses class))
129 (class-finalized-p class)
130 (mapcar #'pretty-class (cpl-or-nil class))
131 (length (specializer-direct-methods class))))))
133 (defmethod describe-object ((package package) stream)
134 (format stream "~&~S is a ~S." package (type-of package))
136 "~@[~&~@<It has nicknames ~2I~{~:_~S~^ ~}~:>~]"
137 (package-nicknames package))
138 (let* ((internal (package-internal-symbols package))
139 (internal-count (- (package-hashtable-size internal)
140 (package-hashtable-free internal)))
141 (external (package-external-symbols package))
142 (external-count (- (package-hashtable-size external)
143 (package-hashtable-free external))))
145 "~&It has ~S internal and ~S external symbols."
146 internal-count external-count))
147 (flet (;; Turn a list of packages into something a human likes
149 (humanize (package-list)
150 (sort (mapcar #'package-name package-list) #'string<)))
152 "~@[~&~@<It uses packages named ~2I~{~:_~S~^ ~}~:>~]"
153 (humanize (package-use-list package)))
155 "~@[~&~@<It is used by packages named ~2I~{~:_~S~^ ~}~:>~]"
156 (humanize (package-used-by-list package))))