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

Contents of /mcclim/describe.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Fri Mar 21 21:36:58 2003 UTC (11 years ago) by mikemac
Branch: MAIN
Changes since 1.4: +1 -1 lines
make all of the package names passed to in-package be lowercase keywords for ACL's java mode
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 #+excl
23 (eval-when (:compile-toplevel :load-toplevel :execute)
24 (setf (excl:package-definition-lock (find-package :common-lisp)) nil))
25
26 #+openmcl
27 (defmacro with-system-redefinition-allowed (&body body)
28 `(let ((ccl::*warn-if-redefine-kernel* nil))
29 ,@body))
30
31 #-openmcl
32 (defmacro with-system-redefinition-allowed (&body body)
33 `(progn
34 ,@body))
35
36 (with-system-redefinition-allowed
37 (defun describe (thing &optional stream)
38 (if (null stream)
39 (setq stream *standard-output*)
40 (if (eq stream t)
41 (setq stream *terminal-io*)))
42 (describe-object thing stream)
43 (values))
44 )
45
46 (defgeneric describe-object (thing stream))
47
48 ;;; For these methods, stream should be of type
49 ;;; (or EXTENDED-OUTPUT-STREAM OUTPUT-RECORDING-STREAM)
50 ;;; but CLIM-STREAM-PANE is used instead.
51
52 (with-system-redefinition-allowed
53 (defmethod describe-object ((thing t) stream)
54 (let ((*print-array* nil))
55 (clim:present thing (clim:presentation-type-of thing)
56 :stream stream)
57 (format stream " is of type ")
58 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
59 :stream stream)
60 (terpri stream)))
61 )
62
63 (defmethod describe-object ((thing symbol) stream)
64 (clim:present thing (clim:presentation-type-of thing)
65 :stream stream)
66 (format stream " is of type ")
67 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
68 :stream stream)
69 (terpri stream)
70 (cond
71 ((not (boundp thing))
72 (format stream " it is unbound~%"))
73 (t
74 (format stream " it has a value of ")
75 (clim:present (symbol-value thing) (clim:presentation-type-of (symbol-value thing))
76 :stream stream)
77 (terpri)))
78 (format stream " it is in the ")
79 (clim:present (symbol-package thing) (clim:presentation-type-of (symbol-package thing))
80 :stream stream)
81 (format stream " package~%")
82 (when (fboundp thing)
83 (format stream " it has a function definition of ~S~%" (symbol-function thing))
84 (format stream " which has the argument list ")
85 #+excl (clim:present (excl:arglist (symbol-function thing))
86 (clim:presentation-type-of (excl:arglist (symbol-function thing)))
87 :stream stream)
88 #+cmu (clim:present (kernel:%function-arglist (symbol-function thing))
89 (clim:presentation-type-of (kernel:%function-arglist (symbol-function thing)))
90 :stream stream)
91 (terpri))
92 (format stream " it has a property list of ~S~%" (symbol-plist thing)))
93
94 (defmethod describe-object ((thing number) stream)
95 (clim:present thing (clim:presentation-type-of thing)
96 :stream stream)
97 (format stream " is a number of type ")
98 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
99 :stream stream)
100 (terpri stream))
101
102 (defmethod describe-object ((thing string) stream)
103 (clim:present thing (clim:presentation-type-of thing)
104 :stream stream)
105 (format stream " is of type ")
106 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
107 :stream stream)
108 (format stream " with a length of ")
109 (clim:present (length thing) 'clim:integer
110 :stream stream)
111 (terpri stream))
112
113 (defmethod describe-object ((thing package) stream)
114 (clim:present thing (clim:presentation-type-of thing)
115 :stream stream)
116 (format stream " is a package named ")
117 (clim:present (package-name thing) (clim:presentation-type-of (package-name thing))
118 :stream stream)
119 (terpri stream)
120 (format stream " it has the nicknames of ")
121 (clim:present (package-nicknames thing) 'clim:expression
122 :stream stream)
123 (terpri stream)
124 (format stream " it uses these packages: ")
125 (clim:present (package-use-list thing) 'clim:expression
126 :stream stream)
127 (terpri stream)
128 (format stream " it is used by the packages: ")
129 (clim:present (package-used-by-list thing) 'clim:expression
130 :stream stream)
131 (terpri stream))
132
133 (defmethod describe-object ((thing structure-object) stream)
134 (clim:present thing (clim:presentation-type-of thing)
135 :stream stream)
136 (format stream " is a structure of type ")
137 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
138 :stream stream)
139 (terpri stream)
140 (format stream " it has the following slots:~%")
141 (let* ((slots (clim-mop:class-slots (class-of thing)))
142 (width (loop for slot in slots
143 maximizing (length (symbol-name (clim-mop:slot-definition-name slot))))))
144 (loop for slot in slots
145 do (cond
146 ((slot-boundp thing (clim-mop:slot-definition-name slot))
147 (format stream " ~v@A: " width
148 (clim-mop:slot-definition-name slot))
149 (clim:present (slot-value thing (clim-mop:slot-definition-name slot))
150 'clim:expression
151 :stream stream)
152 (terpri stream))
153 (t
154 (format stream " ~v@A: <unbound>~%" width
155 (clim-mop:slot-definition-name slot)))))))
156
157 (defmethod describe-object ((thing standard-object) stream)
158 (clim:present thing (clim:presentation-type-of thing)
159 :stream stream)
160 (format stream " is an instance of type ")
161 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
162 :stream stream)
163 (terpri stream)
164 (format stream " it has the following slots:~%")
165 (let* ((slots (clim-mop:class-slots (class-of thing)))
166 (width (loop for slot in slots
167 maximizing (length (symbol-name (clim-mop:slot-definition-name slot))))))
168 (loop for slot in slots
169 do (cond
170 ((slot-boundp thing (clim-mop:slot-definition-name slot))
171 (format stream " ~v@A: " width
172 (clim-mop:slot-definition-name slot))
173 (clim:present (slot-value thing (clim-mop:slot-definition-name slot))
174 'clim:expression
175 :stream stream)
176 (terpri stream))
177 (t
178 (format stream " ~v@A: <unbound>~%" width
179 (clim-mop:slot-definition-name slot)))))))
180
181 #+excl
182 (eval-when (:compile-toplevel :load-toplevel :execute)
183 (setf (excl:package-definition-lock (find-package :common-lisp)) t))
184

  ViewVC Help
Powered by ViewVC 1.1.5