0.6.12.24:
[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 (declaim #.*optimize-byte-compilation*)
30
31 (defmethod slots-to-inspect ((class slot-class) (object slot-object))
32   (class-slots class))
33
34 (defmethod describe-object ((object slot-object) 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     (flet ((adjust-slot-name-length (name)
44              (setq max-slot-name-length
45                    (max max-slot-name-length
46                         (length (the string (symbol-name name))))))
47            (describe-slot (name value &optional (allocation () alloc-p))
48              (if alloc-p
49                  (format stream
50                          "~% ~A ~S ~VT  ~S"
51                          name allocation (+ max-slot-name-length 7) value)
52                  (format stream
53                          "~% ~A~VT  ~S"
54                          name max-slot-name-length value))))
55
56       ;; Figure out a good width for the slot-name column.
57       (dolist (slotd slotds)
58         (adjust-slot-name-length (slot-definition-name slotd))
59         (case (slot-definition-allocation slotd)
60           (:instance (push slotd instance-slotds))
61           (:class  (push slotd class-slotds))
62           (otherwise (push slotd other-slotds))))
63       (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))
64       (format stream "~%~@<~S ~_is an instance of class ~S.~:>" object class)
65
66       ;; Now that we know the width, we can print.
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 (defvar *describe-metaobjects-as-objects-p* nil)
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   (format stream "Its methods are:")
97   (dolist (method (generic-function-methods fun))
98     (format stream "~2%    ~{~S ~}~:S =>~%"
99             (method-qualifiers method)
100             (unparse-specializers method))
101     (describe-object (or (method-fast-function method)
102                          (method-function method))
103                      stream))
104   (when *describe-metaobjects-as-objects-p*
105     (call-next-method)))
106
107 (defmethod describe-object ((class class) stream)
108   (flet ((pretty-class (c) (or (class-name c) c)))
109     (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
110       (ft "~&~S is a class, it is an instance of ~S.~%"
111           class (pretty-class (class-of class)))
112       (let ((name (class-name class)))
113         (if name
114             (if (eq class (find-class name nil))
115                 (ft "Its proper name is ~S.~%" name)
116                 (ft "Its name is ~S, but this is not a proper name.~%" name))
117             (ft "It has no name (the name is NIL).~%")))
118       (ft "The direct superclasses are: ~:S, and the direct~%~
119            subclasses are: ~:S. The class precedence list is:~%~S~%~
120            There are ~D methods specialized for this class."
121           (mapcar #'pretty-class (class-direct-superclasses class))
122           (mapcar #'pretty-class (class-direct-subclasses class))
123           (mapcar #'pretty-class (class-precedence-list class))
124           (length (specializer-direct-methods class)))))
125   (when *describe-metaobjects-as-objects-p*
126     (call-next-method)))
127
128 (defmethod describe-object ((package package) stream)
129   (pprint-logical-block (stream nil)
130     (format stream "~&~S is a ~S." package (type-of package))
131     (format stream
132             "~@[~&It has nicknames ~{~:_~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     (format stream
144             "~@[~&It uses ~{~:_~S~^ ~}~]"
145             (package-use-list package))
146     (format stream
147             "~@[~&It is used by ~{~:_~S~^ ~}~]"
148             (package-used-by-list package))))