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

Contents of /src/interface/debug.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide annotations)
Mon Oct 31 04:53:18 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: RELEASE_18a, RELEASE_18b, RELEASE_18c
Branch point for: RELENG_18
Changes since 1.7: +3 -2 lines
Fix headed boilerplate.
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 ram 1.8 ;;;
7     (ext:file-comment
8     "$Header: /tiger/var/lib/cvsroots/cmucl/src/interface/debug.lisp,v 1.8 1994/10/31 04:53:18 ram Exp $")
9 garland 1.3 ;;;
10     ;;; **********************************************************************
11     ;;;
12     ;;; Written by Michael Garland
13     ;;;
14     ;;; This file implements the graphical interface to the debugger.
15     ;;;
16 garland 1.1
17     (in-package "DEBUG")
18     (use-package '("TOOLKIT" "INTERFACE"))
19    
20 garland 1.4 ;;; 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 garland 1.1 (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 garland 1.3 (debug-pane errmsg restarts backtrace)))
38 garland 1.1 (debug-pane nil :type (or null widget))
39 garland 1.3 (errmsg nil :type (or null widget))
40 garland 1.1 (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 garland 1.4 ;;;; Callback functions used by debugger
52 garland 1.1
53 garland 1.3 (defun quit-debugger-callback (widget call-data)
54 garland 1.1 (declare (ignore widget call-data))
55 garland 1.3 (close-motif-debugger *debug-condition*)
56 garland 1.1 (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 garland 1.4 ;;; 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 garland 1.1 (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 garland 1.4 (defun edit-source-callback (widget call-data frame)
96 garland 1.1 (declare (ignore widget call-data))
97 garland 1.4 (handler-case
98     (let ((*current-frame* frame))
99     (funcall (debug-command-p :edit-source)))
100     (error (cond)
101     (interface-error (format nil "~A" cond)))))
102 garland 1.1
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     (format nil "~2&~A~2&" 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 garland 1.4 ;;; 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 garland 1.1 (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 garland 1.2 (push (create-label frame-view "localsLabel"
160 garland 1.1 :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 garland 1.2 (create-label frame-view "noLocals"
179 garland 1.1 :font-list *italic-font*
180     :label-string
181     " No local variables in function.")
182     widgets))
183     ((not any-valid-p)
184     (push
185 garland 1.2 (create-label frame-view "noValidLocals"
186 garland 1.1 :font-list *italic-font*
187     :label-string
188     " All variables have invalid values.")
189     widgets))))
190    
191 garland 1.2 (push (create-label frame-view "noVariableInfo"
192 garland 1.1 :font-list *italic-font*
193     :label-string
194     " No variable information available.")
195     widgets))
196     (apply #'manage-children widgets)))
197    
198 garland 1.4 ;;; 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 garland 1.1 (defun debug-display-frame-prompt (frame frame-view)
204     (let* ((form (create-form frame-view "promptForm"))
205 garland 1.2 (label (create-label form "framePrompt"
206 garland 1.1 :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 garland 1.4 ;;; 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 garland 1.1 (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 garland 1.2 (fcall (create-label frame-view "frameCall"
247 garland 1.1 :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 garland 1.2 (slabel (create-label frame-view "sourceLabel"
257 garland 1.1 :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 garland 1.2 (srcview (create-label swindow "sourceForm"
270     :alignment :alignment-beginning
271     :user-data 0
272     :label-string source))
273 garland 1.1 (cascade1
274     (create-interface-menu menu-bar "Frame"
275 garland 1.4 `(("Edit Source" edit-source-callback ,frame)
276 garland 1.1 ("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 garland 1.4 ;;; DEBUG-DISPLAY-ERROR -- Internal
297     ;;;
298     ;;; Fills in the given widget with the error message for the given
299     ;;; condition.
300     ;;;
301 garland 1.1 (defun debug-display-error (errmsg condition)
302     (set-values errmsg :label-string (format nil "~A" condition)))
303    
304 garland 1.4 ;;; DEBUG-DISPLAY-RESTARTS -- Internal
305     ;;;
306     ;;; Fills in a RowColumn box with buttons corresponding to the currently
307     ;;; active restarts.
308     ;;;
309 garland 1.3 (defun debug-display-restarts (restart-view)
310     (let ((widgets (reverse (xti:widget-children restart-view)))
311     (used-ones))
312    
313 garland 1.1 (dolist (r *debug-restarts*)
314 garland 1.3 (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 garland 1.1 (add-callback button :activate-callback 'restart-callback r)
325 garland 1.3 (push button used-ones)))
326     (apply #'manage-children used-ones)
327     (when widgets
328     (apply #'unmanage-children widgets))))
329 garland 1.1
330 garland 1.4 ;;; 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 garland 1.1 (defun debug-display-stack (backtrace)
336 garland 1.3 (let ((widgets (reverse (xti:widget-children backtrace)))
337     (used-ones)
338     (frames))
339    
340 garland 1.1 (do ((frame *current-frame* (di:frame-down frame)))
341     ((null frame))
342 garland 1.3 (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 garland 1.1 (add-callback button :activate-callback 'stack-frame-callback frame)
356 garland 1.3 (push button used-ones)))
357     (apply #'manage-children used-ones)
358     (when widgets
359     (apply #'unmanage-children widgets))))
360 garland 1.1
361 garland 1.4 ;;; 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 garland 1.3 (defun really-create-debugger (condition)
369 garland 1.1 (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 garland 1.3 '(("Close All Frames" close-all-callback)
378 garland 1.4 ("Dump Backtrace" dump-backtrace-callback)
379 garland 1.3 ("Quit Debugger" quit-debugger-callback))))
380 garland 1.2 (errlabel (create-label form "errorLabel"
381 garland 1.1 :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 garland 1.2 (errmsg (create-label form "errorMessage"
387 garland 1.1 :top-attachment :attach-widget
388     :top-widget errlabel
389     :left-attachment :attach-form
390     :right-attachment :attach-form))
391 garland 1.2 (rlabel (create-label form "restartLabel"
392 garland 1.1 :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 garland 1.2 (btlabel (create-label form "backtraceLabel"
404 garland 1.1 :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 garland 1.3 (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 garland 1.1
444 garland 1.3
445 garland 1.1 (setf *current-debug-display*
446 garland 1.3 (make-debug-display debug-pane errmsg restarts backtrace))
447 garland 1.1
448     (popup-interface-pane debug-pane)
449     debug-pane))
450 garland 1.3
451 garland 1.4 ;;; 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 garland 1.3 (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 garland 1.4 ;;; 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 garland 1.3 (defun create-debugger (condition)
488     (if *old-display-frames*
489     (reuse-debugger condition (pop *old-display-frames*))
490     (really-create-debugger condition)))
491    
492 garland 1.4 ;;; 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 garland 1.1 (defun close-motif-debugger (condition)
499 garland 1.3 (declare (ignore condition))
500 garland 1.1 (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 garland 1.3 ;; Remove the restart/backtrace window
508     (popdown (dd-info-debug-pane *current-debug-display*))
509 garland 1.1 (setf *current-debug-display* nil)
510    
511     (format t "Leaving debugger.~%"))
512    
513 garland 1.4 ;;; 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 garland 1.1 (defun invoke-motif-debugger (condition)
519 garland 1.4 (let* ((*in-the-debugger* t)
520     (frame (di:top-frame))
521 garland 1.1 (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 ram 1.7 (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 (format nil "~a" err) pane)
547     (interface-error
548     "Do not yet support recursive debugging"
549     pane))))
550     (when (and connection *current-debug-display*)
551     (with-motif-connection (connection)
552     (close-motif-debugger condition))))))
553     (invoke-tty-debugger condition)))))
554 garland 1.1
555    
556    
557 ram 1.6 ;;; Used to prevent recursive invocations of the windowing debugger.
558     ;;;
559     (defvar *in-windowing-debugger* nil)
560    
561 ram 1.7
562     ;;; INVOKE-TTY-DEBUGGER -- Internal
563     ;;;
564     ;;; Print condition and invoke the TTY debugger.
565     ;;;
566     (defun invoke-tty-debugger (condition)
567     (format *error-output* "~2&~A~2&" *debug-condition*)
568     (unless (typep condition 'step-condition)
569     (show-restarts *debug-restarts* *error-output*))
570     (internal-debug))
571    
572 garland 1.4 ;;; INVOKE-DEBUGGER -- Public
573     ;;;
574     ;;; Invokes the Lisp debugger. It executes some common debugger setup code
575     ;;; and then decides whether to invoke the TTY debugger or the Motif
576     ;;; debugger.
577     ;;;
578 garland 1.1 (defun invoke-debugger (condition)
579     "The CMU Common Lisp debugger. Type h for help."
580     (when *debugger-hook*
581     (let ((hook *debugger-hook*)
582     (*debugger-hook* nil))
583     (funcall hook condition hook)))
584     (unix:unix-sigsetmask 0)
585     (let* ((*debug-condition* condition)
586 ram 1.5 (*debug-restarts* (compute-restarts condition))
587 garland 1.1 (*standard-input* *debug-io*) ;in case of setq
588     (*standard-output* *debug-io*) ;'' '' '' ''
589     (*error-output* *debug-io*)
590     ;; Rebind some printer control variables.
591     (kernel:*current-level* 0)
592     (*print-readably* nil)
593     (*read-eval* t))
594     (if (or (not (use-graphics-interface))
595 ram 1.6 *in-windowing-debugger*
596 garland 1.1 (typep condition 'xti:toolkit-error))
597 ram 1.7 (invoke-tty-debugger condition)
598 ram 1.6 (let ((*in-windowing-debugger* t))
599 garland 1.1 (write-line "Invoking debugger...")
600     (invoke-motif-debugger condition)))))

  ViewVC Help
Powered by ViewVC 1.1.5