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

Contents of /src/interface/inspect.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Thu Nov 12 14:08:40 1992 UTC (21 years, 5 months ago) by garland
Branch: MAIN
Initial revision
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