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

Contents of /src/interface/debug.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Thu Nov 12 14:08:12 1992 UTC (21 years, 5 months ago) by garland
Branch: MAIN
Initial revision
1 garland 1.1 ;;;; -*- Mode: Lisp ; Package: Debug -*-
2     ;;;
3    
4     (in-package "DEBUG")
5     (use-package '("TOOLKIT" "INTERFACE"))
6    
7     (defvar *current-debug-display* nil)
8     (defvar *debug-active-frames* nil)
9     (defvar *old-display-frames* nil)
10    
11    
12    
13     ;;;; Structures used by the graphical debugger
14    
15     (defstruct (debug-display
16     (:conc-name dd-info-)
17     (:print-function print-debug-display)
18     (:constructor make-debug-display
19     (debug-pane restarts backtrace)))
20     (debug-pane nil :type (or null widget))
21     (restarts nil :type (or null widget))
22     (backtrace nil :type (or null widget))
23     (level 0 :type fixnum)
24     (connection nil :type (or null xt::motif-connection)))
25    
26     (defun print-debug-display (info stream d)
27     (declare (ignore d))
28     (format stream "#<Debugger Display Info level ~d" (dd-info-level info)))
29    
30    
31    
32     ;;;; Callback functions
33    
34     (defun quit-debugger-callback (widget call-data condition)
35     (declare (ignore widget call-data))
36     (close-motif-debugger condition)
37     (throw 'lisp::top-level-catcher nil))
38    
39     (defun restart-callback (widget call-data restart)
40     (declare (ignore widget call-data))
41     (invoke-restart-interactively restart))
42    
43     (defun stack-frame-callback (widget call-data frame)
44     (declare (ignore widget call-data))
45     (unless (assoc frame *debug-active-frames*)
46     ;; Should wrap this in a busy cursor
47     (debug-display-frame frame)))
48    
49     (defun ping-callback (widget call-data test)
50     (declare (ignore widget call-data))
51     (destroy-widget (car (xt::widget-children test))))
52    
53     (defun close-all-callback (widget call-data)
54     (declare (ignore widget call-data))
55     (dolist (info *debug-active-frames*)
56     (destroy-widget (cdr info)))
57     (setf *debug-active-frames* nil))
58    
59     (defun frame-view-callback (widget call-data thing)
60     (declare (ignore widget call-data))
61     ;; Should wrap this in a busy cursor
62     (inspect thing))
63    
64     (defun close-frame-callback (widget call-data frame)
65     (declare (ignore widget call-data))
66     (setf *debug-active-frames*
67     (delete frame *debug-active-frames*
68     :test #'(lambda (a b) (eql a (car b)))))
69     (destroy-interface-pane frame))
70    
71     (defun edit-source-callback (widget call-data)
72     (declare (ignore widget call-data))
73     (funcall (debug-command-p :edit-source)))
74    
75     (defun frame-eval-callback (widget call-data frame output)
76     (declare (ignore call-data))
77     (let* ((input (car (get-values widget :value)))
78     (mark (text-get-last-position output))
79     (response
80     (format nil "Eval>> ~a~%~a--------------------~%"
81     input
82     (handler-case
83     (multiple-value-bind
84     (out val)
85     (let ((*current-frame* frame))
86     (grab-output-as-string
87     (di:eval-in-frame frame (read-from-string input))))
88     (format nil "~a~s~%" out val))
89     (error (cond)
90     (format nil "~2&~A~2&" cond)))))
91     (length (length response)))
92     (declare (simple-string response))
93    
94     (text-set-string widget "")
95     (text-insert output mark response)
96     ;; This is to make sure that things stay visible
97     (text-set-insertion-position output (+ length mark))))
98    
99     (defun source-verbosity-callback (widget call-data frame srcview delta)
100     (declare (ignore widget call-data))
101     (let* ((current (car (get-values srcview :user-data)))
102     (new (+ current delta)))
103     (when (minusp new)
104     (setf new 0))
105     (let ((source (handler-case
106     (grab-output-as-string
107     (print-code-location-source-form
108     (di:frame-code-location frame) new))
109     (di:debug-condition (cond)
110     (declare (ignore cond))
111     "Source form not available."))))
112     (set-values srcview
113     :label-string source
114     :user-data new))))
115    
116    
117    
118     (defun debug-display-frame-locals (frame debug-fun location frame-view)
119     (let (widgets)
120     (if (di:debug-variable-info-available debug-fun)
121     (let ((any-p nil)
122     (any-valid-p nil))
123     (di:do-debug-function-variables (v debug-fun)
124     (unless any-p
125     (setf any-p t)
126     (push (create-label-gadget frame-view "localsLabel"
127     :font-list *header-font*
128     :label-string "Local variables:")
129     widgets))
130     (when (eq (di:debug-variable-validity v location) :valid)
131     (let ((value (di:debug-variable-value v frame))
132     (id (di:debug-variable-id v)))
133     (setf any-valid-p t)
134     (push
135     (create-value-box frame-view
136     (format nil " ~A~:[#~D~;~*~]:"
137     (di:debug-variable-name v)
138     (zerop id) id)
139     value
140     :callback 'frame-view-callback)
141     widgets))))
142     (cond
143     ((not any-p)
144     (push
145     (create-label-gadget frame-view "noLocals"
146     :font-list *italic-font*
147     :label-string
148     " No local variables in function.")
149     widgets))
150     ((not any-valid-p)
151     (push
152     (create-label-gadget frame-view "noValidLocals"
153     :font-list *italic-font*
154     :label-string
155     " All variables have invalid values.")
156     widgets))))
157    
158     (push (create-label-gadget frame-view "noVariableInfo"
159     :font-list *italic-font*
160     :label-string
161     " No variable information available.")
162     widgets))
163     (apply #'manage-children widgets)))
164    
165     (defun debug-display-frame-prompt (frame frame-view)
166     (let* ((form (create-form frame-view "promptForm"))
167     (label (create-label-gadget form "framePrompt"
168     :label-string "Frame Eval:"
169     :font-list *header-font*))
170     (entry (create-text form "frameEval"
171     :top-attachment :attach-widget
172     :top-widget label
173     :left-attachment :attach-form
174     :right-attachment :attach-form))
175     (output (create-text form "frameOutput"
176     :edit-mode :multi-line-edit
177     :editable nil
178     :rows 8
179     :columns 40
180     :top-attachment :attach-widget
181     :top-widget entry
182     :bottom-attachment :attach-form
183     :left-attachment :attach-form
184     :right-attachment :attach-form)))
185    
186     (manage-child form)
187     (manage-children label entry output)
188     (add-callback entry :activate-callback 'frame-eval-callback
189     frame output)))
190    
191     (defun debug-display-frame (frame)
192     (let* ((debug-fun (di:frame-debug-function frame))
193     (location (di:frame-code-location frame))
194     (name (di:debug-function-name debug-fun))
195     (title (format nil "Stack Frame: ~A" name))
196     (frame-shell (create-interface-pane-shell title frame))
197     (frame-view (create-row-column frame-shell "debugFrameView"))
198     (menu-bar (create-menu-bar frame-view "frameMenu"))
199     (fcall (create-label-gadget frame-view "frameCall"
200     :label-string
201     (format nil "Frame Call: ~a"
202     (grab-output-as-string
203     (print-frame-call frame)))))
204     (fbox (create-value-box frame-view "Function:"
205     name
206     :callback 'frame-view-callback
207     :client-data
208     (di:debug-function-function debug-fun)))
209     (slabel (create-label-gadget frame-view "sourceLabel"
210     :font-list *header-font*
211     :label-string "Source form:"))
212     (swindow (create-scrolled-window frame-view "frameSourceWindow"
213     :scrolling-policy :automatic
214     :scroll-bar-placement :bottom-right))
215    
216     (source (handler-case
217     (grab-output-as-string
218     (print-code-location-source-form location 0))
219     (di:debug-condition (cond)
220     (declare (ignore cond))
221     "Source form not available.")))
222     (srcview (create-label-gadget swindow "sourceForm"
223     :alignment :alignment-beginning
224     :user-data 0
225     :label-string source))
226     (cascade1
227     (create-interface-menu menu-bar "Frame"
228     `(("Edit Source" edit-source-callback)
229     ("Expand Source Form" source-verbosity-callback ,frame ,srcview 1)
230     ("Shrink Source Form" source-verbosity-callback ,frame ,srcview -1)
231     ("Close Frame" close-frame-callback ,frame))))
232     (cascade2 (create-cached-menu menu-bar "Debug")))
233    
234     (manage-child frame-view)
235     (manage-children menu-bar fcall fbox slabel swindow)
236     (manage-child srcview)
237     (manage-children cascade1 cascade2)
238    
239     (debug-display-frame-locals frame debug-fun location frame-view)
240     (debug-display-frame-prompt frame frame-view)
241    
242     (popup-interface-pane frame-shell)
243     (push (cons frame frame-shell) *debug-active-frames*)))
244    
245    
246    
247     ;;;; Functions to display the debugger control panel
248    
249     (defun debug-display-error (errmsg condition)
250     (set-values errmsg :label-string (format nil "~A" condition)))
251    
252     (defun debug-display-restarts (restarts)
253     (let (buttons)
254     (dolist (r *debug-restarts*)
255     (let ((button (create-highlight-button
256     restarts "restartButton" (format nil "~A" r))))
257     (add-callback button :activate-callback 'restart-callback r)
258     (push button buttons)))
259     (apply #'manage-children buttons)))
260    
261     (defun debug-display-stack (backtrace)
262     (let ((buttons))
263     (do ((frame *current-frame* (di:frame-down frame)))
264     ((null frame))
265     (let ((button (create-highlight-button
266     backtrace "stackFrame"
267     (grab-output-as-string
268     (print-frame-call frame)))))
269     (add-callback button :activate-callback 'stack-frame-callback frame)
270     (push button buttons)))
271     (apply #'manage-children buttons)))
272    
273     (defun create-debugger (condition)
274     (let* ((debug-pane (create-interface-pane-shell "Debugger" condition))
275     (frame (create-frame debug-pane "debugFrame"))
276     (form (create-form frame "debugForm"))
277     (menu-bar (create-menu-bar form "debugMenu"
278     :left-attachment :attach-form
279     :right-attachment :attach-form))
280     (cascade (create-cached-menu
281     menu-bar "Debug"
282     `(("Close All Frames" close-all-callback)
283     ("Quit Debugger" quit-debugger-callback ,condition))))
284     (errlabel (create-label-gadget form "errorLabel"
285     :top-attachment :attach-widget
286     :top-widget menu-bar
287     :left-attachment :attach-form
288     :font-list *header-font*
289     :label-string "Error Message:"))
290     (errmsg (create-label-gadget form "errorMessage"
291     :top-attachment :attach-widget
292     :top-widget errlabel
293     :left-attachment :attach-form
294     :right-attachment :attach-form))
295     (rlabel (create-label-gadget form "restartLabel"
296     :top-attachment :attach-widget
297     :top-widget errmsg
298     :left-attachment :attach-form
299     :font-list *header-font*))
300     (restarts (create-row-column form "debugRestarts"
301     :adjust-last nil
302     :top-attachment :widget
303     :top-widget rlabel
304     :left-attachment :attach-form
305     :right-attachment :attach-form
306     :left-offset 10))
307     (btlabel (create-label-gadget form "backtraceLabel"
308     :label-string "Stack Backtrace:"
309     :font-list *header-font*
310     :top-attachment :attach-widget
311     :top-widget restarts
312     :left-attachment :attach-form))
313     (btwindow (create-scrolled-window form "backtraceWindow"
314     :scrolling-policy :automatic
315     :scroll-bar-placement :bottom-right
316     :left-attachment :attach-form
317     :right-attachment :attach-form
318     :left-offset 4
319     :right-offset 4
320     :bottom-offset 4
321     :bottom-attachment :attach-form
322     :top-attachment :attach-widget
323     :top-widget btlabel))
324     (backtrace (create-row-column btwindow "debugBacktrace"
325     :adjust-last nil
326     :spacing 1)))
327    
328     (manage-child frame) (manage-child form)
329     (manage-children menu-bar errlabel errmsg rlabel restarts btlabel btwindow)
330     (manage-child backtrace)
331     (manage-child cascade)
332    
333     (debug-display-error errmsg condition)
334    
335     (if *debug-restarts*
336     (progn
337     (set-values rlabel :label-string "Restarts:")
338     (debug-display-restarts restarts))
339     (set-values rlabel :label-string "No restarts available"))
340    
341     (debug-display-stack backtrace)
342    
343     (setf *current-debug-display*
344     (make-debug-display debug-pane restarts backtrace))
345    
346     (popup-interface-pane debug-pane)
347     debug-pane))
348    
349     (defun close-motif-debugger (condition)
350     (push *current-debug-display* *old-display-frames*)
351     ;;
352     ;; Destroy all frame panes
353     (dolist (info *debug-active-frames*)
354     (destroy-widget (cdr info)))
355     (setf *debug-active-frames* nil)
356     ;;
357     ;; Destroy the restart/backtrace window
358     (setf *current-debug-display* nil)
359     (destroy-interface-pane condition)
360    
361     (format t "Leaving debugger.~%"))
362    
363     (defun invoke-motif-debugger (condition)
364     (let* ((frame (di:top-frame))
365     (previous-display *current-debug-display*)
366     (*current-debug-display* nil)
367     (*debug-active-frames* nil))
368     (declare (ignore previous-display))
369     (verify-system-server-exists)
370     (multiple-value-bind (shell connection)
371     (create-interface-shell)
372     (declare (ignore shell))
373     (with-motif-connection (connection)
374     (let ((pane (find-interface-pane condition))
375     (*current-frame* frame))
376     (unless pane
377     (setf pane (create-debugger condition)))
378     (unless (is-managed pane)
379     (popup-interface-pane pane))
380     (setf (dd-info-level *current-debug-display*) *debug-command-level*)
381     (setf (dd-info-connection *current-debug-display*) connection)
382     (unwind-protect
383     (handler-case
384     (loop
385     (system:serve-event))
386     (error (err)
387     (if *flush-debug-errors*
388     (interface-error (format nil "~a" err) pane)
389     (interface-error
390     "Do not yet support recursive debugging" pane))))
391     (when (and connection *current-debug-display*)
392     (with-motif-connection (connection)
393     (close-motif-debugger condition)))))))))
394    
395    
396    
397     (defun invoke-debugger (condition)
398     "The CMU Common Lisp debugger. Type h for help."
399     (when *debugger-hook*
400     (let ((hook *debugger-hook*)
401     (*debugger-hook* nil))
402     (funcall hook condition hook)))
403     (unix:unix-sigsetmask 0)
404     (let* ((*debug-condition* condition)
405     (*debug-restarts* (compute-restarts))
406     (*standard-input* *debug-io*) ;in case of setq
407     (*standard-output* *debug-io*) ;'' '' '' ''
408     (*error-output* *debug-io*)
409     ;; Rebind some printer control variables.
410     (kernel:*current-level* 0)
411     (*print-readably* nil)
412     (*read-eval* t))
413     (if (or (not (use-graphics-interface))
414     (typep condition 'xti:toolkit-error))
415     (progn
416     (format *error-output* "~2&~A~2&" *debug-condition*)
417     (unless (typep condition 'step-condition)
418     (show-restarts *debug-restarts* *error-output*))
419     (internal-debug))
420     (progn
421     (write-line "Invoking debugger...")
422     (invoke-motif-debugger condition)))))
423    
424     #|
425     (defun invoke-debugger (condition)
426     "The CMU Common Lisp debugger. Type h for help."
427     (when *debugger-hook*
428     (let ((hook *debugger-hook*)
429     (*debugger-hook* nil))
430     (funcall hook condition hook)))
431     (unix:unix-sigsetmask 0)
432     (let* ((*debug-condition* condition)
433     (*debug-restarts* (compute-restarts))
434     (*standard-input* *debug-io*) ;in case of setq
435     (*standard-output* *debug-io*) ;'' '' '' ''
436     (*error-output* *debug-io*)
437     ;; Rebind some printer control variables.
438     (kernel:*current-level* 0)
439     (*print-readably* nil)
440     (*read-eval* t))
441     (format *error-output* "~2&~A~2&" *debug-condition*)
442     (unless (typep condition 'step-condition)
443     (show-restarts *debug-restarts* *error-output*))
444     (internal-debug)))
445    
446     |#

  ViewVC Help
Powered by ViewVC 1.1.5