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

Contents of /mcclim/describe.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Mon Aug 18 08:45:16 2003 UTC (10 years, 8 months ago) by kevin
Branch: MAIN
Changes since 1.6: +1 -1 lines
Update for SBCL's renamed function: %simple-fun-arglist
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 (let ((arglist #+excl (excl:arglist (symbol-function thing))
86 #+cmu (kernel:%function-arglist (symbol-function thing))
87 #+sbcl (sb-kernel:%simple-fun-arglist (symbol-function thing))
88 #-(or excl cmu sbcl) "( ??? )"))
89 (when arglist
90 (clim:present arglist
91 (clim:presentation-type-of arglist)
92 :stream stream)))
93 (terpri))
94 (format stream " it has a property list of ~S~%" (symbol-plist thing)))
95
96 (defmethod describe-object ((thing number) stream)
97 (clim:present thing (clim:presentation-type-of thing)
98 :stream stream)
99 (format stream " is a number of type ")
100 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
101 :stream stream)
102 (terpri stream))
103
104 (defmethod describe-object ((thing string) stream)
105 (clim:present thing (clim:presentation-type-of thing)
106 :stream stream)
107 (format stream " is of type ")
108 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
109 :stream stream)
110 (format stream " with a length of ")
111 (clim:present (length thing) 'clim:integer
112 :stream stream)
113 (terpri stream))
114
115 (defmethod describe-object ((thing package) stream)
116 (clim:present thing (clim:presentation-type-of thing)
117 :stream stream)
118 (format stream " is a package named ")
119 (clim:present (package-name thing) (clim:presentation-type-of (package-name thing))
120 :stream stream)
121 (terpri stream)
122 (format stream " it has the nicknames of ")
123 (clim:present (package-nicknames thing) 'clim:expression
124 :stream stream)
125 (terpri stream)
126 (format stream " it uses these packages: ")
127 (clim:present (package-use-list thing) 'clim:expression
128 :stream stream)
129 (terpri stream)
130 (format stream " it is used by the packages: ")
131 (clim:present (package-used-by-list thing) 'clim:expression
132 :stream stream)
133 (terpri stream))
134
135 (defmethod describe-object ((thing structure-object) stream)
136 (clim:present thing (clim:presentation-type-of thing)
137 :stream stream)
138 (format stream " is a structure of type ")
139 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
140 :stream stream)
141 (terpri stream)
142 (format stream " it has the following slots:~%")
143 (let* ((slots (clim-mop:class-slots (class-of thing)))
144 (width (loop for slot in slots
145 maximizing (length (symbol-name (clim-mop:slot-definition-name slot))))))
146 (loop for slot in slots
147 do (cond
148 ((slot-boundp thing (clim-mop:slot-definition-name slot))
149 (format stream " ~v@A: " width
150 (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 (terpri stream))
155 (t
156 (format stream " ~v@A: <unbound>~%" width
157 (clim-mop:slot-definition-name slot)))))))
158
159 (defmethod describe-object ((thing standard-object) stream)
160 (clim:present thing (clim:presentation-type-of thing)
161 :stream stream)
162 (format stream " is an instance of type ")
163 (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
164 :stream stream)
165 (terpri stream)
166 (format stream " it has the following slots:~%")
167 (let* ((slots (clim-mop:class-slots (class-of thing)))
168 (width (loop for slot in slots
169 maximizing (length (symbol-name (clim-mop:slot-definition-name slot))))))
170 (loop for slot in slots
171 do (cond
172 ((slot-boundp thing (clim-mop:slot-definition-name slot))
173 (format stream " ~v@A: " width
174 (clim-mop:slot-definition-name slot))
175 (clim:present (slot-value thing (clim-mop:slot-definition-name slot))
176 'clim:expression
177 :stream stream)
178 (terpri stream))
179 (t
180 (format stream " ~v@A: <unbound>~%" width
181 (clim-mop:slot-definition-name slot)))))))
182
183 #+excl
184 (eval-when (:compile-toplevel :load-toplevel :execute)
185 (setf (excl:package-definition-lock (find-package :common-lisp)) t))
186

  ViewVC Help
Powered by ViewVC 1.1.5