0.8.21.1:
[sbcl.git] / 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   (when (documentation fun t)
95     (format stream "~&Its documentation is: ~A" (documentation fun t)))
96   (format stream "~&Its lambda-list is:~&  ~S"
97           (generic-function-pretty-arglist fun))
98   (format stream "~&Its method-combination is:~&  ~S"
99           (generic-function-method-combination fun))
100   (let ((methods (generic-function-methods fun)))
101     (if (null methods)
102         (format stream "~&It has no methods.~%")
103         (let ((gf-name (generic-function-name fun)))
104           (format stream "~&Its methods are:")
105           (dolist (method methods)
106             (format stream "~&  (~A ~{~S ~}~:S)~%"
107                     gf-name
108                     (method-qualifiers method)
109                     (unparse-specializers method))
110             (when (documentation method t)
111               (format stream "~&    Method documentation: ~A"
112                       (documentation method t))))))))
113
114 (defmethod describe-object ((class class) stream)
115   (flet ((pretty-class (c) (or (class-name c) c)))
116     (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
117       (ft "~&~@<~S is a class. It is an instance of ~S.~:@>"
118           class (pretty-class (class-of class)))
119       (let ((name (class-name class)))
120         (if name
121             (if (eq class (find-class name nil))
122                 (ft "~&~@<Its proper name is ~S.~@:>" name)
123                 (ft "~&~@<Its name is ~S, but this is not a proper name.~@:>"
124                     name))
125             (ft "~&~@<It has no name (the name is NIL).~@:>")))
126       (ft "~&~@<The direct superclasses are: ~:S, and the direct ~
127            subclasses are: ~:S.~I~_The class is ~:[not ~;~]finalized~
128            ~:[. ~;; its class precedence list is:~2I~_~:*~S.~]~I~_~
129            There ~[are~;is~:;are~] ~:*~S method~:P specialized for ~
130            this class.~:@>~%"
131           (mapcar #'pretty-class (class-direct-superclasses class))
132           (mapcar #'pretty-class (class-direct-subclasses class))
133           (class-finalized-p class)
134           (mapcar #'pretty-class (cpl-or-nil class))
135           (length (specializer-direct-methods class))))))
136
137 (defmethod describe-object ((package package) stream)
138   (format stream "~&~S is a ~S." package (type-of package))
139   (format stream
140           "~@[~&~@<It has nicknames ~2I~{~:_~S~^ ~}~:>~]"
141           (package-nicknames package))
142   (let* ((internal (package-internal-symbols package))
143          (internal-count (- (package-hashtable-size internal)
144                             (package-hashtable-free internal)))
145          (external (package-external-symbols package))
146          (external-count (- (package-hashtable-size external)
147                             (package-hashtable-free external))))
148     (format stream
149             "~&It has ~S internal and ~S external symbols."
150             internal-count external-count))
151   (flet (;; Turn a list of packages into something a human likes
152          ;; to read.
153          (humanize (package-list)
154            (sort (mapcar #'package-name package-list) #'string<)))
155     (format stream
156             "~@[~&~@<It uses packages named ~2I~{~:_~S~^ ~}~:>~]"
157             (humanize (package-use-list package)))
158     (format stream
159             "~@[~&~@<It is used by packages named ~2I~{~:_~S~^ ~}~:>~]"
160             (humanize (package-used-by-list package))))
161   (terpri stream))