source: trunk/abcl/src/org/armedbear/lisp/describe.lisp @ 14196

Last change on this file since 14196 was 13554, checked in by ehuelsmann, 9 years ago

Fix DESCRIBE for instances of classes with a custom META-CLASS.

Found by: Blake McBride?

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 6.4 KB
Line 
1;;; describe.lisp
2;;;
3;;; Copyright (C) 2005 Peter Graves
4;;; $Id: describe.lisp 13554 2011-09-02 08:33:43Z ehuelsmann $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package #:system)
33
34(require '#:clos)
35(require '#:format)
36
37(defun describe-arglist (object stream)
38  (multiple-value-bind
39      (arglist known-p)
40      (arglist object)
41    (when known-p
42      (format stream "~&The function's lambda list is:~%  ~A~%" arglist))))
43
44(defun %describe-object (object stream)
45  (format stream "~S is an object of type ~S.~%" object (type-of object)))
46
47(defun describe (object &optional stream)
48  (describe-object object (out-synonym-of stream))
49  (values))
50
51(defmethod describe-object ((object t) stream)
52  (let ((*print-pretty* t))
53    (typecase object
54      (SYMBOL
55       (let ((package (symbol-package object)))
56         (if package
57             (multiple-value-bind
58                 (sym status)
59                 (find-symbol (symbol-name object) package)
60               (format stream "~S is an ~A symbol in the ~A package.~%"
61                       object
62                       (if (eq status :internal) "internal" "external")
63                       (package-name package)))
64             (format stream "~S is an uninterned symbol.~%" object))
65         (cond ((special-variable-p object)
66                (format stream "It is a ~A; "
67                        (if (constantp object) "constant" "special variable"))
68                (if (boundp object)
69                    (format stream "its value is ~S.~%" (symbol-value object))
70                    (format stream "it is unbound.~%")))
71               ((boundp object)
72                (format stream "It is an undefined variable; its value is ~S.~%"
73                        (symbol-value object)))))
74       (when (autoloadp object)
75         (resolve object))
76       (let ((function (and (fboundp object) (symbol-function object))))
77         (when function
78           (format stream "Its function binding is ~S.~%" function)
79           (describe-arglist function stream)))
80       (let ((doc (documentation object 'function)))
81         (when doc
82           (format stream "Function documentation:~%  ~A~%" doc)))
83       (let ((plist (symbol-plist object)))
84         (when plist
85           (format stream "The symbol's property list contains these indicator/value pairs:~%")
86           (loop
87             (when (null plist) (return))
88             (format stream "  ~S ~S~%" (car plist) (cadr plist))
89             (setf plist (cddr plist))))))
90      (FUNCTION
91       (%describe-object object stream)
92       (describe-arglist object stream))
93      (INTEGER
94       (%describe-object object stream)
95       (format stream "~D.~%~
96                       #x~X~%~
97                       #o~O~%~
98                       #b~B~%"
99               object object object object))
100      (t
101       (%describe-object object stream))))
102  (values))
103
104(defmethod describe-object ((object pathname) stream)
105  (format stream "~S is an object of type ~S:~%" object (type-of object))
106  (format stream "  HOST         ~S~%" (pathname-host object))
107  (format stream "  DEVICE       ~S~%" (pathname-device object))
108  (format stream "  DIRECTORY    ~S~%" (pathname-directory object))
109  (format stream "  NAME         ~S~%" (pathname-name object))
110  (format stream "  TYPE         ~S~%" (pathname-type object))
111  (format stream "  VERSION      ~S~%" (pathname-version object)))
112
113(defmethod describe-object ((object standard-object) stream)
114  (let* ((class (class-of object))
115         (slotds (mop:class-slots class))
116         (max-slot-name-length 0)
117         (instance-slotds ())
118         (class-slotds ()))
119    (format stream "~S is an instance of ~S.~%" object class)
120    (dolist (slotd slotds)
121      (let* ((name (%slot-definition-name slotd))
122             (length (length (symbol-name name))))
123        (when (> length max-slot-name-length)
124          (setf max-slot-name-length length)))
125      (case (%slot-definition-allocation slotd)
126        (:instance (push slotd instance-slotds))
127        (:class  (push slotd class-slotds))))
128    (setf max-slot-name-length  (min (+ max-slot-name-length 3) 30))
129    (flet ((describe-slot (slot-name)
130             (if (slot-boundp object slot-name)
131                 (format stream
132                         "~&  ~A~VT  ~S"
133                         slot-name max-slot-name-length (slot-value object slot-name))
134                 (format stream
135                         "~&  ~A~VT  unbound"
136                         slot-name max-slot-name-length))))
137      (when instance-slotds
138        (format stream "The following slots have :INSTANCE allocation:~%")
139        (dolist (slotd (nreverse instance-slotds))
140          (describe-slot
141           (%slot-definition-name slotd))))
142        (format stream "~%")
143      (when class-slotds
144        (format stream "The following slots have :CLASS allocation:~%")
145        (dolist (slotd (nreverse class-slotds))
146          (describe-slot
147           (%slot-definition-name slotd)))
148        (format stream "~%"))))
149    (values))
150
151(defmethod describe-object ((object java:java-object) stream)
152  (java:describe-java-object object stream))
Note: See TracBrowser for help on using the repository browser.