/[cmucl]/src/interface/inspect.lisp
ViewVC logotype

Contents of /src/interface/inspect.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Wed Dec 3 07:56:09 2003 UTC (10 years, 4 months ago) by emarsden
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2004-10, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, unicode-utf16-sync-2008-12, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, merge-sse2-packed, mod-arith-base, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, RELEASE_20b, snapshot-2008-04, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.10: +4 -1 lines
Add a pane-title for integers to the CLM inspector (fixes an error when
inspecting integers using the Motif interface). Thanks to Raymond Toy for
testing.
1 ;;;; -*- Mode: Lisp ; Package: Interface -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/interface/inspect.lisp,v 1.11 2003/12/03 07:56:09 emarsden Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Written by Michael Garland
13 ;;;
14 ;;; This file implements the methods used in graphically inspecting Lisp
15 ;;; objects.
16 ;;;
17 ;;; The inspector mechanism revolves around two generic functions:
18 ;;; - INSPECTOR-PANE-TITLE which returns a string meant to be the
19 ;;; title of the inspection pane displaying the given object
20 ;;; - DISPLAY-INSPECTOR-PANE which creates a window pane displaying
21 ;;; the relevant information about the given object
22 ;;;
23 ;;; You can add new display mechanisms by defining new methods for these
24 ;;; generic functions. Specific functions for aiding in the construction
25 ;;; of inspection panes are given below.
26 ;;;
27
28 (in-package "INTERFACE")
29
30
31 (defvar *inspector-huge-object-threshold* 20)
32 (defvar *inspector-sequence-initial-display* 5)
33
34
35
36 ;;;; Inspector callbacks
37
38 (defun destroy-pane-callback (widget call-data object)
39 (declare (ignore widget call-data))
40 (setf *current-inspector-objects*
41 (delete object *current-inspector-objects*))
42 (destroy-interface-pane object))
43
44 (defun inspect-object-callback (widget call-data object)
45 (declare (ignore widget call-data))
46 (inspect object))
47
48 (defun inspect-eval-callback (widget call-data output shell)
49 (declare (ignore widget call-data))
50 (with-busy-cursor (shell)
51 (inspect (xti:widget-user-data output))))
52
53 (defun eval-callback (widget call-data object output)
54 (declare (ignore call-data))
55 (let* ((input (car (get-values widget :value)))
56 (mark (text-get-last-position output))
57 (response
58 (format nil "* ~a~%~a~%"
59 input
60 (handler-case
61 (multiple-value-bind (out val)
62 (grab-output-as-string
63 (let ((* object))
64 (eval (read-from-string input))))
65 (setf (xti:widget-user-data output) val)
66 (format nil "~a~s~%" out val))
67 (error (cond)
68 (format nil "~2&~A~2&" cond)))))
69 (length (length response)))
70 (declare (simple-string response))
71
72 (text-set-string widget "")
73 (text-insert output mark response)
74 (text-set-insertion-position output (+ length mark))))
75
76 (defun popup-eval-callback (widget call-data pane object)
77 (declare (ignore widget call-data))
78 (multiple-value-bind (form shell)
79 (create-form-dialog pane "evalDialog")
80 (let* ((s1 (compound-string-create "Eval: " "HeaderFont"))
81 (s2 (compound-string-create
82 (format nil "[~a]" (print-for-widget-display "~S" object))
83 "EntryFont"))
84 (s3 (compound-string-concat s1 s2))
85 (done (create-push-button-gadget form "evalDone"
86 :label-string "Done"
87 :bottom-attachment :attach-form))
88 (inspect (create-push-button-gadget form "evalInspect"
89 :label-string "Inspect Last"
90 :bottom-attachment :attach-form
91 :left-attachment :attach-widget
92 :left-widget done))
93 (entry (create-text form "evalEntry"
94 :bottom-attachment :attach-widget
95 :bottom-widget done
96 :left-attachment :attach-form
97 :right-attachment :attach-form))
98 (prompt (create-label-gadget form "evalPrompt"
99 :bottom-attachment :attach-widget
100 :bottom-widget entry
101 :font-list *all-fonts*
102 :label-string s3))
103 (output (create-text form "evalOutput"
104 :edit-mode :multi-line-edit
105 :editable nil
106 :rows 8
107 :columns 40
108 :top-attachment :attach-form
109 :bottom-attachment :attach-widget
110 :bottom-widget prompt
111 :left-attachment :attach-form
112 :right-attachment :attach-form)))
113 (compound-string-free s1)
114 (compound-string-free s2)
115
116 (set-values shell :title "Inspector Eval"
117 :keyboard-focus-policy :pointer)
118 (add-callback entry :activate-callback 'eval-callback object output)
119 (add-callback inspect :activate-callback
120 'inspect-eval-callback output shell)
121 (add-callback done :activate-callback #'destroy-callback shell)
122 (manage-children done inspect entry prompt output)
123 (manage-child form))))
124
125
126
127 ;;;; Methods for constructing the title of inspection panes
128
129 ;;; INSPECTOR-PANE-TITLE -- Public
130 ;;;
131 ;;; This function takes a Lisp object and returns a string which is meant
132 ;;; to be the title of the inspection pane displaying the given object.
133
134 ;;; This particular method is a catch-all for the types which PCL does not
135 ;;; allow us to discriminate.
136 ;;;
137 (defmethod inspector-pane-title (object)
138 (let ((*print-level* (or debug:*debug-print-level* *print-level*))
139 (*print-length* (or debug:*debug-print-length* *print-length*)))
140 (typecase object
141 (standard-object
142 (format nil "Instance ~a of Class ~a" object (type-of object)))
143 (function (format nil "~a" object))
144 (structure-object
145 (let ((default (format nil "~a" object)))
146 (declare (simple-string default))
147 (if (and (> (length default) 2)
148 (char= (schar default 0) #\#)
149 (char= (schar default 1) #\S))
150 (format nil "#<~a Structure>" (type-of object))
151 default)))
152 (t
153 (format nil "~a ~a" (string-capitalize (type-of object))
154 (print-for-widget-display "~s" object))))))
155
156 (defmethod inspector-pane-title ((sym symbol))
157 (format nil "Symbol ~s" sym))
158
159 (defmethod inspector-pane-title ((v vector))
160 (declare (vector v))
161 (let ((length (length v))
162 (type (type-of v)))
163 (format nil "~a of length ~a"
164 (string-capitalize (if (listp type) (car type) type))
165 length)))
166
167 (defmethod inspector-pane-title ((a array))
168 (let ((dimensions (array-dimensions a)))
169 (format nil "Array of ~a Dimensions = ~s"
170 (array-element-type a) dimensions)))
171
172 (defmethod inspector-pane-title ((l list))
173 (if (listp (cdr l))
174 (format nil "List of length ~a" (length l))
175 (format nil "Dotted Pair")))
176
177 (defmethod inspector-pane-title ((i integer))
178 (format nil "Integer ~D" i))
179
180
181
182 ;;;; Methods for displaying object inspection panes
183
184 ;;; WITH-INSPECTOR-PANE -- Public
185 ;;;
186 ;;; This macro is the primary tool for building inspection panes. It
187 ;;; creates all the fundamental pieces of the display pane and then calls
188 ;;; the supplied body to create the rest. A typical display method would
189 ;;; like something like:
190 ;;; (defmethod display-inspector-pane ((x mytype))
191 ;;; (with-inspector-pane (x)
192 ;;; ... custom forms ...
193 ;;; ))
194 ;;;
195 (defmacro with-inspector-pane ((object) &body forms)
196 `(multiple-value-bind
197 (pane is-new)
198 (create-interface-pane-shell (format nil "Inspect: ~a" (type-of ,object))
199 ,object)
200 (when is-new
201 (let* ((frame (create-frame pane "inspectFrame"))
202 (over-form (create-form frame "inspectForm"))
203 (menu-bar (create-menu-bar over-form "menubar"
204 :left-attachment :attach-form
205 :right-attachment :attach-form))
206 (obmenu (create-interface-menu
207 menu-bar "Object"
208 ,``(("Eval Expression" popup-eval-callback ,pane ,,object)
209 ("Close Pane" destroy-pane-callback ,,object)
210 ("Close All Panes" close-all-callback))))
211 (title (create-label-gadget
212 over-form "inspectTitle"
213 :label-string (inspector-pane-title ,object)
214 :font-list *header-font*
215 :top-attachment :attach-widget
216 :top-widget menu-bar
217 :left-attachment :attach-form
218 :right-attachment :attach-form))
219 (form (create-form over-form "inspectForm"
220 :left-attachment :attach-form
221 :right-attachment :attach-form
222 :bottom-attachment :attach-form
223 :top-attachment :attach-widget
224 :top-widget title)))
225
226 ,@forms
227 (manage-child frame)
228 (manage-child over-form)
229 (manage-child obmenu)
230 (manage-children menu-bar title form)))
231 (popup-interface-pane pane)))
232
233 ;;; DISPLAY-INSPECTOR-PANE -- Public
234 ;;;
235 ;;; This function takes an object and creates a graphical inspection pane
236 ;;; for displaying it.
237
238 ;;; This particular method is a catch all for the types which PCL won't
239 ;;; specialize on.
240 ;;;
241 (defmethod display-inspector-pane (object)
242 (typecase object
243 (standard-object (display-clos-pane object))
244 (function (display-function-pane object))
245 (structure-object (display-structure-pane object))
246 (t
247 (with-inspector-pane (object)
248 (let ((label (create-label-gadget
249 form "label"
250 :label-string (format nil "~s" object))))
251 (manage-child label))))))
252
253
254
255 (defmethod display-inspector-pane ((sym symbol))
256 (with-inspector-pane (sym)
257 (let* ((value (if (boundp sym) (symbol-value sym) "Unbound"))
258 (function (if (fboundp sym) (symbol-function sym) "Undefined"))
259 (plist (symbol-plist sym))
260 (package (symbol-package sym))
261 (rc (create-row-column form "rowColumn"))
262 (vview (create-value-box rc "Value:" value
263 :callback 'inspect-object-callback
264 :activep (boundp sym)))
265 (fview (create-value-box rc "Function:" function
266 :callback 'inspect-object-callback
267 :activep (fboundp sym)))
268 (plview (create-value-box rc "PList:" plist
269 :callback 'inspect-object-callback))
270 (pview (create-value-box rc "Package:" package
271 :callback 'inspect-object-callback)))
272 (manage-child rc)
273 (manage-children vview fview plview pview))))
274
275 (defun is-traced (function)
276 (let ((fun (debug::trace-fdefinition function)))
277 (if (gethash fun debug::*traced-functions*) t)))
278
279 (defun trace-function-callback (widget call-data function)
280 (declare (ignore widget))
281 (if (toggle-button-callback-set call-data)
282 (debug::trace-1 function (debug::make-trace-info))
283 (debug::untrace-1 function)))
284
285 (defun display-function-pane (f)
286 (with-inspector-pane (f)
287 (multiple-value-bind
288 (dstring dval)
289 (grab-output-as-string (describe f))
290 (declare (ignore dval))
291 (let* ((trace (create-toggle-button-gadget form "functionTrace"
292 :bottom-attachment :attach-form
293 :label-string "Trace Function"
294 :set (is-traced f)))
295 (sep (create-separator-gadget form "separator"
296 :left-attachment :attach-form
297 :right-attachment :attach-form
298 :bottom-attachment :attach-widget
299 :bottom-widget trace))
300 (descview (create-scrolled-window form "scrolledView"
301 :left-attachment :attach-form
302 :right-attachment :attach-form
303 :bottom-attachment :attach-widget
304 :bottom-widget sep
305 :top-attachment :attach-form
306 :scrolling-policy :automatic))
307 (desc (create-label descview "functionDescription"
308 :alignment :alignment-beginning
309 :label-string dstring)))
310
311 (add-callback trace :value-changed-callback
312 'trace-function-callback f)
313 (manage-child desc)
314 (manage-children trace sep descview)))))
315
316 (defun display-structure-pane (s)
317 (with-inspector-pane (s)
318 (let* ((dd (kernel:layout-info (kernel:%instance-layout s)))
319 (dsds (kernel:dd-slots dd))
320 (viewer (when (> (length dsds) *inspector-huge-object-threshold*)
321 (create-scrolled-window form "structureViewer"
322 :left-attachment :attach-form
323 :right-attachment :attach-form
324 :top-attachment :attach-form
325 :bottom-attachment :attach-form
326 :scrolling-policy :automatic)))
327 (rc (create-row-column (or viewer form) "rowColumn"))
328 (widgets))
329 (declare (list dsds))
330 (dolist (dsd dsds)
331 (push
332 (create-value-box rc (format nil "~A:"
333 (string-capitalize
334 (kernel:dsd-%name dsd)))
335 (funcall (kernel:dsd-accessor dsd) s)
336 :callback #'inspect-object-callback)
337 widgets))
338 (apply #'manage-children widgets)
339 (manage-child rc)
340 (when viewer (manage-child viewer)))))
341
342
343 (defun sequence-redisplay-callback (widget call-data v s-text c-text view pane)
344 (declare (ignore widget call-data))
345 (handler-case
346 (let* ((start (read-from-string (car (get-values s-text :value))))
347 (count (read-from-string (car (get-values c-text :value))))
348 (length (length v))
349 (widgets (reverse (xti:widget-children view)))
350 (unused-ones)
351 (used-ones))
352
353 (when (> (+ start count) length)
354 (setf count (- length start))
355 (set-values c-text :value (format nil "~a" count)))
356
357 (when (minusp start)
358 (setf start 0)
359 (set-values s-text :value (format nil "~a" 0)))
360
361 (dolist (widget widgets)
362 (if (zerop count)
363 (push widget unused-ones)
364 (progn
365 (set-value-box widget (format nil "~a:" start) (elt v start)
366 :callback #'inspect-object-callback)
367 (push widget used-ones)
368 (incf start)
369 (decf count))))
370
371 (dotimes (i count)
372 (let ((pos (+ start i)))
373 (push (create-value-box view (format nil "~a:" pos) (elt v pos)
374 :callback #'inspect-object-callback)
375 used-ones)))
376 (when unused-ones
377 (apply #'unmanage-children unused-ones))
378 (apply #'manage-children used-ones))
379 (error (e)
380 (interface-error (format nil "~a" e) pane))))
381
382 (defun sequence-filter-callback (widget call-data v fexp view pane)
383 (declare (ignore widget call-data))
384 (handler-case
385 (let* ((exp (read-from-string (car (get-values fexp :value))))
386 (length (length v))
387 (widgets (reverse (xti:widget-children view)))
388 (used-ones))
389 (dotimes (index length)
390 (let* ((item (elt v index))
391 (* item)
392 (** index))
393 (when (eval exp)
394 (let ((widget (pop widgets)))
395 (if widget
396 (set-value-box widget (format nil "~a:" index) item
397 :callback #'inspect-object-callback)
398 (setf widget (create-value-box
399 view (format nil "~a:" index) item
400 :callback #'inspect-object-callback)))
401 (push widget used-ones)))))
402 (when widgets
403 (apply #'unmanage-children widgets))
404 (apply #'manage-children used-ones))
405 (error (e)
406 (interface-error (format nil "~a" e) pane))))
407
408 (defun display-cons-pane (p form)
409 (let* ((rc (create-row-column form "rowColumn"))
410 (car-view (create-value-box rc "Car:" (car p)
411 :callback #'inspect-object-callback))
412 (cdr-view (create-value-box rc "Cdr:" (cdr p)
413 :callback #'inspect-object-callback)))
414 (manage-children car-view cdr-view)
415 (manage-child rc)))
416
417 (defmethod display-inspector-pane ((v sequence))
418 (with-inspector-pane (v)
419 (if (and (listp v)
420 (not (listp (cdr v))))
421 (display-cons-pane v form)
422 (let* ((length (length v))
423 (controls (create-row-column form "sequenceStartHolder"
424 :left-attachment :attach-form
425 :right-attachment :attach-form
426 :orientation :horizontal))
427 (slabel (create-label-gadget controls "sequenceStartLabel"
428 :font-list *header-font*
429 :label-string "Start:"))
430 (start (create-text controls "sequenceStart"
431 :value "0"
432 :columns 4))
433 (clabel (create-label-gadget controls "sequenceCountLabel"
434 :font-list *header-font*
435 :label-string "Count:"))
436 (count (create-text controls "sequenceCount"
437 :value "5"
438 :columns 4))
439 (filter (create-row-column form "sequenceFilterHolder"
440 :top-attachment :attach-widget
441 :top-widget controls
442 :left-attachment :attach-form
443 :right-attachment :attach-form
444 :orientation :horizontal))
445 (flabel (create-label-gadget filter "sequenceFilterLabel"
446 :font-list *header-font*
447 :label-string "Filter:"))
448 (fexp (create-text filter "sequenceFilterExp" :value "T"))
449 (apply (create-push-button-gadget filter "sequenceFilterApply"
450 :label-string "Apply"))
451 (unapply (create-push-button-gadget filter
452 "sequenceFilterUnapply"
453 :label-string "No Filter"))
454 (view (create-scrolled-window form "sequenceViewPort"
455 :scrolling-policy :automatic
456 :top-attachment :attach-widget
457 :top-widget filter
458 :bottom-attachment :attach-form
459 :left-attachment :attach-form
460 :right-attachment :attach-form))
461 (rc (create-row-column view "sequenceView"
462 :spacing 0))
463 (widgets))
464
465 (manage-children slabel start clabel count)
466 (manage-children flabel fexp apply unapply)
467
468 (dotimes (i (min length *inspector-sequence-initial-display*))
469 (let ((item (elt v i)))
470 (push (create-value-box rc (format nil "~a:" i) item
471 :callback #'inspect-object-callback)
472 widgets)))
473
474 (apply #'manage-children widgets)
475
476 (add-callback start :activate-callback 'sequence-redisplay-callback
477 v start count rc pane)
478 (add-callback count :activate-callback 'sequence-redisplay-callback
479 v start count rc pane)
480 (add-callback apply :activate-callback 'sequence-filter-callback
481 v fexp rc pane)
482 (add-callback fexp :activate-callback 'sequence-filter-callback
483 v fexp rc pane)
484 (add-callback unapply :activate-callback
485 #'(lambda (widget call-data)
486 (declare (ignore widget call-data))
487 (sequence-redisplay-callback
488 nil nil v start count rc pane)))
489
490 (manage-children view controls filter)
491 (manage-child rc)))))
492
493 (defun show-slot-list (object slot-list view allocp label)
494 (let ((label (create-label-gadget view "slotLabel"
495 :label-string label
496 :font-list *header-font*))
497 (widgets))
498 (dolist (slotd slot-list)
499 (with-slots ((slot pcl::name) (allocation pcl::allocation))
500 slotd
501 (let* ((slot-label (if allocp
502 (format nil "~a: " slot)
503 (format nil "~a [~a]: " slot allocation)))
504 (slot-bound (slot-boundp object slot))
505 (slot-value (if slot-bound
506 (slot-value object slot)
507 "Unbound")))
508 (push
509 (create-value-box view slot-label slot-value
510 :callback #'inspect-object-callback
511 :activep slot-bound)
512 widgets)))
513 (apply #'manage-children label widgets))))
514
515 (defun display-clos-pane (object)
516 (with-inspector-pane (object)
517 (let* ((class (pcl::class-of object))
518 (slotds (pcl::slots-to-inspect class object))
519 (view (create-row-column form "rowColumn"
520 :left-attachment :attach-form
521 :right-attachment :attach-form
522 :top-attachment :attach-form
523 :bottom-attachment :attach-form))
524 (instance-slots ())
525 (class-slots ())
526 (other-slots ()))
527
528 (dolist (slotd slotds)
529 (with-slots ((slot pcl::name) (allocation pcl::allocation))
530 slotd
531 (case allocation
532 (:instance (push slotd instance-slots))
533 (:class (push slotd class-slots))
534 (otherwise (push slotd other-slots)))))
535
536 (when instance-slots
537 (show-slot-list object instance-slots view t
538 "Slots with Instance allocation:"))
539 (when class-slots
540 (show-slot-list object class-slots view t
541 "Slots with Class allocation:"))
542 (when other-slots
543 (show-slot-list object other-slots view nil
544 "Slots with Other allocation:"))
545
546 (when view (manage-child view)))))
547
548
549
550 ;;;; Functions for creating the Motif inspector
551
552 (defun start-motif-inspector (object)
553 (verify-system-server-exists)
554 (multiple-value-bind (shell connection)
555 (create-interface-shell)
556 (declare (ignore shell))
557 (with-motif-connection (connection)
558 (verify-control-pane-displayed)
559 (display-inspector-pane object)
560 (push object *current-inspector-objects*)
561 (inspector-add-history-item object)))
562 object)
563
564
565
566 ;;;; User visible INSPECT function
567
568 ;;; INSPECT -- Public.
569 ;;;
570 (defun inspect (object &optional (style interface:*interface-style*))
571 "This function allows the user to interactively examine Lisp objects.
572 STYLE indicates whether this should run with a :graphics interface
573 or a :command-line oriented one; when running without X, there is no
574 choice. Supplying :window, :windows, :graphics, :graphical, and :x gets
575 a windowing interface, and supplying :command-line or :tty gets the
576 other style."
577
578 (let ((interface:*interface-style* style))
579 (if (use-graphics-interface)
580 (start-motif-inspector object)
581 (inspect::tty-inspect object))))

  ViewVC Help
Powered by ViewVC 1.1.5