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

Contents of /src/interface/debug.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Tue Mar 9 13:11:19 1993 UTC (21 years, 1 month ago) by garland
Branch: MAIN
Changes since 1.3: +96 -9 lines
The "Edit Source" button now works.
A new button, "Dump Backtrace" has been added.  This is for dumping
a copy of the stack backtrace for use in bug reports.  At the moment,
it just prints a copy of the backtrace on the standard output stream.
1 ;;;; -*- Mode: Lisp ; Package: Debug -*-
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 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 ;;; **********************************************************************
10 ;;;
11 ;;; Written by Michael Garland
12 ;;;
13 ;;; This file implements the graphical interface to the debugger.
14 ;;;
15
16 (in-package "DEBUG")
17 (use-package '("TOOLKIT" "INTERFACE"))
18
19 ;;; We need to record three things globally:
20 ;;; - The structure decribing the current debugger display
21 ;;; - The frame displays which are currently active (ie. visible)
22 ;;; - The husks of old debugger displays for reuse
23 ;;;
24 (defvar *current-debug-display* nil)
25 (defvar *debug-active-frames* nil)
26 (defvar *old-display-frames* nil)
27
28
29
30 ;;;; Structures used by the graphical debugger
31
32 (defstruct (debug-display
33 (:conc-name dd-info-)
34 (:print-function print-debug-display)
35 (:constructor make-debug-display
36 (debug-pane errmsg restarts backtrace)))
37 (debug-pane nil :type (or null widget))
38 (errmsg nil :type (or null widget))
39 (restarts nil :type (or null widget))
40 (backtrace nil :type (or null widget))
41 (level 0 :type fixnum)
42 (connection nil :type (or null xt::motif-connection)))
43
44 (defun print-debug-display (info stream d)
45 (declare (ignore d))
46 (format stream "#<Debugger Display Info level ~d" (dd-info-level info)))
47
48
49
50 ;;;; Callback functions used by debugger
51
52 (defun quit-debugger-callback (widget call-data)
53 (declare (ignore widget call-data))
54 (close-motif-debugger *debug-condition*)
55 (throw 'lisp::top-level-catcher nil))
56
57 (defun restart-callback (widget call-data restart)
58 (declare (ignore widget call-data))
59 (invoke-restart-interactively restart))
60
61 (defun stack-frame-callback (widget call-data frame)
62 (declare (ignore widget call-data))
63 (unless (assoc frame *debug-active-frames*)
64 ;; Should wrap this in a busy cursor
65 (debug-display-frame frame)))
66
67 (defun close-all-callback (widget call-data)
68 (declare (ignore widget call-data))
69 (dolist (info *debug-active-frames*)
70 (destroy-widget (cdr info)))
71 (setf *debug-active-frames* nil))
72
73 ;;; This is to provide a means for recording the stack backtrace. In
74 ;;; particular, this is important for sending bug reports.
75 ;;;
76 (defun dump-backtrace-callback (widget call-data)
77 (declare (ignore widget call-data))
78 (let ((*current-frame* (di:top-frame)))
79 (format t "~%Stack Backtrace:~%")
80 (backtrace)))
81
82 (defun frame-view-callback (widget call-data thing)
83 (declare (ignore widget call-data))
84 ;; Should wrap this in a busy cursor
85 (inspect thing))
86
87 (defun close-frame-callback (widget call-data frame)
88 (declare (ignore widget call-data))
89 (setf *debug-active-frames*
90 (delete frame *debug-active-frames*
91 :test #'(lambda (a b) (eql a (car b)))))
92 (destroy-interface-pane frame))
93
94 (defun edit-source-callback (widget call-data frame)
95 (declare (ignore widget call-data))
96 (handler-case
97 (let ((*current-frame* frame))
98 (funcall (debug-command-p :edit-source)))
99 (error (cond)
100 (interface-error (format nil "~A" cond)))))
101
102 (defun frame-eval-callback (widget call-data frame output)
103 (declare (ignore call-data))
104 (let* ((input (car (get-values widget :value)))
105 (mark (text-get-last-position output))
106 (response
107 (format nil "Eval>> ~a~%~a--------------------~%"
108 input
109 (handler-case
110 (multiple-value-bind
111 (out val)
112 (let ((*current-frame* frame))
113 (grab-output-as-string
114 (di:eval-in-frame frame (read-from-string input))))
115 (format nil "~a~s~%" out val))
116 (error (cond)
117 (format nil "~2&~A~2&" cond)))))
118 (length (length response)))
119 (declare (simple-string response))
120
121 (text-set-string widget "")
122 (text-insert output mark response)
123 ;; This is to make sure that things stay visible
124 (text-set-insertion-position output (+ length mark))))
125
126 (defun source-verbosity-callback (widget call-data frame srcview delta)
127 (declare (ignore widget call-data))
128 (let* ((current (car (get-values srcview :user-data)))
129 (new (+ current delta)))
130 (when (minusp new)
131 (setf new 0))
132 (let ((source (handler-case
133 (grab-output-as-string
134 (print-code-location-source-form
135 (di:frame-code-location frame) new))
136 (di:debug-condition (cond)
137 (declare (ignore cond))
138 "Source form not available."))))
139 (set-values srcview
140 :label-string source
141 :user-data new))))
142
143
144
145 ;;; DEBUG-DISPLAY-FRAME-LOCALS -- Internal
146 ;;;
147 ;;; This sets up the display of the available local variables for the given
148 ;;; stack frame.
149 ;;;
150 (defun debug-display-frame-locals (frame debug-fun location frame-view)
151 (let (widgets)
152 (if (di:debug-variable-info-available debug-fun)
153 (let ((any-p nil)
154 (any-valid-p nil))
155 (di:do-debug-function-variables (v debug-fun)
156 (unless any-p
157 (setf any-p t)
158 (push (create-label frame-view "localsLabel"
159 :font-list *header-font*
160 :label-string "Local variables:")
161 widgets))
162 (when (eq (di:debug-variable-validity v location) :valid)
163 (let ((value (di:debug-variable-value v frame))
164 (id (di:debug-variable-id v)))
165 (setf any-valid-p t)
166 (push
167 (create-value-box frame-view
168 (format nil " ~A~:[#~D~;~*~]:"
169 (di:debug-variable-name v)
170 (zerop id) id)
171 value
172 :callback 'frame-view-callback)
173 widgets))))
174 (cond
175 ((not any-p)
176 (push
177 (create-label frame-view "noLocals"
178 :font-list *italic-font*
179 :label-string
180 " No local variables in function.")
181 widgets))
182 ((not any-valid-p)
183 (push
184 (create-label frame-view "noValidLocals"
185 :font-list *italic-font*
186 :label-string
187 " All variables have invalid values.")
188 widgets))))
189
190 (push (create-label frame-view "noVariableInfo"
191 :font-list *italic-font*
192 :label-string
193 " No variable information available.")
194 widgets))
195 (apply #'manage-children widgets)))
196
197 ;;; DEBUG-DISPLAY-FRAME-PROMPT -- Internal
198 ;;;
199 ;;; Every frame window has a Frame Eval area. This function creates the
200 ;;; Eval area and attaches the necessary callbacks.
201 ;;;
202 (defun debug-display-frame-prompt (frame frame-view)
203 (let* ((form (create-form frame-view "promptForm"))
204 (label (create-label form "framePrompt"
205 :label-string "Frame Eval:"
206 :font-list *header-font*))
207 (entry (create-text form "frameEval"
208 :top-attachment :attach-widget
209 :top-widget label
210 :left-attachment :attach-form
211 :right-attachment :attach-form))
212 (output (create-text form "frameOutput"
213 :edit-mode :multi-line-edit
214 :editable nil
215 :rows 8
216 :columns 40
217 :top-attachment :attach-widget
218 :top-widget entry
219 :bottom-attachment :attach-form
220 :left-attachment :attach-form
221 :right-attachment :attach-form)))
222
223 (manage-child form)
224 (manage-children label entry output)
225 (add-callback entry :activate-callback 'frame-eval-callback
226 frame output)))
227
228 ;;; DEBUG-DISPLAY-FRAME -- Internal
229 ;;;
230 ;;; Function to generate the graphical display for the given frame. Each
231 ;;; frame window is composed of the following parts:
232 ;;; - The function called
233 ;;; - The source form
234 ;;; - Local variables
235 ;;; - Frame Eval window
236 ;;;
237 (defun debug-display-frame (frame)
238 (let* ((debug-fun (di:frame-debug-function frame))
239 (location (di:frame-code-location frame))
240 (name (di:debug-function-name debug-fun))
241 (title (format nil "Stack Frame: ~A" name))
242 (frame-shell (create-interface-pane-shell title frame))
243 (frame-view (create-row-column frame-shell "debugFrameView"))
244 (menu-bar (create-menu-bar frame-view "frameMenu"))
245 (fcall (create-label frame-view "frameCall"
246 :label-string
247 (format nil "Frame Call: ~a"
248 (grab-output-as-string
249 (print-frame-call frame)))))
250 (fbox (create-value-box frame-view "Function:"
251 name
252 :callback 'frame-view-callback
253 :client-data
254 (di:debug-function-function debug-fun)))
255 (slabel (create-label frame-view "sourceLabel"
256 :font-list *header-font*
257 :label-string "Source form:"))
258 (swindow (create-scrolled-window frame-view "frameSourceWindow"
259 :scrolling-policy :automatic
260 :scroll-bar-placement :bottom-right))
261
262 (source (handler-case
263 (grab-output-as-string
264 (print-code-location-source-form location 0))
265 (di:debug-condition (cond)
266 (declare (ignore cond))
267 "Source form not available.")))
268 (srcview (create-label swindow "sourceForm"
269 :alignment :alignment-beginning
270 :user-data 0
271 :label-string source))
272 (cascade1
273 (create-interface-menu menu-bar "Frame"
274 `(("Edit Source" edit-source-callback ,frame)
275 ("Expand Source Form" source-verbosity-callback ,frame ,srcview 1)
276 ("Shrink Source Form" source-verbosity-callback ,frame ,srcview -1)
277 ("Close Frame" close-frame-callback ,frame))))
278 (cascade2 (create-cached-menu menu-bar "Debug")))
279
280 (manage-child frame-view)
281 (manage-children menu-bar fcall fbox slabel swindow)
282 (manage-child srcview)
283 (manage-children cascade1 cascade2)
284
285 (debug-display-frame-locals frame debug-fun location frame-view)
286 (debug-display-frame-prompt frame frame-view)
287
288 (popup-interface-pane frame-shell)
289 (push (cons frame frame-shell) *debug-active-frames*)))
290
291
292
293 ;;;; Functions to display the debugger control panel
294
295 ;;; DEBUG-DISPLAY-ERROR -- Internal
296 ;;;
297 ;;; Fills in the given widget with the error message for the given
298 ;;; condition.
299 ;;;
300 (defun debug-display-error (errmsg condition)
301 (set-values errmsg :label-string (format nil "~A" condition)))
302
303 ;;; DEBUG-DISPLAY-RESTARTS -- Internal
304 ;;;
305 ;;; Fills in a RowColumn box with buttons corresponding to the currently
306 ;;; active restarts.
307 ;;;
308 (defun debug-display-restarts (restart-view)
309 (let ((widgets (reverse (xti:widget-children restart-view)))
310 (used-ones))
311
312 (dolist (r *debug-restarts*)
313 (let* ((label (format nil "~A" r))
314 (button (if widgets
315 (let ((w (pop widgets)))
316 (set-values w :label-string label)
317 (remove-all-callbacks w :activate-callback)
318 w)
319 (create-highlight-button restart-view
320 "restartButton"
321 label))))
322
323 (add-callback button :activate-callback 'restart-callback r)
324 (push button used-ones)))
325 (apply #'manage-children used-ones)
326 (when widgets
327 (apply #'unmanage-children widgets))))
328
329 ;;; DEBUG-DISPLAY-STACK -- Internal
330 ;;;
331 ;;; Fills in a RowColumn box with buttons corresponding to the stack frames
332 ;;; found on the stack.
333 ;;;
334 (defun debug-display-stack (backtrace)
335 (let ((widgets (reverse (xti:widget-children backtrace)))
336 (used-ones)
337 (frames))
338
339 (do ((frame *current-frame* (di:frame-down frame)))
340 ((null frame))
341 (push frame frames))
342 (setf frames (nreverse frames))
343
344 (dolist (frame frames)
345 (let* ((label (grab-output-as-string
346 (print-frame-call frame)))
347 (button (if widgets
348 (let ((w (pop widgets)))
349 (set-values w :label-string label)
350 (remove-all-callbacks w :activate-callback)
351 w)
352 (create-highlight-button
353 backtrace "stackFrame" label))))
354 (add-callback button :activate-callback 'stack-frame-callback frame)
355 (push button used-ones)))
356 (apply #'manage-children used-ones)
357 (when widgets
358 (apply #'unmanage-children widgets))))
359
360 ;;; REALLY-CREATE-DEBUGGER -- Internal
361 ;;;
362 ;;; This creates all the widgets used by the main debugger window. It
363 ;;; calls various sub-functions such as DEBUG-DISPLAY-STACK to fill in the
364 ;;; various display sections. It should only be called if there are no old
365 ;;; debugger panes available for recycling.
366 ;;;
367 (defun really-create-debugger (condition)
368 (let* ((debug-pane (create-interface-pane-shell "Debugger" condition))
369 (frame (create-frame debug-pane "debugFrame"))
370 (form (create-form frame "debugForm"))
371 (menu-bar (create-menu-bar form "debugMenu"
372 :left-attachment :attach-form
373 :right-attachment :attach-form))
374 (cascade (create-cached-menu
375 menu-bar "Debug"
376 '(("Close All Frames" close-all-callback)
377 ("Dump Backtrace" dump-backtrace-callback)
378 ("Quit Debugger" quit-debugger-callback))))
379 (errlabel (create-label form "errorLabel"
380 :top-attachment :attach-widget
381 :top-widget menu-bar
382 :left-attachment :attach-form
383 :font-list *header-font*
384 :label-string "Error Message:"))
385 (errmsg (create-label form "errorMessage"
386 :top-attachment :attach-widget
387 :top-widget errlabel
388 :left-attachment :attach-form
389 :right-attachment :attach-form))
390 (rlabel (create-label form "restartLabel"
391 :top-attachment :attach-widget
392 :top-widget errmsg
393 :left-attachment :attach-form
394 :font-list *header-font*))
395 (restarts (create-row-column form "debugRestarts"
396 :adjust-last nil
397 :top-attachment :widget
398 :top-widget rlabel
399 :left-attachment :attach-form
400 :right-attachment :attach-form
401 :left-offset 10))
402 (btlabel (create-label form "backtraceLabel"
403 :label-string "Stack Backtrace:"
404 :font-list *header-font*
405 :top-attachment :attach-widget
406 :top-widget restarts
407 :left-attachment :attach-form))
408 (btwindow (create-scrolled-window form "backtraceWindow"
409 :scrolling-policy :automatic
410 :scroll-bar-placement :bottom-right
411 :left-attachment :attach-form
412 :right-attachment :attach-form
413 :left-offset 4
414 :right-offset 4
415 :bottom-offset 4
416 :bottom-attachment :attach-form
417 :top-attachment :attach-widget
418 :top-widget btlabel))
419 (backtrace (create-row-column btwindow "debugBacktrace"
420 :adjust-last nil
421 :spacing 1)))
422
423 (manage-child frame) (manage-child form)
424 (manage-children menu-bar errlabel errmsg rlabel restarts btlabel btwindow)
425 (manage-child backtrace)
426 (manage-child cascade)
427
428 (debug-display-error errmsg condition)
429
430 (if *debug-restarts*
431 (progn
432 (set-values rlabel :label-string "Restarts:")
433 (debug-display-restarts restarts))
434 (set-values rlabel :label-string "No restarts available"))
435
436 (let ((quick-stack (create-highlight-button backtrace "quickStack"
437 "Display Stack")))
438 (add-callback quick-stack :activate-callback
439 #'(lambda (w c) (declare (ignore w c))
440 (debug-display-stack backtrace)))
441 (manage-child quick-stack))
442
443
444 (setf *current-debug-display*
445 (make-debug-display debug-pane errmsg restarts backtrace))
446
447 (popup-interface-pane debug-pane)
448 debug-pane))
449
450 ;;; REUSE-DEBUGGER -- Internal
451 ;;;
452 ;;; Takes an old debugger pane and a new condition. It renovates the old
453 ;;; display to reflect the current debugging state. This should be used
454 ;;; whenever possible since it is quite a bit faster than creating a new
455 ;;; debugger pane from scratch.
456 ;;;
457 (defun reuse-debugger (condition info)
458 (let ((debug-pane (dd-info-debug-pane info))
459 (errmsg (dd-info-errmsg info))
460 (restarts (dd-info-restarts info))
461 (backtrace (dd-info-backtrace info)))
462
463 (debug-display-error errmsg condition)
464 (debug-display-restarts restarts)
465
466 (let* ((buttons (xti:widget-children backtrace))
467 (quick-stack (car buttons)))
468 (remove-all-callbacks quick-stack :activate-callback)
469 (set-values quick-stack :label-string "Display Stack")
470 (add-callback quick-stack :activate-callback
471 #'(lambda (w c) (declare (ignore w c))
472 (debug-display-stack backtrace)))
473 (manage-child quick-stack)
474 (apply #'unmanage-children (cdr buttons)))
475
476 (setf *current-debug-display* info)
477 (popup-interface-pane debug-pane)
478 debug-pane))
479
480 ;;; CREATE-DEBUGGER -- Internal
481 ;;;
482 ;;; Creates a graphical debugger display for the given condition. It will
483 ;;; attempt to reuse any available old panes. However, if none are
484 ;;; available, it will create a new display frame.
485 ;;;
486 (defun create-debugger (condition)
487 (if *old-display-frames*
488 (reuse-debugger condition (pop *old-display-frames*))
489 (really-create-debugger condition)))
490
491 ;;; CLOSE-MOTIF-DEBUGGER -- Internal
492 ;;;
493 ;;; This function should always be called before leaving the context of the
494 ;;; debugger. It closes down the frame windows and marks the main debug
495 ;;; display pane as ready for recycling.
496 ;;;
497 (defun close-motif-debugger (condition)
498 (declare (ignore condition))
499 (push *current-debug-display* *old-display-frames*)
500 ;;
501 ;; Destroy all frame panes
502 (dolist (info *debug-active-frames*)
503 (destroy-widget (cdr info)))
504 (setf *debug-active-frames* nil)
505 ;;
506 ;; Remove the restart/backtrace window
507 (popdown (dd-info-debug-pane *current-debug-display*))
508 (setf *current-debug-display* nil)
509
510 (format t "Leaving debugger.~%"))
511
512 ;;; INVOKE-MOTIF-DEBUGGER -- Internal
513 ;;;
514 ;;; This function essentially mimics the functions which manage the TTY
515 ;;; debugger, but uses a graphical debugging display instead.
516 ;;;
517 (defun invoke-motif-debugger (condition)
518 (let* ((*in-the-debugger* t)
519 (frame (di:top-frame))
520 (previous-display *current-debug-display*)
521 (*current-debug-display* nil)
522 (*debug-active-frames* nil))
523 (declare (ignore previous-display))
524 (verify-system-server-exists)
525 (multiple-value-bind (shell connection)
526 (create-interface-shell)
527 (declare (ignore shell))
528 (with-motif-connection (connection)
529 (let ((pane (find-interface-pane condition))
530 (*current-frame* frame))
531 (unless pane
532 (setf pane (create-debugger condition)))
533 (unless (is-managed pane)
534 (popup-interface-pane pane))
535 (setf (dd-info-level *current-debug-display*) *debug-command-level*)
536 (setf (dd-info-connection *current-debug-display*) connection)
537 (unwind-protect
538 (handler-case
539 (loop
540 (system:serve-event))
541 (error (err)
542 (if *flush-debug-errors*
543 (interface-error (format nil "~a" err) pane)
544 (interface-error
545 "Do not yet support recursive debugging" pane))))
546 (when (and connection *current-debug-display*)
547 (with-motif-connection (connection)
548 (close-motif-debugger condition)))))))))
549
550
551
552 ;;; INVOKE-DEBUGGER -- Public
553 ;;;
554 ;;; Invokes the Lisp debugger. It executes some common debugger setup code
555 ;;; and then decides whether to invoke the TTY debugger or the Motif
556 ;;; debugger.
557 ;;;
558 (defun invoke-debugger (condition)
559 "The CMU Common Lisp debugger. Type h for help."
560 (when *debugger-hook*
561 (let ((hook *debugger-hook*)
562 (*debugger-hook* nil))
563 (funcall hook condition hook)))
564 (unix:unix-sigsetmask 0)
565 (let* ((*debug-condition* condition)
566 (*debug-restarts* (compute-restarts))
567 (*standard-input* *debug-io*) ;in case of setq
568 (*standard-output* *debug-io*) ;'' '' '' ''
569 (*error-output* *debug-io*)
570 ;; Rebind some printer control variables.
571 (kernel:*current-level* 0)
572 (*print-readably* nil)
573 (*read-eval* t))
574 (if (or (not (use-graphics-interface))
575 (typep condition 'xti:toolkit-error))
576 (progn
577 (format *error-output* "~2&~A~2&" *debug-condition*)
578 (unless (typep condition 'step-condition)
579 (show-restarts *debug-restarts* *error-output*))
580 (internal-debug))
581 (progn
582 (write-line "Invoking debugger...")
583 (invoke-motif-debugger condition)))))

  ViewVC Help
Powered by ViewVC 1.1.5