/[mcclim]/mcclim/describe.lisp
ViewVC logotype

Contents of /mcclim/describe.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Mon Dec 20 15:48:30 2004 UTC (9 years, 4 months ago) by bhaible
Branch: MAIN
CVS Tags: mcclim-0-9-4, McCLIM-0-9-5, McCLIM-0-9-4, McCLIM-0-9-6, McCLIM-0-9-1, McCLIM-0-9-3, McCLIM-0-9-2, HEAD
Changes since 1.10: +2 -1 lines
(describe-object@symbol): Add CLISP support.
1 ;;; -*- Mode: Lisp; Package: COMMON-LISP -*-
2
3 ;;; (c) copyright 2002 by Michael McDonald (mikemac@mikemac.com)
4
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Library General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 2 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Library General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Library General Public
16 ;;; License along with this library; if not, write to the
17 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;;; Boston, MA 02111-1307 USA.
19
20 (in-package :clim-lisp)
21
22 (defun describe (thing &optional stream)
23 (if (null stream)
24 (setq stream *standard-output*)
25 (if (eq stream t)
26 (setq stream *terminal-io*)))
27 (describe-object thing stream)
28 (values))
29
30
31 (defgeneric describe-object (thing stream))
32
33 ;;; For these methods, stream should be of type
34 ;;; (or EXTENDED-OUTPUT-STREAM OUTPUT-RECORDING-STREAM)
35 ;;; but CLIM-STREAM-PANE is used instead.
36
37 (clim-internals::with-system-redefinition-allowed
38 (defmethod describe-object ((thing t) stream)
39 (let ((*print-array* nil))
40 (clim:present thing (clim:presentation-type-of thing)
41 :stream stream)
42 (format stream " is of type ")
43 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
44 :stream stream)
45 (terpri stream)))
46 )
47
48 (defmethod describe-object ((thing symbol) stream)
49 (clim:present thing (clim:presentation-type-of thing)
50 :stream stream)
51 (format stream " is of type ")
52 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
53 :stream stream)
54 (terpri stream)
55 (cond
56 ((not (boundp thing))
57 (format stream " it is unbound~%"))
58 (t
59 (format stream " it has a value of ")
60 (clim:present (symbol-value thing) (clim:presentation-type-of (symbol-value thing))
61 :stream stream)
62 (terpri)))
63 (format stream " it is in the ")
64 (clim:present (symbol-package thing) (clim:presentation-type-of (symbol-package thing))
65 :stream stream)
66 (format stream " package~%")
67 (when (fboundp thing)
68 (format stream " it has a function definition of ~S~%" (symbol-function thing))
69 (format stream " which has the argument list ")
70 (let ((arglist #+excl (excl:arglist (symbol-function thing))
71 #+cmu (kernel:%function-arglist (symbol-function thing))
72 #+sbcl (sb-kernel:%simple-fun-arglist (symbol-function thing))
73 #+clisp (ext:arglist (symbol-function thing))
74 #-(or excl cmu sbcl clisp) "( ??? )"))
75 (when arglist
76 (clim:present arglist
77 (clim:presentation-type-of arglist)
78 :stream stream)))
79 (terpri))
80 (format stream " it has a property list of ~S~%" (symbol-plist thing)))
81
82 (defmethod describe-object ((thing number) stream)
83 (clim:present thing (clim:presentation-type-of thing)
84 :stream stream)
85 (format stream " is a number of type ")
86 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
87 :stream stream)
88 (terpri stream))
89
90 (defmethod describe-object ((thing string) stream)
91 (clim:present thing (clim:presentation-type-of thing)
92 :stream stream)
93 (format stream " is of type ")
94 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
95 :stream stream)
96 (format stream " with a length of ")
97 (clim:present (length thing) 'clim:integer
98 :stream stream)
99 (terpri stream))
100
101 (defmethod describe-object ((thing package) stream)
102 (clim:present thing (clim:presentation-type-of thing)
103 :stream stream)
104 (format stream " is a package named ")
105 (clim:present (package-name thing) (clim:presentation-type-of (package-name thing))
106 :stream stream)
107 (terpri stream)
108 (format stream " it has the nicknames of ")
109 (clim:present (package-nicknames thing) 'clim:expression
110 :stream stream)
111 (terpri stream)
112 (format stream " it uses these packages: ")
113 (clim:present (package-use-list thing) 'clim:expression
114 :stream stream)
115 (terpri stream)
116 (format stream " it is used by the packages: ")
117 (clim:present (package-used-by-list thing) 'clim:expression
118 :stream stream)
119 (terpri stream))
120
121
122 (labels ((present-instance-slots-text (thing stream)
123 (let* ((slots (clim-mop:class-slots (class-of thing)))
124 (width (loop for slot in slots
125 maximizing (length (symbol-name (clim-mop:slot-definition-name slot))))))
126 (loop for slot in slots
127 do (cond
128 ((slot-boundp thing (clim-mop:slot-definition-name slot))
129 (format stream " ~v@A: " width
130 (clim-mop:slot-definition-name slot))
131 (clim:present (slot-value thing (clim-mop:slot-definition-name slot))
132 'clim:expression
133 :stream stream)
134 (terpri stream))
135 (t
136 (format stream " ~v@A: <unbound>~%" width
137 (clim-mop:slot-definition-name slot)))))))
138
139 (present-instance-slots-clim (thing stream)
140 (let ((slots (clim-mop:class-slots (class-of thing))))
141 (clim:formatting-table (stream)
142 (dolist (slot slots)
143 (clim:formatting-row (stream)
144 (clim:formatting-cell (stream :align-x :right)
145 (clim:present (clim-mop:slot-definition-name slot)
146 'clim:symbol
147 :stream stream)
148 (write-char #\: stream))
149 (clim:formatting-cell (stream)
150 (if (slot-boundp thing (clim-mop:slot-definition-name slot))
151 (clim:present (slot-value thing (clim-mop:slot-definition-name slot))
152 'clim:expression
153 :stream stream)
154 (format stream "<unbound>"))))))))
155
156 (describe-instance (thing a-what stream)
157 (clim:present thing (clim:presentation-type-of thing)
158 :stream stream)
159 (format stream " is ~A of type " a-what)
160 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
161 :stream stream)
162 (terpri stream)
163 (format stream " it has the following slots:~%")
164 (if (typep stream 'clim:output-recording-stream)
165 (present-instance-slots-clim thing stream)
166 (present-instance-slots-text thing stream))))
167
168 (defmethod describe-object ((thing standard-object) stream)
169 (describe-instance thing "an instance" stream))
170
171 (defmethod describe-object ((thing structure-object) stream)
172 (describe-instance thing "a structure" stream)))

  ViewVC Help
Powered by ViewVC 1.1.5