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

Contents of /mcclim/describe.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (show annotations)
Wed Feb 18 02:50:32 2004 UTC (10 years, 2 months ago) by hefner1
Branch: MAIN
Changes since 1.8: +51 -48 lines
Some OAOO between describe-object methods for standard-object,
structure-object. Added use of CLIM table formatting for slot values if
the stream is an output-recording-stream, with a fallback to the original
code otherwise (looks almost identical, but should have no issues with
proportional fonts).
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 :common-lisp)
21
22 (clim-internals::with-system-redefinition-allowed
23 (defun describe (thing &optional stream)
24 (if (null stream)
25 (setq stream *standard-output*)
26 (if (eq stream t)
27 (setq stream *terminal-io*)))
28 (describe-object thing stream)
29 (values))
30 )
31
32 (defgeneric describe-object (thing stream))
33
34 ;;; For these methods, stream should be of type
35 ;;; (or EXTENDED-OUTPUT-STREAM OUTPUT-RECORDING-STREAM)
36 ;;; but CLIM-STREAM-PANE is used instead.
37
38 (clim-internals::with-system-redefinition-allowed
39 (defmethod describe-object ((thing t) stream)
40 (let ((*print-array* nil))
41 (clim:present thing (clim:presentation-type-of thing)
42 :stream stream)
43 (format stream " is of type ")
44 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
45 :stream stream)
46 (terpri stream)))
47 )
48
49 (defmethod describe-object ((thing symbol) stream)
50 (clim:present thing (clim:presentation-type-of thing)
51 :stream stream)
52 (format stream " is of type ")
53 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
54 :stream stream)
55 (terpri stream)
56 (cond
57 ((not (boundp thing))
58 (format stream " it is unbound~%"))
59 (t
60 (format stream " it has a value of ")
61 (clim:present (symbol-value thing) (clim:presentation-type-of (symbol-value thing))
62 :stream stream)
63 (terpri)))
64 (format stream " it is in the ")
65 (clim:present (symbol-package thing) (clim:presentation-type-of (symbol-package thing))
66 :stream stream)
67 (format stream " package~%")
68 (when (fboundp thing)
69 (format stream " it has a function definition of ~S~%" (symbol-function thing))
70 (format stream " which has the argument list ")
71 (let ((arglist #+excl (excl:arglist (symbol-function thing))
72 #+cmu (kernel:%function-arglist (symbol-function thing))
73 #+sbcl (sb-kernel:%simple-fun-arglist (symbol-function thing))
74 #-(or excl cmu sbcl) "( ??? )"))
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