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

Contents of /src/interface/debug.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5