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

Contents of /mcclim/describe.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Mon Nov 11 18:37:00 2002 UTC (11 years, 5 months ago) by mikemac
Branch: MAIN
Changes since 1.2: +3 -3 lines
forgot some STREAM args to TERPRIs
1 mikemac 1.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 moore 1.2 #+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 mikemac 1.1
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 moore 1.2 (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     :acceptably t :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 mikemac 1.1
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 mikemac 1.3 (terpri stream)
124 mikemac 1.1 (format stream " it uses these packages: ")
125     (clim:present (package-use-list thing) 'clim:expression
126     :stream stream)
127 mikemac 1.3 (terpri stream)
128 mikemac 1.1 (format stream " it is used by the packages: ")
129     (clim:present (package-used-by-list thing) 'clim:expression
130     :stream stream)
131 mikemac 1.3 (terpri stream))
132 mikemac 1.1
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