Mercurial > hg > xemacs-beta

comparison lisp/eos/sun-eos-debugger.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; sun-eos-debugger.el --- Implements the XEmacs/SPARCworks interface
2
3 ;; Copyright (C) 1995 Sun Microsystems, Inc.
4
5 ;; Maintainer: Eduardo Pelegri-Llopart <eduardo.pelegri-llopart@Eng.Sun.COM>
6 ;; Author: Eduardo Pelegri-Llopart <eduardo.pelegri-llopart@Eng.Sun.COM>
7
8 ;; Keywords: SPARCworks EOS Era on SPARCworks Debugger dbx
9
10 ;;; Commentary:
11
12 ;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com
13
14 ;;; Code:
15
16 (require 'eos-common "sun-eos-common")
17
18 ;;; =================
19 ;;; debugger protocol
20 ;;; =================
21
22 (defvar eos::current-hollow-arrow nil)
23 (defvar eos::current-solid-arrow nil)
24 (defvar eos::current-dbx-proc-id nil
25 "TT id for the current dbx")
26 (defvar eos::current-debugger-clique-id nil
27 "Clique_ID for the current debugger/dbx")
28
29 ;; currentpc.color
30
31 (defvar eos::currentpc-inst "/* XPM */
32 static char * file[] = {
33 \"16 11 5 1\",
34 \" s background c #BDBDBDBDBDBD\",
35 \". c #000000000000\",
36 \"X c #0000FFFF0000\",
37 \"o c #000077770000\",
38 \"O c #000044440000\",
39 \" . \",
40 \" .. \",
41 \" .X. \",
42 \" .........XX. \",
43 \" .XXXXXXXXXoX. \",
44 \" .Xooooooooooo. \",
45 \" .oOOOOOOOOoO. \",
46 \" .........OO. \",
47 \" .O. \",
48 \" .. \",
49 \" . \"};")
50
51 (defvar eos::currentpc-inst-alt
52 "/* XPM */
53 static char * file[] = {
54 \"16 11 5 1\",
55 \" s background c #BDBDBDBDBDBD\",
56 \". c #000000000000\",
57 \"X c #0000FFFF0000\",
58 \"o c #000077770000\",
59 \"O c #000044440000\",
60 \" . \",
61 \" .. \",
62 \" .X. \",
63 \" .........XX. \",
64 \" .XXXXXXXXXoX. \",
65 \" .Xooooooooooo. \",
66 \" .oOOOOOOOOoO. \",
67 \" .........OO. \",
68 \" .O. \",
69 \" .. ..\",
70 \" . ..\"};")
71
72 (defvar eos::visitedpc-inst
73 "/* XPM */
74 static char * file[] ={
75 \"16 11 5 1\",
76 \" s background c #BDBDBDBDBDBD\",
77 \". c #000000000000\",
78 \"X c #AFAFAFAFAFAF\",
79 \"o c #7E7E7E7EA9A9\",
80 \"O c #666633339999\",
81 \" . \",
82 \" .. \",
83 \" .X. \",
84 \" .........XX. \",
85 \" .XXXXXXXXXoX. \",
86 \" .XooooooooooO. \",
87 \" .XOOOOOOOOoO. \",
88 \" .........OO. \",
89 \" .O. \",
90 \" .. \",
91 \" . \"};")
92
93 (defvar eos::visitedpc-inst-alt
94 "/* XPM */
95 static char * file[] ={
96 \"16 11 5 1\",
97 \" s background c #BDBDBDBDBDBD\",
98 \". c #000000000000\",
99 \"X c #AFAFAFAFAFAF\",
100 \"o c #7E7E7E7EA9A9\",
101 \"O c #666633339999\",
102 \" . \",
103 \" .. \",
104 \" .X. \",
105 \" .........XX. \",
106 \" .XXXXXXXXXoX. \",
107 \" .XooooooooooO. \",
108 \" .XOOOOOOOOoO. \",
109 \" .........OO. \",
110 \" .O. \",
111 \" .. ..\",
112 \" . ..\"};")
113
114 (defvar eos::breakpoint-inst
115 "/* XPM */
116 static char * file[] ={
117 \"11 11 5 1\",
118 \" s background c #BDBDBDBDBDBD\",
119 \". c #000000000000\",
120 \"X c #FFFF66666666\",
121 \"o c #FFFF00000000\",
122 \"O c #777700000000\",
123 \" ..... \",
124 \" .XXXXX. \",
125 \" .XXoooXX. \",
126 \".XXoooooXO.\",
127 \".XoooooooO.\",
128 \".XoooooooO.\",
129 \".XoooooooO.\",
130 \".XXoooooOO.\",
131 \" .XXoooOO. \",
132 \" .OOOOO. \",
133 \" ..... \"};")
134
135 (defvar eos::breakpoint-inst-alt
136 "/* XPM */
137 static char * file[] ={
138 \"11 11 5 1\",
139 \" s background c #BDBDBDBDBDBD\",
140 \". c #000000000000\",
141 \"X c #FFFF66666666\",
142 \"o c #FFFF00000000\",
143 \"O c #777700000000\",
144 \" ..... \",
145 \" .XXXXX. \",
146 \" .XXoooXX. \",
147 \".XXoooooXO.\",
148 \".XoooooooO.\",
149 \".XoooooooO.\",
150 \".XoooooooO.\",
151 \".XXoooooOO.\",
152 \" .XXoooOO. \",
153 \" .OOOOO...\",
154 \" ..... ..\"};")
155
156 ;; The TT protocol does not provide enough information to
157 ;; use the eos::disabledBreakpoint glyph.
158
159 (defvar eos::disabledBreakpoint-inst
160 "/* XPM */
161 static char * file[] ={
162 \"11 11 4 1\",
163 \" s background c #BDBDBDBDBDBD\",
164 \". c #000000000000\",
165 \"X c Grey\",
166 \"O c Grey80\",
167 \" ..... \",
168 \" .XXXXX. \",
169 \" .XXXXXXX. \",
170 \".XXXXXXXXO.\",
171 \".XXXXXXXXO.\",
172 \".XXXXXXXXO.\",
173 \".XXXXXXXXO.\",
174 \".XXXXXXXOO.\",
175 \" .XXXXXOO. \",
176 \" .OOOOO. \",
177 \" ..... \"};")
178
179 (defvar eos::disabledBreakpoint-inst-alt
180 "/* XPM */
181 static char * file[] ={
182 \"11 11 4 1\",
183 \" s background c #BDBDBDBDBDBD\",
184 \". c #000000000000\",
185 \"X c Grey\",
186 \"O c Grey80\",
187 \" ..... \",
188 \" .XXXXX. \",
189 \" .XXXXXXX. \",
190 \".XXXXXXXXO.\",
191 \".XXXXXXXXO.\",
192 \".XXXXXXXXO.\",
193 \".XXXXXXXXO.\",
194 \".XXXXXXXOO.\",
195 \" .XXXXXOO. \",
196 \" .OOOOO...\",
197 \" ..... ..\"};")
198
199 (defvar eos::dbx-pattern-list nil)
200
201 (defun eos::debugger-startup ()
202 ;; Actions to do at startup for eos-debugger.el
203 (make-face 'stop-face)
204 (make-face 'solid-arrow-face)
205 (make-face 'hollow-arrow-face)
206
207 (set-face-foreground 'stop-face eos::stop-color)
208 (set-face-background 'stop-face
209 (face-background (get-face 'default)))
210 (set-face-foreground 'solid-arrow-face eos::solid-arrow-color)
211 (set-face-background 'solid-arrow-face
212 (face-background (get-face 'default)))
213 (set-face-foreground 'hollow-arrow-face eos::hollow-arrow-color)
214 (set-face-background 'hollow-arrow-face
215 (face-background (get-face 'default)))
216
217 (setq eos::dbx-pattern-list ; list of dbx TT patterns
218 (eos::create-debugger-patterns))
219
220 ;; should there be only one stop-face, with different properties depending
221 ;; on the frame/device?
222
223 (eos::annotation-set-inst 'debugger-stop 'x eos::breakpoint-inst [nothing])
224 (eos::annotation-set-inst 'debugger-stop 'tty "[S]" [nothing])
225 (eos::annotation-set-face 'debugger-stop 'x
226 (get-face 'stop-face) (get-face 'stop-face))
227 (eos::annotation-set-face 'debugger-stop 'tty
228 (get-face 'highlight) (get-face 'highlight))
229
230 (eos::annotation-set-inst 'debugger-hollow-arrow 'x eos::visitedpc-inst [nothing])
231 (eos::annotation-set-inst 'debugger-hollow-arrow 'tty "[]>" [nothing])
232 (eos::annotation-set-face 'debugger-hollow-arrow 'x
233 (get-face 'hollow-arrow-face)
234 (get-face 'hollow-arrow-face))
235 (eos::annotation-set-face 'debugger-hollow-arrow 'tty
236 (get-face 'highlight) (get-face 'highlight))
237
238 (eos::annotation-set-inst 'debugger-solid-arrow 'x eos::currentpc-inst [nothing])
239 (eos::annotation-set-inst 'debugger-solid-arrow 'tty "=>" [nothing])
240 (eos::annotation-set-face 'debugger-solid-arrow 'x
241 (get-face 'solid-arrow-face)
242 (get-face 'solid-arrow-face))
243 (eos::annotation-set-face 'debugger-solid-arrow 'tty
244 (get-face 'highlight) (get-face 'highlight))
245 )
246
247 ;; Not yet ready for prime time.
248
249 (defvar eos::fill-stack-buffer nil
250 "when t don't try any stack tracing")
251
252 (defvar eos::stack-buffer "*Eos Stack*"
253 "name of buffer where to log Stack")
254
255 (defun eos::empty-stack ()
256 ;; No valid stack data - e.g. resume/run program -
257 (if eos::fill-stack-buffer
258 (progn
259 (set-buffer (get-buffer-create eos::stack-buffer))
260 (toggle-read-only -1)
261 (delete-region (point-min) (point-max))
262 (toggle-read-only 1)
263 )))
264
265 (defun eos::load-stack ()
266 ;; Should send a TT message requesting for the stack information;
267 ;; with the real work done in a callback
268 (if eos::fill-stack-buffer
269 (eos::stack-test 1)))
270
271 (defun eos::visit-stack (stackpos)
272 (if eos::fill-stack-buffer
273 (progn
274 (eos::empty-stack)
275 (eos::stack-test 1)
276 )))
277
278 (defun eos::create-stack-patterns ()
279 ;; returns a list of patterns
280 (list
281 (make-an-observer "SPRO_SPIDER_FRAMES" 'eos::spro_spider_frames)
282 ))
283
284 (defun eos::spro_spider_frames (msg pat)
285 ;; We have received a SPRO_SPIDER_FRAMES notice
286 (let ((count (get-tooltalk-message-attribute msg 'args_count))
287 (i 1))
288 (set-buffer (get-buffer-create eos::stack-buffer))
289 (toggle-read-only -1)
290 (while (< i count)
291 ;; optional leading comment
292 (if (equal (get-tooltalk-message-attribute msg 'arg_type i)
293 "Stack_Info1")
294 (progn
295 (insert (get-tooltalk-message-attribute msg 'arg_val i))
296 (setq i (1+ i))))
297 ;; current frame?
298 (insert (if (equal (get-tooltalk-message-attribute msg 'arg_ival i)
299 "0") " " "> "))
300 (setq i (1+ i))
301 (insert (format "[%s] %s%s %s:%s"
302 ;; frameno
303 (get-tooltalk-message-attribute msg 'arg_ival i)
304 ;; funcname
305 (get-tooltalk-message-attribute msg 'arg_val (+ i 1))
306 ;; funcargs
307 (get-tooltalk-message-attribute msg 'arg_val (+ i 2))
308 ;; source
309 (get-tooltalk-message-attribute msg 'arg_val (+ i 3))
310 ;; line
311 (get-tooltalk-message-attribute msg 'arg_val (+ i 4))))
312 (setq i (+ i 5))
313 (if (equal (get-tooltalk-message-attribute msg 'arg_type i)
314 "Stack_Info2")
315 (progn
316 (insert (get-tooltalk-message-attribute msg 'arg_val i))
317 (setq i (1+ i))))
318 (insert "\n"))
319 (toggle-read-only 1)
320 ;; (return-tooltalk-message msg)
321 ))
322
323 (defun eos::spider-stack-callback (msg pat)
324 ;; Callback after processing a spider_stack request
325 (destroy-tooltalk-message msg)
326 )
327
328 (defmacro eos::stack-tt-args (spider-id clique-id hidden verbose quick starting-index count)
329 (` (list
330 'class TT_REQUEST
331 'address TT_HANDLER
332 'scope TT_SESSION
333 'handler (, spider-id)
334 'op "SPRO_SPIDER_STACK"
335 'callback 'eos::spider-stack-callback
336 'args (list
337 (list 'TT_IN (, clique-id) "Context_ID")
338 (list 'TT_IN (, hidden) "Boolean")
339 (list 'TT_IN (, verbose) "Boolean")
340 (list 'TT_IN (, quick) "Boolean")
341 (list 'TT_IN (, starting-index) "int")
342 (list 'TT_IN (, count) "int"))
343 )))
344
345 (defun eos::stack-test (starting-index)
346 (let ((msg (make-tooltalk-message
347 (eos::stack-tt-args eos::current-dbx-proc-id
348 eos::current-debugger-clique-id
349 0 ; hidden
350 1 ; verbose
351 0 ; quick
352 starting-index
353 4 ; count
354 ))))
355 (send-tooltalk-message msg)
356 ;; (destroy-tooltalk-message msg)
357 ))
358
359 ;; (setq eos::fill-stack-buffer t)
360 ;; (setq eos::fill-stack-buffer nil)
361 ;; (setq eos::stack-pattern-list (eos::create-stack-patterns))
362 ;; (mapcar 'register-tooltalk-pattern eos::stack-pattern-list)
363 ;; (mapcar 'unregister-tooltalk-pattern eos::stack-pattern-list)
364 ;; (eos::stack-test 1)
365
366
367 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
368
369
370 ;;
371
372 (defun eos::spro_te_eventset (msg pat)
373 ;; thread_id trap_id string string filename lineno string string
374 (let* ((trap-id
375 (get-tooltalk-message-attribute msg 'arg_val 1))
376 (filename
377 (get-tooltalk-message-attribute msg 'arg_val 4))
378 (lineno
379 (read (get-tooltalk-message-attribute msg 'arg_ival 5))))
380 (eos::add-annotation 'debugger-stop filename lineno trap-id)
381 ;; (return-tooltalk-message msg)
382 ))
383
384 (defun eos::spro_te_eventdel (msg pat)
385 ;; trap_id string string filename lineno string string
386 (let* ((trap-id
387 (get-tooltalk-message-attribute msg 'arg_val 0))
388 (filename
389 (get-tooltalk-message-attribute msg 'arg_val 3))
390 (lineno
391 (read (get-tooltalk-message-attribute msg 'arg_ival 4))))
392 (eos::delete-annotation 'debugger-stop filename lineno trap-id)
393 ;; (return-tooltalk-message msg)
394 ))
395
396 (defun eos::spro_te_stopped (msg pat)
397 ;; thread_id filename procname lineno filename procname lineno
398 (let* ((filename-hollow
399 (get-tooltalk-message-attribute msg 'arg_val 1))
400 (procname-hollow
401 (get-tooltalk-message-attribute msg 'arg_val 2))
402 (lineno-hollow
403 (read (get-tooltalk-message-attribute msg 'arg_ival 3)))
404 (filename-solid
405 (get-tooltalk-message-attribute msg 'arg_val 4))
406 (lineno-solid
407 (read (get-tooltalk-message-attribute msg 'arg_ival 6)))
408 )
409 (setq eos::current-solid-arrow
410 (eos::make-annotation-visible eos::current-solid-arrow
411 filename-solid
412 lineno-solid
413 'debugger-solid-arrow))
414 (if (or (not (equal filename-solid filename-hollow))
415 (not (equal lineno-solid lineno-hollow)))
416 (setq eos::current-hollow-arrow
417 (eos::make-annotation-visible eos::current-hollow-arrow
418 filename-hollow
419 lineno-hollow
420 'debugger-hollow-arrow)))
421 ;; (return-tooltalk-message msg)
422 (eos::load-stack)
423 ))
424
425 ;; Tracking current id's
426 ;;
427
428 (defun eos::update-dbx-proc-id (msg)
429 (setq eos::current-dbx-proc-id
430 (get-tooltalk-message-attribute msg 'sender))
431 ;; the following is needed to make toolbar entries be active or not
432 ;; I think it is not needed in 19.13
433 (eos::select-debugger-frame eos::debugger-frame)
434 )
435
436 (defun eos::update-current-debugger-clique-id (msg)
437 (setq eos::current-debugger-clique-id
438 (get-tooltalk-message-attribute msg 'arg_val 0))
439 )
440
441 ;;
442 ;; Updating arrows
443 ;;
444
445
446 (defun eos::update-pids (msg)
447 (eos::update-dbx-proc-id msg)
448 (eos::update-current-debugger-clique-id msg))
449
450 (defun eos::internal-clear-annotations (stack arrows stops &optional clique)
451 (if stack
452 (eos::empty-stack))
453 (if arrows
454 (progn
455 (eos::make-annotation-invisible eos::current-hollow-arrow)
456 (eos::make-annotation-invisible eos::current-solid-arrow)))
457 (if clique
458 (progn
459 (setq eos::current-debugger-clique-id nil)
460 ;; not needed in 19.13?
461 (eos::select-debugger-frame eos::debugger-frame)))
462 (if stops
463 (eos::remove-all-from-annotation-list 'debugger-stop)))
464
465
466 (defun eos::clear-arrows (msg pat)
467 (eos::internal-clear-annotations t t nil)
468 ;; (return-tooltalk-message msg)
469 )
470
471 (defun eos::update-clear-stops (msg pat)
472 (eos::update-pids msg)
473 (eos::internal-clear-annotations t nil t)
474 ;; (return-tooltalk-message msg)
475 )
476
477 (defun eos::update-clear-arrows-stops (msg pat)
478 (eos::update-pids msg)
479 (eos::internal-clear-annotations t t t)
480 ;; (return-tooltalk-message msg)
481 )
482
483 (defun eos::clear-arrows-stops (msg pat)
484 (let ((this-proc-id
485 (get-tooltalk-message-attribute msg 'sender)))
486 (if (equal eos::current-dbx-proc-id this-proc-id)
487 (progn
488 (eos::internal-clear-annotations t t t)
489 ;; (return-tooltalk-message msg)
490 ))))
491
492 ;;
493
494 ;;
495
496 (defun eos::spro_detach (msg pat)
497 ;; a detach notification has been received. this means dbx/debugger
498 ;; is exiting
499 (eos::internal-clear-annotations t t t t)
500 (eos::dismiss-print-frame))
501
502 (defun eos::spro_te_location (msg pat)
503 ;; thread_id filename procname lineno filename procname lineno
504 (let* ((filename-hollow
505 (get-tooltalk-message-attribute msg 'arg_val 1))
506 (lineno-hollow
507 (read (get-tooltalk-message-attribute msg 'arg_ival 3)))
508 (filename-solid
509 (get-tooltalk-message-attribute msg 'arg_val 4))
510 (lineno-solid
511 (read (get-tooltalk-message-attribute msg 'arg_ival 6)))
512 )
513 (setq eos::current-solid-arrow
514 (eos::make-annotation-visible eos::current-solid-arrow
515 filename-solid
516 lineno-solid
517 'debugger-solid-arrow))
518 (if (or (not (equal filename-solid filename-hollow))
519 (not (equal lineno-solid lineno-hollow)))
520 (setq eos::current-hollow-arrow
521 (eos::make-annotation-visible eos::current-hollow-arrow
522 filename-hollow
523 lineno-hollow
524 'debugger-hollow-arrow)))
525 ;; (return-tooltalk-message msg)
526 ))
527
528 (defun eos::spro_te_visit (msg pat)
529 ;; thread_id filename procname lineno stackpos
530 (let* ((filename
531 (get-tooltalk-message-attribute msg 'arg_val 1))
532 (procname
533 (get-tooltalk-message-attribute msg 'arg_val 2))
534 (lineno
535 (read (get-tooltalk-message-attribute msg 'arg_ival 3)))
536 (stackpos
537 (read (get-tooltalk-message-attribute msg 'arg_ival 4)))
538 )
539 (eos::make-annotation-invisible eos::current-hollow-arrow)
540 (if (equal stackpos 1)
541 (progn
542 (eos::make-annotation-invisible eos::current-solid-arrow)
543 (setq eos::current-solid-arrow
544 (eos::make-annotation-visible eos::current-solid-arrow
545 filename
546 lineno
547 'debugger-solid-arrow))
548 )
549 (setq eos::current-hollow-arrow
550 (eos::make-annotation-visible eos::current-hollow-arrow
551 filename
552 lineno
553 'debugger-hollow-arrow))
554 )
555 ;; (return-tooltalk-message msg)
556 (eos::visit-stack stackpos)
557 ))
558
559 ;; generate a list of patterns
560 ;; so it can be registered and unregistered.
561
562
563 (defun eos::create-debugger-patterns ()
564 ;; returns a list of patterns
565 (list
566 (make-an-observer "SPRO_TE_STOPPED" 'eos::spro_te_stopped)
567 (make-an-observer "SPRO_SE_STARTED" 'eos::clear-arrows)
568 (make-an-observer "SPRO_TE_STEPPED" 'eos::clear-arrows)
569 (make-an-observer "SPRO_TE_CONTINUED" 'eos::clear-arrows)
570 (make-an-observer "SPRO_SE_DROPPED" 'eos::clear-arrows-stops)
571 (make-an-observer "SPRO_SE_DEBUGGED" 'eos::update-clear-stops)
572 (make-an-observer "SPRO_SE_REVIVED" 'eos::update-clear-arrows-stops)
573 (make-an-observer "SPRO_SE_ATTACHED" 'eos::update-clear-arrows-stops)
574 (make-an-observer "SPRO_SE_GONE" 'eos::clear-arrows)
575 (make-an-observer "SPRO_TE_LOCATION" 'eos::spro_te_location)
576 (make-an-observer "SPRO_TE_VISIT" 'eos::spro_te_visit)
577 (make-an-observer "SPRO_TE_EVENTSET" 'eos::spro_te_eventset)
578 (make-an-observer "SPRO_TE_EVENTDEL" 'eos::spro_te_eventdel)
579 (make-an-observer "SPRO_DETACH" 'eos::spro_detach)
580 ))
581
582 (defun eos::register-debugger-patterns ()
583 ;; register all dbx patterns
584 (mapcar 'register-tooltalk-pattern eos::dbx-pattern-list)
585 (eos::register-debugger-extra-patterns))
586
587 (defun eos::unregister-debugger-patterns ()
588 ;; unregister all dbx patterns
589 (mapcar 'unregister-tooltalk-pattern eos::dbx-pattern-list)
590 (eos::unregister-debugger-extra-patterns))
591
592 (provide 'eos-debugger)
593
594 ;;; sun-eos-debugger.el ends here