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

Contents of /src/interface/debug.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Thu Nov 12 14:08:12 1992 UTC (21 years, 5 months ago) by garland
Branch: MAIN
Initial revision
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