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

Contents of /src/interface/inspect.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide 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 garland 1.1 ;;;; -*- Mode: Lisp ; Package: Interface -*-
2     ;;;
3 garland 1.2 ;;; **********************************************************************
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 ram 1.10 ;;;
7     (ext:file-comment
8 emarsden 1.11 "$Header: /tiger/var/lib/cvsroots/cmucl/src/interface/inspect.lisp,v 1.11 2003/12/03 07:56:09 emarsden Rel $")
9 garland 1.1 ;;;
10 garland 1.2 ;;; **********************************************************************
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 garland 1.1
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 garland 1.2 (setf *current-inspector-objects*
41     (delete object *current-inspector-objects*))
42 garland 1.1 (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 garland 1.2 ;;; 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 garland 1.1 (defmethod inspector-pane-title (object)
138 ram 1.7 (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 garland 1.1
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 garland 1.5 (if (listp (cdr l))
174     (format nil "List of length ~a" (length l))
175     (format nil "Dotted Pair")))
176 emarsden 1.11
177     (defmethod inspector-pane-title ((i integer))
178     (format nil "Integer ~D" i))
179 garland 1.1
180    
181    
182     ;;;; Methods for displaying object inspection panes
183    
184 garland 1.2 ;;; 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 garland 1.1 (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 garland 1.2 ("Close Pane" destroy-pane-callback ,,object)
210     ("Close All Panes" close-all-callback))))
211 garland 1.1 (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 garland 1.2 ;;; 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 garland 1.1 (defmethod display-inspector-pane (object)
242     (typecase object
243 ram 1.6 (standard-object (display-clos-pane object))
244 garland 1.1 (function (display-function-pane object))
245 ram 1.4 (structure-object (display-structure-pane object))
246 garland 1.1 (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 garland 1.5
255 garland 1.1 (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 ram 1.4 (let* ((dd (kernel:layout-info (kernel:%instance-layout s)))
319     (dsds (kernel:dd-slots dd))
320 garland 1.1 (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 ram 1.4 (string-capitalize
334     (kernel:dsd-%name dsd)))
335     (funcall (kernel:dsd-accessor dsd) s)
336 garland 1.1 :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 garland 1.5 (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 garland 1.1 (defmethod display-inspector-pane ((v sequence))
418     (with-inspector-pane (v)
419 garland 1.5 (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 garland 1.1
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 ram 1.7 (with-slots ((slot pcl::name) (allocation pcl::allocation))
500 garland 1.1 slotd
501     (let* ((slot-label (if allocp
502     (format nil "~a: " slot)
503     (format nil "~a [~a]: " slot allocation)))
504 ram 1.7 (slot-bound (slot-boundp object slot))
505 garland 1.1 (slot-value (if slot-bound
506 ram 1.7 (slot-value object slot)
507 garland 1.1 "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 ram 1.3 (let* ((class (pcl::class-of object))
518 garland 1.1 (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 ram 1.9 (instance-slots ())
525     (class-slots ())
526     (other-slots ()))
527    
528 garland 1.1 (dolist (slotd slotds)
529 ram 1.7 (with-slots ((slot pcl::name) (allocation pcl::allocation))
530 ram 1.9 slotd
531 garland 1.1 (case allocation
532     (:instance (push slotd instance-slots))
533     (:class (push slotd class-slots))
534 ram 1.9 (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 garland 1.1
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 garland 1.2 (push object *current-inspector-objects*)
561 garland 1.1 (inspector-add-history-item object)))
562     object)
563    
564    
565    
566     ;;;; User visible INSPECT function
567    
568     ;;; INSPECT -- Public.
569     ;;;
570 garland 1.8 (defun inspect (object &optional (style interface:*interface-style*))
571 garland 1.1 "This function allows the user to interactively examine Lisp objects.
572 garland 1.8 STYLE indicates whether this should run with a :graphics interface
573 garland 1.1 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 garland 1.8 (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