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

Contents of /src/interface/inspect.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Thu Nov 12 14:08:40 1992 UTC (21 years, 5 months ago) by garland
Branch: MAIN
Initial revision
1 garland 1.1 ;;;; -*- Mode: Lisp ; Package: Interface -*-
2     ;;;
3     ;;;
4    
5     (in-package "INTERFACE")
6    
7    
8     (defvar *inspector-huge-object-threshold* 20)
9     (defvar *inspector-sequence-initial-display* 5)
10    
11    
12    
13     ;;;; Inspector callbacks
14    
15     (defun destroy-pane-callback (widget call-data object)
16     (declare (ignore widget call-data))
17     (destroy-interface-pane object))
18    
19     (defun inspect-object-callback (widget call-data object)
20     (declare (ignore widget call-data))
21     (inspect object))
22    
23     (defun inspect-eval-callback (widget call-data output shell)
24     (declare (ignore widget call-data))
25     (with-busy-cursor (shell)
26     (inspect (xti:widget-user-data output))))
27    
28     (defun eval-callback (widget call-data object output)
29     (declare (ignore call-data))
30     (let* ((input (car (get-values widget :value)))
31     (mark (text-get-last-position output))
32     (response
33     (format nil "* ~a~%~a~%"
34     input
35     (handler-case
36     (multiple-value-bind (out val)
37     (grab-output-as-string
38     (let ((* object))
39     (eval (read-from-string input))))
40     (setf (xti:widget-user-data output) val)
41     (format nil "~a~s~%" out val))
42     (error (cond)
43     (format nil "~2&~A~2&" cond)))))
44     (length (length response)))
45     (declare (simple-string response))
46    
47     (text-set-string widget "")
48     (text-insert output mark response)
49     (text-set-insertion-position output (+ length mark))))
50    
51     (defun popup-eval-callback (widget call-data pane object)
52     (declare (ignore widget call-data))
53     (multiple-value-bind (form shell)
54     (create-form-dialog pane "evalDialog")
55     (let* ((s1 (compound-string-create "Eval: " "HeaderFont"))
56     (s2 (compound-string-create
57     (format nil "[~a]" (print-for-widget-display "~S" object))
58     "EntryFont"))
59     (s3 (compound-string-concat s1 s2))
60     (done (create-push-button-gadget form "evalDone"
61     :label-string "Done"
62     :bottom-attachment :attach-form))
63     (inspect (create-push-button-gadget form "evalInspect"
64     :label-string "Inspect Last"
65     :bottom-attachment :attach-form
66     :left-attachment :attach-widget
67     :left-widget done))
68     (entry (create-text form "evalEntry"
69     :bottom-attachment :attach-widget
70     :bottom-widget done
71     :left-attachment :attach-form
72     :right-attachment :attach-form))
73     (prompt (create-label-gadget form "evalPrompt"
74     :bottom-attachment :attach-widget
75     :bottom-widget entry
76     :font-list *all-fonts*
77     :label-string s3))
78     (output (create-text form "evalOutput"
79     :edit-mode :multi-line-edit
80     :editable nil
81     :rows 8
82     :columns 40
83     :top-attachment :attach-form
84     :bottom-attachment :attach-widget
85     :bottom-widget prompt
86     :left-attachment :attach-form
87     :right-attachment :attach-form)))
88     (compound-string-free s1)
89     (compound-string-free s2)
90    
91     (set-values shell :title "Inspector Eval"
92     :keyboard-focus-policy :pointer)
93     (add-callback entry :activate-callback 'eval-callback object output)
94     (add-callback inspect :activate-callback
95     'inspect-eval-callback output shell)
96     (add-callback done :activate-callback #'destroy-callback shell)
97     (manage-children done inspect entry prompt output)
98     (manage-child form))))
99    
100    
101    
102     ;;;; Methods for constructing the title of inspection panes
103    
104     (defmethod inspector-pane-title (object)
105     (typecase object
106     (pcl::std-instance
107     (format nil "Instance ~a of Class ~a"
108     object (pcl:class-name (pcl:class-of object))))
109     (function (format nil "~a" object))
110     (structure
111     (let ((default (format nil "~a" object)))
112     (declare (simple-string default))
113     (if (and (> (length default) 2)
114     (char= (schar default 0) #\#)
115     (char= (schar default 1) #\S))
116     (format nil "#<~a Structure>" (type-of object))
117     default)))
118     (t
119     (format nil "~a ~a" (string-capitalize (type-of object))
120     (print-for-widget-display "~s" object)))))
121    
122     (defmethod inspector-pane-title ((sym symbol))
123     (format nil "Symbol ~s" sym))
124    
125     (defmethod inspector-pane-title ((v vector))
126     (declare (vector v))
127     (let ((length (length v))
128     (type (type-of v)))
129     (format nil "~a of length ~a"
130     (string-capitalize (if (listp type) (car type) type))
131     length)))
132    
133     (defmethod inspector-pane-title ((a array))
134     (let ((dimensions (array-dimensions a)))
135     (format nil "Array of ~a Dimensions = ~s"
136     (array-element-type a) dimensions)))
137    
138     (defmethod inspector-pane-title ((l list))
139     (if (not (listp (cdr l)))
140     (format nil "Dotted Pair")
141     (format nil "List of length ~a" (length l))))
142    
143    
144    
145     ;;;; Methods for displaying object inspection panes
146    
147     (defmacro with-inspector-pane ((object) &body forms)
148     `(multiple-value-bind
149     (pane is-new)
150     (create-interface-pane-shell (format nil "Inspect: ~a" (type-of ,object))
151     ,object)
152     (when is-new
153     (let* ((frame (create-frame pane "inspectFrame"))
154     (over-form (create-form frame "inspectForm"))
155     (menu-bar (create-menu-bar over-form "menubar"
156     :left-attachment :attach-form
157     :right-attachment :attach-form))
158     (obmenu (create-interface-menu
159     menu-bar "Object"
160     ,``(("Eval Expression" popup-eval-callback ,pane ,,object)
161     ("Close Pane" destroy-pane-callback ,,object))))
162     (title (create-label-gadget
163     over-form "inspectTitle"
164     :label-string (inspector-pane-title ,object)
165     :font-list *header-font*
166     :top-attachment :attach-widget
167     :top-widget menu-bar
168     :left-attachment :attach-form
169     :right-attachment :attach-form))
170     (form (create-form over-form "inspectForm"
171     :left-attachment :attach-form
172     :right-attachment :attach-form
173     :bottom-attachment :attach-form
174     :top-attachment :attach-widget
175     :top-widget title)))
176    
177     ,@forms
178     (manage-child frame)
179     (manage-child over-form)
180     (manage-child obmenu)
181     (manage-children menu-bar title form)))
182     (popup-interface-pane pane)))
183    
184     (defmethod display-inspector-pane (object)
185     (typecase object
186     (pcl::std-instance (display-clos-pane object))
187     (function (display-function-pane object))
188     (structure (display-structure-pane object))
189     (t
190     (with-inspector-pane (object)
191     (let ((label (create-label-gadget
192     form "label"
193     :label-string (format nil "~s" object))))
194     (manage-child label))))))
195    
196    
197     (defmethod display-inspector-pane ((sym symbol))
198     (with-inspector-pane (sym)
199     (let* ((value (if (boundp sym) (symbol-value sym) "Unbound"))
200     (function (if (fboundp sym) (symbol-function sym) "Undefined"))
201     (plist (symbol-plist sym))
202     (package (symbol-package sym))
203     (rc (create-row-column form "rowColumn"))
204     (vview (create-value-box rc "Value:" value
205     :callback 'inspect-object-callback
206     :activep (boundp sym)))
207     (fview (create-value-box rc "Function:" function
208     :callback 'inspect-object-callback
209     :activep (fboundp sym)))
210     (plview (create-value-box rc "PList:" plist
211     :callback 'inspect-object-callback))
212     (pview (create-value-box rc "Package:" package
213     :callback 'inspect-object-callback)))
214     (manage-child rc)
215     (manage-children vview fview plview pview))))
216    
217     (defun is-traced (function)
218     (let ((fun (debug::trace-fdefinition function)))
219     (if (gethash fun debug::*traced-functions*) t)))
220    
221     (defun trace-function-callback (widget call-data function)
222     (declare (ignore widget))
223     (if (toggle-button-callback-set call-data)
224     (debug::trace-1 function (debug::make-trace-info))
225     (debug::untrace-1 function)))
226    
227     (defun display-function-pane (f)
228     (with-inspector-pane (f)
229     (multiple-value-bind
230     (dstring dval)
231     (grab-output-as-string (describe f))
232     (declare (ignore dval))
233     (let* ((trace (create-toggle-button-gadget form "functionTrace"
234     :bottom-attachment :attach-form
235     :label-string "Trace Function"
236     :set (is-traced f)))
237     (sep (create-separator-gadget form "separator"
238     :left-attachment :attach-form
239     :right-attachment :attach-form
240     :bottom-attachment :attach-widget
241     :bottom-widget trace))
242     (descview (create-scrolled-window form "scrolledView"
243     :left-attachment :attach-form
244     :right-attachment :attach-form
245     :bottom-attachment :attach-widget
246     :bottom-widget sep
247     :top-attachment :attach-form
248     :scrolling-policy :automatic))
249     (desc (create-label descview "functionDescription"
250     :alignment :alignment-beginning
251     :label-string dstring)))
252    
253     (add-callback trace :value-changed-callback
254     'trace-function-callback f)
255     (manage-child desc)
256     (manage-children trace sep descview)))))
257    
258     (defun display-structure-pane (s)
259     (with-inspector-pane (s)
260     (let* ((dd (info type defined-structure-info (structure-ref s 0)))
261     (dsds (c::dd-slots dd))
262     (viewer (when (> (length dsds) *inspector-huge-object-threshold*)
263     (create-scrolled-window form "structureViewer"
264     :left-attachment :attach-form
265     :right-attachment :attach-form
266     :top-attachment :attach-form
267     :bottom-attachment :attach-form
268     :scrolling-policy :automatic)))
269     (rc (create-row-column (or viewer form) "rowColumn"))
270     (widgets))
271     (declare (list dsds))
272     (dolist (dsd dsds)
273     (push
274     (create-value-box rc (format nil "~A:"
275     (string-capitalize (c::dsd-%name dsd)))
276     (structure-ref s (c::dsd-index dsd))
277     :callback #'inspect-object-callback)
278     widgets))
279     (apply #'manage-children widgets)
280     (manage-child rc)
281     (when viewer (manage-child viewer)))))
282    
283    
284     (defun sequence-redisplay-callback (widget call-data v s-text c-text view pane)
285     (declare (ignore widget call-data))
286     (handler-case
287     (let* ((start (read-from-string (car (get-values s-text :value))))
288     (count (read-from-string (car (get-values c-text :value))))
289     (length (length v))
290     (widgets (reverse (xti:widget-children view)))
291     (unused-ones)
292     (used-ones))
293    
294     (when (> (+ start count) length)
295     (setf count (- length start))
296     (set-values c-text :value (format nil "~a" count)))
297    
298     (when (minusp start)
299     (setf start 0)
300     (set-values s-text :value (format nil "~a" 0)))
301    
302     (dolist (widget widgets)
303     (if (zerop count)
304     (push widget unused-ones)
305     (progn
306     (set-value-box widget (format nil "~a:" start) (elt v start)
307     :callback #'inspect-object-callback)
308     (push widget used-ones)
309     (incf start)
310     (decf count))))
311    
312     (dotimes (i count)
313     (let ((pos (+ start i)))
314     (push (create-value-box view (format nil "~a:" pos) (elt v pos)
315     :callback #'inspect-object-callback)
316     used-ones)))
317     (when unused-ones
318     (apply #'unmanage-children unused-ones))
319     (apply #'manage-children used-ones))
320     (error (e)
321     (interface-error (format nil "~a" e) pane))))
322    
323     (defun sequence-filter-callback (widget call-data v fexp view pane)
324     (declare (ignore widget call-data))
325     (handler-case
326     (let* ((exp (read-from-string (car (get-values fexp :value))))
327     (length (length v))
328     (widgets (reverse (xti:widget-children view)))
329     (used-ones))
330     (dotimes (index length)
331     (let* ((item (elt v index))
332     (* item)
333     (** index))
334     (when (eval exp)
335     (let ((widget (pop widgets)))
336     (if widget
337     (set-value-box widget (format nil "~a:" index) item
338     :callback #'inspect-object-callback)
339     (setf widget (create-value-box
340     view (format nil "~a:" index) item
341     :callback #'inspect-object-callback)))
342     (push widget used-ones)))))
343     (when widgets
344     (apply #'unmanage-children widgets))
345     (apply #'manage-children used-ones))
346     (error (e)
347     (interface-error (format nil "~a" e) pane))))
348    
349     (defmethod display-inspector-pane ((v sequence))
350     (with-inspector-pane (v)
351     (let* ((length (length v))
352     (controls (create-row-column form "sequenceStartHolder"
353     :left-attachment :attach-form
354     :right-attachment :attach-form
355     :orientation :horizontal))
356     (slabel (create-label-gadget controls "sequenceStartLabel"
357     :font-list *header-font*
358     :label-string "Start:"))
359     (start (create-text controls "sequenceStart"
360     :value "0"
361     :columns 4))
362     (clabel (create-label-gadget controls "sequenceCountLabel"
363     :font-list *header-font*
364     :label-string "Count:"))
365     (count (create-text controls "sequenceCount"
366     :value "5"
367     :columns 4))
368     (filter (create-row-column form "sequenceFilterHolder"
369     :top-attachment :attach-widget
370     :top-widget controls
371     :left-attachment :attach-form
372     :right-attachment :attach-form
373     :orientation :horizontal))
374     (flabel (create-label-gadget filter "sequenceFilterLabel"
375     :font-list *header-font*
376     :label-string "Filter:"))
377     (fexp (create-text filter "sequenceFilterExp" :value "T"))
378     (apply (create-push-button-gadget filter "sequenceFilterApply"
379     :label-string "Apply"))
380     (unapply (create-push-button-gadget filter "sequenceFilterUnapply"
381     :label-string "No Filter"))
382     (view (create-scrolled-window form "sequenceViewPort"
383     :scrolling-policy :automatic
384     :top-attachment :attach-widget
385     :top-widget filter
386     :bottom-attachment :attach-form
387     :left-attachment :attach-form
388     :right-attachment :attach-form))
389     (rc (create-row-column view "sequenceView"
390     :spacing 0))
391     (widgets))
392    
393     (manage-children slabel start clabel count)
394     (manage-children flabel fexp apply unapply)
395    
396     (dotimes (i (min length *inspector-sequence-initial-display*))
397     (let ((item (elt v i)))
398     (push (create-value-box rc (format nil "~a:" i) item
399     :callback #'inspect-object-callback)
400     widgets)))
401    
402     (apply #'manage-children widgets)
403    
404     (add-callback start :activate-callback 'sequence-redisplay-callback
405     v start count rc pane)
406     (add-callback count :activate-callback 'sequence-redisplay-callback
407     v start count rc pane)
408     (add-callback apply :activate-callback 'sequence-filter-callback
409     v fexp rc pane)
410     (add-callback fexp :activate-callback 'sequence-filter-callback
411     v fexp rc pane)
412     (add-callback unapply :activate-callback
413     #'(lambda (widget call-data)
414     (declare (ignore widget call-data))
415     (sequence-redisplay-callback
416     nil nil v start count rc pane)))
417    
418     (manage-children view controls filter)
419     (manage-child rc))))
420    
421     (defun show-slot-list (object slot-list view allocp label)
422     (let ((label (create-label-gadget view "slotLabel"
423     :label-string label
424     :font-list *header-font*))
425     (widgets))
426     (dolist (slotd slot-list)
427     (pcl:with-slots ((slot pcl::name) (allocation pcl::allocation))
428     slotd
429     (let* ((slot-label (if allocp
430     (format nil "~a: " slot)
431     (format nil "~a [~a]: " slot allocation)))
432     (slot-bound (pcl:slot-boundp object slot))
433     (slot-value (if slot-bound
434     (pcl:slot-value object slot)
435     "Unbound")))
436     (push
437     (create-value-box view slot-label slot-value
438     :callback #'inspect-object-callback
439     :activep slot-bound)
440     widgets)))
441     (apply #'manage-children label widgets))))
442    
443     (defun display-clos-pane (object)
444     (with-inspector-pane (object)
445     (let* ((class (pcl:class-of object))
446     (slotds (pcl::slots-to-inspect class object))
447     (view (create-row-column form "rowColumn"
448     :left-attachment :attach-form
449     :right-attachment :attach-form
450     :top-attachment :attach-form
451     :bottom-attachment :attach-form))
452     instance-slots class-slots other-slots)
453    
454     (dolist (slotd slotds)
455     (pcl:with-slots ((slot pcl::name) (allocation pcl::allocation))
456     slotd
457     (case allocation
458     (:instance (push slotd instance-slots))
459     (:class (push slotd class-slots))
460     (otherwise (push slotd other-slots))))
461     (when instance-slots
462     (show-slot-list object instance-slots view t
463     "Slots with Instance allocation:"))
464     (when class-slots
465     (show-slot-list object class-slots view t
466     "Slots with Class allocation:"))
467     (when other-slots
468     (show-slot-list object other-slots view nil
469     "Slots with Other allocation:"))))))
470    
471    
472    
473     ;;;; Functions for creating the Motif inspector
474    
475     (defun start-motif-inspector (object)
476     (verify-system-server-exists)
477     (multiple-value-bind (shell connection)
478     (create-interface-shell)
479     (declare (ignore shell))
480     (with-motif-connection (connection)
481     (verify-control-pane-displayed)
482     (display-inspector-pane object)
483     (inspector-add-history-item object)))
484     object)
485    
486    
487    
488     ;;;; User visible INSPECT function
489    
490     ;;; INSPECT -- Public.
491     ;;;
492     (defun inspect (object)
493     "This function allows the user to interactively examine Lisp objects.
494     INTERFACE indicates whether this should run with a :graphics interface
495     or a :command-line oriented one; when running without X, there is no
496     choice. Supplying :window, :windows, :graphics, :graphical, and :x gets
497     a windowing interface, and supplying :command-line or :tty gets the
498     other style."
499    
500     (if (use-graphics-interface)
501     (start-motif-inspector object)
502     (inspect::tty-inspect object)))

  ViewVC Help
Powered by ViewVC 1.1.5