source: branches/streams/abcl/src/org/armedbear/lisp/describe.lisp

Last change on this file was 14478, checked in by rschlatte, 12 years ago

remove Java-side accessor primitives from SlotDefinition?.java

  • Replaced %slot-definition-name, %slot-definition-initfunction, %slot-definition-initform, %slot-definition-initargs, %slot-definition-readers, %slot-definition-writers, %slot-definition-allocation, %slot-definition-allocation-class, %slot-definition-location, %slot-definition-type, %slot-definition-documentation and the corresponding writers with direct slot accesses
  • *FASL-VERSION* increased since old fasls contain calls to slot accessors
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 6.6 KB
Line 
1;;; describe.lisp
2;;;
3;;; Copyright (C) 2005 Peter Graves
4;;; $Id: describe.lisp 14478 2013-04-24 12:51:14Z rschlatte $
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(defun %describe-standard-object/funcallable (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 (mop: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 (mop: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           (mop: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           (mop:slot-definition-name slotd)))
148        (format stream "~%")))))
149
150(defmethod describe-object ((object standard-object) stream)
151  (%describe-standard-object/funcallable object stream)
152  (values))
153
154(defmethod describe-object ((object mop:funcallable-standard-object) stream)
155  (%describe-standard-object/funcallable object stream)
156  (values))
157
158(defmethod describe-object ((object java:java-object) stream)
159  (java:describe-java-object object stream))
Note: See TracBrowser for help on using the repository browser.