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

Contents of /src/interface/debug.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Thu Mar 3 16:57:31 1994 UTC (20 years, 1 month ago) by ram
Branch: MAIN
Changes since 1.6: +37 -26 lines
Add INVOKE-TTY-DEBUGGER.  Don't try to invoke motif debugger if we didn't
succeed in opening a connection.
1 garland 1.1 ;;;; -*- Mode: Lisp ; Package: Debug -*-
2     ;;;
3 garland 1.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 garland 1.1
16     (in-package "DEBUG")
17     (use-package '("TOOLKIT" "INTERFACE"))
18    
19 garland 1.4 ;;; 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 garland 1.1 (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 garland 1.3 (debug-pane errmsg restarts backtrace)))
37 garland 1.1 (debug-pane nil :type (or null widget))
38 garland 1.3 (errmsg nil :type (or null widget))
39 garland 1.1 (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 garland 1.4 ;;;; Callback functions used by debugger
51 garland 1.1
52 garland 1.3 (defun quit-debugger-callback (widget call-data)
53 garland 1.1 (declare (ignore widget call-data))
54 garland 1.3 (close-motif-debugger *debug-condition*)
55 garland 1.1 (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 garland 1.4 ;;; 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 garland 1.1 (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 garland 1.4 (defun edit-source-callback (widget call-data frame)
95 garland 1.1 (declare (ignore widget call-data))
96 garland 1.4 (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 garland 1.1
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 garland 1.4 ;;; 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 garland 1.1 (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 garland 1.2 (push (create-label frame-view "localsLabel"
159 garland 1.1 :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 garland 1.2 (create-label frame-view "noLocals"
178 garland 1.1 :font-list *italic-font*
179     :label-string
180     " No local variables in function.")
181     widgets))
182     ((not any-valid-p)
183     (push
184 garland 1.2 (create-label frame-view "noValidLocals"
185 garland 1.1 :font-list *italic-font*
186     :label-string
187     " All variables have invalid values.")
188     widgets))))
189    
190 garland 1.2 (push (create-label frame-view "noVariableInfo"
191 garland 1.1 :font-list *italic-font*
192     :label-string
193     " No variable information available.")
194     widgets))
195     (apply #'manage-children widgets)))
196    
197 garland 1.4 ;;; 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 garland 1.1 (defun debug-display-frame-prompt (frame frame-view)
203     (let* ((form (create-form frame-view "promptForm"))
204 garland 1.2 (label (create-label form "framePrompt"
205 garland 1.1 :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 garland 1.4 ;;; 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 garland 1.1 (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 garland 1.2 (fcall (create-label frame-view "frameCall"
246 garland 1.1 :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 garland 1.2 (slabel (create-label frame-view "sourceLabel"
256 garland 1.1 :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 garland 1.2 (srcview (create-label swindow "sourceForm"
269     :alignment :alignment-beginning
270     :user-data 0
271     :label-string source))
272 garland 1.1 (cascade1
273     (create-interface-menu menu-bar "Frame"
274 garland 1.4 `(("Edit Source" edit-source-callback ,frame)
275 garland 1.1 ("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 garland 1.4 ;;; DEBUG-DISPLAY-ERROR -- Internal
296     ;;;
297     ;;; Fills in the given widget with the error message for the given
298     ;;; condition.
299     ;;;
300 garland 1.1 (defun debug-display-error (errmsg condition)
301     (set-values errmsg :label-string (format nil "~A" condition)))
302    
303 garland 1.4 ;;; DEBUG-DISPLAY-RESTARTS -- Internal
304     ;;;
305     ;;; Fills in a RowColumn box with buttons corresponding to the currently
306     ;;; active restarts.
307     ;;;
308 garland 1.3 (defun debug-display-restarts (restart-view)
309     (let ((widgets (reverse (xti:widget-children restart-view)))
310     (used-ones))
311    
312 garland 1.1 (dolist (r *debug-restarts*)
313 garland 1.3 (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 garland 1.1 (add-callback button :activate-callback 'restart-callback r)
324 garland 1.3 (push button used-ones)))
325     (apply #'manage-children used-ones)
326     (when widgets
327     (apply #'unmanage-children widgets))))
328 garland 1.1
329 garland 1.4 ;;; 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 garland 1.1 (defun debug-display-stack (backtrace)
335 garland 1.3 (let ((widgets (reverse (xti:widget-children backtrace)))
336     (used-ones)
337     (frames))
338    
339 garland 1.1 (do ((frame *current-frame* (di:frame-down frame)))
340     ((null frame))
341 garland 1.3 (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 garland 1.1 (add-callback button :activate-callback 'stack-frame-callback frame)
355 garland 1.3 (push button used-ones)))
356     (apply #'manage-children used-ones)
357     (when widgets
358     (apply #'unmanage-children widgets))))
359 garland 1.1
360 garland 1.4 ;;; 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 garland 1.3 (defun really-create-debugger (condition)
368 garland 1.1 (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 garland 1.3 '(("Close All Frames" close-all-callback)
377 garland 1.4 ("Dump Backtrace" dump-backtrace-callback)
378 garland 1.3 ("Quit Debugger" quit-debugger-callback))))
379 garland 1.2 (errlabel (create-label form "errorLabel"
380 garland 1.1 :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 garland 1.2 (errmsg (create-label form "errorMessage"
386 garland 1.1 :top-attachment :attach-widget
387     :top-widget errlabel
388     :left-attachment :attach-form
389     :right-attachment :attach-form))
390 garland 1.2 (rlabel (create-label form "restartLabel"
391 garland 1.1 :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 garland 1.2 (btlabel (create-label form "backtraceLabel"
403 garland 1.1 :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 garland 1.3 (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 garland 1.1
443 garland 1.3
444 garland 1.1 (setf *current-debug-display*
445 garland 1.3 (make-debug-display debug-pane errmsg restarts backtrace))
446 garland 1.1
447     (popup-interface-pane debug-pane)
448     debug-pane))
449 garland 1.3
450 garland 1.4 ;;; 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 garland 1.3 (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 garland 1.4 ;;; 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 garland 1.3 (defun create-debugger (condition)
487     (if *old-display-frames*
488     (reuse-debugger condition (pop *old-display-frames*))
489     (really-create-debugger condition)))
490    
491 garland 1.4 ;;; 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 garland 1.1 (defun close-motif-debugger (condition)
498 garland 1.3 (declare (ignore condition))
499 garland 1.1 (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 garland 1.3 ;; Remove the restart/backtrace window
507     (popdown (dd-info-debug-pane *current-debug-display*))
508 garland 1.1 (setf *current-debug-display* nil)
509    
510     (format t "Leaving debugger.~%"))
511    
512 garland 1.4 ;;; 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 garland 1.1 (defun invoke-motif-debugger (condition)
518 garland 1.4 (let* ((*in-the-debugger* t)
519     (frame (di:top-frame))
520 garland 1.1 (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 ram 1.7 (if connection
529     (with-motif-connection (connection)
530     (let ((pane (find-interface-pane condition))
531     (*current-frame* frame))
532     (unless pane
533     (setf pane (create-debugger condition)))
534     (unless (is-managed pane)
535     (popup-interface-pane pane))
536     (setf (dd-info-level *current-debug-display*)
537     *debug-command-level*)
538     (setf (dd-info-connection *current-debug-display*) connection)
539     (unwind-protect
540     (handler-case
541     (loop
542     (system:serve-event))
543     (error (err)
544     (if *flush-debug-errors*
545     (interface-error (format nil "~a" err) pane)
546     (interface-error
547     "Do not yet support recursive debugging"
548     pane))))
549     (when (and connection *current-debug-display*)
550     (with-motif-connection (connection)
551     (close-motif-debugger condition))))))
552     (invoke-tty-debugger condition)))))
553 garland 1.1
554    
555    
556 ram 1.6 ;;; Used to prevent recursive invocations of the windowing debugger.
557     ;;;
558     (defvar *in-windowing-debugger* nil)
559    
560 ram 1.7
561     ;;; INVOKE-TTY-DEBUGGER -- Internal
562     ;;;
563     ;;; Print condition and invoke the TTY debugger.
564     ;;;
565     (defun invoke-tty-debugger (condition)
566     (format *error-output* "~2&~A~2&" *debug-condition*)
567     (unless (typep condition 'step-condition)
568     (show-restarts *debug-restarts* *error-output*))
569     (internal-debug))
570    
571 garland 1.4 ;;; INVOKE-DEBUGGER -- Public
572     ;;;
573     ;;; Invokes the Lisp debugger. It executes some common debugger setup code
574     ;;; and then decides whether to invoke the TTY debugger or the Motif
575     ;;; debugger.
576     ;;;
577 garland 1.1 (defun invoke-debugger (condition)
578     "The CMU Common Lisp debugger. Type h for help."
579     (when *debugger-hook*
580     (let ((hook *debugger-hook*)
581     (*debugger-hook* nil))
582     (funcall hook condition hook)))
583     (unix:unix-sigsetmask 0)
584     (let* ((*debug-condition* condition)
585 ram 1.5 (*debug-restarts* (compute-restarts condition))
586 garland 1.1 (*standard-input* *debug-io*) ;in case of setq
587     (*standard-output* *debug-io*) ;'' '' '' ''
588     (*error-output* *debug-io*)
589     ;; Rebind some printer control variables.
590     (kernel:*current-level* 0)
591     (*print-readably* nil)
592     (*read-eval* t))
593     (if (or (not (use-graphics-interface))
594 ram 1.6 *in-windowing-debugger*
595 garland 1.1 (typep condition 'xti:toolkit-error))
596 ram 1.7 (invoke-tty-debugger condition)
597 ram 1.6 (let ((*in-windowing-debugger* t))
598 garland 1.1 (write-line "Invoking debugger...")
599     (invoke-motif-debugger condition)))))

  ViewVC Help
Powered by ViewVC 1.1.5