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

Contents of /mcclim/describe.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide annotations)
Wed Oct 1 21:35:27 2003 UTC (10 years, 6 months ago) by moore
Branch: MAIN
CVS Tags: McCLIM-0-9
Changes since 1.7: +2 -19 lines

Support (in OpenMCL) for accepting the subforms of a form, as opposed
to blowing away the entire form in progress. Put the transform for
coord-seqs in the recording methods, not the def-grecording
macro. Fake MOP functions for OpenMCL in order to support the listener
application.
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 mikemac 1.5 (in-package :common-lisp)
21 mikemac 1.1
22 moore 1.8 (clim-internals::with-system-redefinition-allowed
23 moore 1.2 (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 mikemac 1.1
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 moore 1.8 (clim-internals::with-system-redefinition-allowed
39 moore 1.2 (defmethod describe-object ((thing t) stream)
40     (let ((*print-array* nil))
41     (clim:present thing (clim:presentation-type-of thing)
42 mikemac 1.4 :stream stream)
43 moore 1.2 (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 mikemac 1.1
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 mikemac 1.6 (let ((arglist #+excl (excl:arglist (symbol-function thing))
72     #+cmu (kernel:%function-arglist (symbol-function thing))
73 kevin 1.7 #+sbcl (sb-kernel:%simple-fun-arglist (symbol-function thing))
74 mikemac 1.6 #-(or excl cmu sbcl) "( ??? )"))
75     (when arglist
76     (clim:present arglist
77     (clim:presentation-type-of arglist)
78     :stream stream)))
79 mikemac 1.1 (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 mikemac 1.3 (terpri stream)
112 mikemac 1.1 (format stream " it uses these packages: ")
113     (clim:present (package-use-list thing) 'clim:expression
114     :stream stream)
115 mikemac 1.3 (terpri stream)
116 mikemac 1.1 (format stream " it is used by the packages: ")
117     (clim:present (package-used-by-list thing) 'clim:expression
118     :stream stream)
119 mikemac 1.3 (terpri stream))
120 mikemac 1.1
121     (defmethod describe-object ((thing structure-object) stream)
122     (clim:present thing (clim:presentation-type-of thing)
123     :stream stream)
124     (format stream " is a structure of type ")
125     (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
126     :stream stream)
127     (terpri stream)
128     (format stream " it has the following slots:~%")
129     (let* ((slots (clim-mop:class-slots (class-of thing)))
130     (width (loop for slot in slots
131     maximizing (length (symbol-name (clim-mop:slot-definition-name slot))))))
132     (loop for slot in slots
133     do (cond
134     ((slot-boundp thing (clim-mop:slot-definition-name slot))
135     (format stream " ~v@A: " width
136     (clim-mop:slot-definition-name slot))
137     (clim:present (slot-value thing (clim-mop:slot-definition-name slot))
138     'clim:expression
139     :stream stream)
140     (terpri stream))
141     (t
142     (format stream " ~v@A: <unbound>~%" width
143     (clim-mop:slot-definition-name slot)))))))
144    
145     (defmethod describe-object ((thing standard-object) stream)
146     (clim:present thing (clim:presentation-type-of thing)
147     :stream stream)
148     (format stream " is an instance of type ")
149     (clim:present (type-of thing) (clim:presentation-type-of (type-of thing))
150     :stream stream)
151     (terpri stream)
152     (format stream " it has the following slots:~%")
153     (let* ((slots (clim-mop:class-slots (class-of thing)))
154     (width (loop for slot in slots
155     maximizing (length (symbol-name (clim-mop:slot-definition-name slot))))))
156     (loop for slot in slots
157     do (cond
158     ((slot-boundp thing (clim-mop:slot-definition-name slot))
159     (format stream " ~v@A: " width
160     (clim-mop:slot-definition-name slot))
161     (clim:present (slot-value thing (clim-mop:slot-definition-name slot))
162     'clim:expression
163     :stream stream)
164     (terpri stream))
165     (t
166     (format stream " ~v@A: <unbound>~%" width
167     (clim-mop:slot-definition-name slot)))))))
168    
169    

  ViewVC Help
Powered by ViewVC 1.1.5