Commit | Line | Data |
---|---|---|
754e5da2 SG |
1 | # GDB GUI setup |
2 | ||
3 | set cfile Blank | |
006e71e9 | 4 | set wins($cfile) .src.text |
754e5da2 SG |
5 | set current_label {} |
6 | set screen_height 0 | |
7 | set screen_top 0 | |
8 | set screen_bot 0 | |
006e71e9 | 9 | set current_output_win .cmd.text |
8532893d | 10 | set cfunc NIL |
006e71e9 SG |
11 | #option add *Foreground Black |
12 | #option add *Background White | |
13 | #option add *Font -*-*-medium-r-normal--18-*-*-*-m-*-*-1 | |
746d1df4 | 14 | tk colormodel . monochrome |
754e5da2 SG |
15 | |
16 | proc echo string {puts stdout $string} | |
17 | ||
8532893d SG |
18 | if [info exists env(EDITOR)] then { |
19 | set editor $env(EDITOR) | |
20 | } else { | |
21 | set editor emacs | |
22 | } | |
23 | ||
24 | # GDB callbacks | |
25 | # | |
26 | # These functions are called by GDB (from C code) to do various things in | |
27 | # TK-land. All start with the prefix `gdbtk_tcl_' to make them easy to find. | |
28 | # | |
29 | ||
30 | # | |
31 | # GDB Callback: | |
32 | # | |
33 | # gdbtk_tcl_fputs (text) - Output text to the command window | |
34 | # | |
35 | # Description: | |
36 | # | |
37 | # GDB calls this to output TEXT to the GDB command window. The text is | |
38 | # placed at the end of the text widget. Note that output may not occur, | |
39 | # due to buffering. Use gdbtk_tcl_flush to cause an immediate update. | |
40 | # | |
41 | ||
754e5da2 | 42 | proc gdbtk_tcl_fputs {arg} { |
8532893d SG |
43 | global current_output_win |
44 | ||
45 | $current_output_win insert end "$arg" | |
46 | $current_output_win yview -pickplace end | |
47 | } | |
48 | ||
49 | # | |
50 | # GDB Callback: | |
51 | # | |
52 | # gdbtk_tcl_flush () - Flush output to the command window | |
53 | # | |
54 | # Description: | |
55 | # | |
56 | # GDB calls this to force all buffered text to the GDB command window. | |
57 | # | |
58 | ||
59 | proc gdbtk_tcl_flush {} { | |
60 | $current_output_win yview -pickplace end | |
61 | update idletasks | |
754e5da2 SG |
62 | } |
63 | ||
8532893d SG |
64 | # |
65 | # GDB Callback: | |
66 | # | |
67 | # gdbtk_tcl_query (message) - Create a yes/no query dialog box | |
68 | # | |
69 | # Description: | |
70 | # | |
71 | # GDB calls this to create a yes/no dialog box containing MESSAGE. GDB | |
72 | # is hung while the dialog box is active (ie: no commands will work), | |
73 | # however windows can still be refreshed in case of damage or exposure. | |
74 | # | |
754e5da2 SG |
75 | |
76 | proc gdbtk_tcl_query {message} { | |
77 | tk_dialog .query "gdb : query" "$message" {} 1 "No" "Yes" | |
78 | } | |
79 | ||
8532893d SG |
80 | # |
81 | # GDB Callback: | |
82 | # | |
83 | # gdbtk_start_variable_annotation (args ...) - | |
84 | # | |
85 | # Description: | |
86 | # | |
87 | # Not yet implemented. | |
88 | # | |
754e5da2 SG |
89 | |
90 | proc gdbtk_tcl_start_variable_annotation {valaddr ref_type stor_cl cum_expr field type_cast} { | |
91 | echo "gdbtk_tcl_start_variable_annotation $valaddr $ref_type $stor_cl $cum_expr $field $type_cast" | |
92 | } | |
93 | ||
8532893d SG |
94 | # |
95 | # GDB Callback: | |
96 | # | |
97 | # gdbtk_end_variable_annotation (args ...) - | |
98 | # | |
99 | # Description: | |
100 | # | |
101 | # Not yet implemented. | |
102 | # | |
103 | ||
754e5da2 SG |
104 | proc gdbtk_tcl_end_variable_annotation {} { |
105 | echo gdbtk_tcl_end_variable_annotation | |
106 | } | |
107 | ||
8532893d SG |
108 | # |
109 | # GDB Callback: | |
110 | # | |
111 | # gdbtk_tcl_breakpoint (action bpnum file line) - Notify the TK | |
112 | # interface of changes to breakpoints. | |
113 | # | |
114 | # Description: | |
115 | # | |
116 | # GDB calls this to notify TK of changes to breakpoints. ACTION is one | |
117 | # of: | |
118 | # create - Notify of breakpoint creation | |
119 | # delete - Notify of breakpoint deletion | |
120 | # enable - Notify of breakpoint enabling | |
121 | # disable - Notify of breakpoint disabling | |
122 | # | |
123 | # All actions take the same set of arguments: BPNUM is the breakpoint | |
124 | # number, FILE is the source file and LINE is the line number, and PC is | |
125 | # the pc of the affected breakpoint. | |
126 | # | |
127 | ||
128 | proc gdbtk_tcl_breakpoint {action bpnum file line pc} { | |
129 | ${action}_breakpoint $bpnum $file $line $pc | |
754e5da2 SG |
130 | } |
131 | ||
335129a9 SG |
132 | proc asm_win_name {funcname} { |
133 | regsub -all {\.} $funcname _ temp | |
134 | ||
135 | return .asm.func_${temp} | |
136 | } | |
137 | ||
8532893d SG |
138 | # |
139 | # Local procedure: | |
140 | # | |
141 | # create_breakpoint (bpnum file line pc) - Record breakpoint info in TK land | |
142 | # | |
143 | # Description: | |
144 | # | |
145 | # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK | |
146 | # land of breakpoint creation. This consists of recording the file and | |
147 | # line number in the breakpoint_file and breakpoint_line arrays. Also, | |
148 | # if there is already a window associated with FILE, it is updated with | |
149 | # a breakpoint tag. | |
150 | # | |
151 | ||
152 | proc create_breakpoint {bpnum file line pc} { | |
754e5da2 SG |
153 | global wins |
154 | global breakpoint_file | |
155 | global breakpoint_line | |
8532893d | 156 | global pos_to_breakpoint |
335129a9 | 157 | global pos_to_bpcount |
8532893d SG |
158 | global cfunc |
159 | global pclist | |
754e5da2 SG |
160 | |
161 | # Record breakpoint locations | |
162 | ||
163 | set breakpoint_file($bpnum) $file | |
164 | set breakpoint_line($bpnum) $line | |
8532893d | 165 | set pos_to_breakpoint($file:$line) $bpnum |
335129a9 SG |
166 | if ![info exists pos_to_bpcount($file:$line)] { |
167 | set pos_to_bpcount($file:$line) 0 | |
168 | } | |
169 | incr pos_to_bpcount($file:$line) | |
170 | set pos_to_breakpoint($pc) $bpnum | |
171 | if ![info exists pos_to_bpcount($pc)] { | |
172 | set pos_to_bpcount($pc) 0 | |
173 | } | |
174 | incr pos_to_bpcount($pc) | |
754e5da2 | 175 | |
8532893d | 176 | # If there's a window for this file, update it |
754e5da2 SG |
177 | |
178 | if [info exists wins($file)] { | |
179 | insert_breakpoint_tag $wins($file) $line | |
180 | } | |
8532893d SG |
181 | |
182 | # If there's an assembly window, update that too | |
183 | ||
335129a9 | 184 | set win [asm_win_name $cfunc] |
8532893d | 185 | if [winfo exists $win] { |
637b1661 | 186 | insert_breakpoint_tag $win [pc_to_line $pclist($cfunc) $pc] |
8532893d | 187 | } |
754e5da2 SG |
188 | } |
189 | ||
8532893d SG |
190 | # |
191 | # Local procedure: | |
192 | # | |
193 | # delete_breakpoint (bpnum file line pc) - Delete breakpoint info from TK land | |
194 | # | |
195 | # Description: | |
196 | # | |
197 | # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK | |
198 | # land of breakpoint destruction. This consists of removing the file and | |
199 | # line number from the breakpoint_file and breakpoint_line arrays. Also, | |
200 | # if there is already a window associated with FILE, the tags are removed | |
201 | # from it. | |
202 | # | |
203 | ||
204 | proc delete_breakpoint {bpnum file line pc} { | |
754e5da2 SG |
205 | global wins |
206 | global breakpoint_file | |
207 | global breakpoint_line | |
8532893d | 208 | global pos_to_breakpoint |
335129a9 SG |
209 | global pos_to_bpcount |
210 | global cfunc pclist | |
754e5da2 | 211 | |
8532893d | 212 | # Save line number and file for later |
754e5da2 SG |
213 | |
214 | set line $breakpoint_line($bpnum) | |
215 | ||
8532893d SG |
216 | set file $breakpoint_file($bpnum) |
217 | ||
754e5da2 SG |
218 | # Reset breakpoint annotation info |
219 | ||
335129a9 | 220 | if {$pos_to_bpcount($file:$line) > 0} { |
637b1661 | 221 | decr pos_to_bpcount($file:$line) |
335129a9 SG |
222 | |
223 | if {$pos_to_bpcount($file:$line) == 0} { | |
637b1661 SG |
224 | catch "unset pos_to_breakpoint($file:$line)" |
225 | ||
335129a9 SG |
226 | unset breakpoint_file($bpnum) |
227 | unset breakpoint_line($bpnum) | |
754e5da2 | 228 | |
8532893d | 229 | # If there's a window for this file, update it |
754e5da2 | 230 | |
335129a9 SG |
231 | if [info exists wins($file)] { |
232 | delete_breakpoint_tag $wins($file) $line | |
233 | } | |
234 | } | |
235 | } | |
236 | ||
237 | # If there's an assembly window, update that too | |
238 | ||
239 | if {$pos_to_bpcount($pc) > 0} { | |
637b1661 | 240 | decr pos_to_bpcount($pc) |
335129a9 SG |
241 | |
242 | if {$pos_to_bpcount($pc) == 0} { | |
637b1661 SG |
243 | catch "unset pos_to_breakpoint($pc)" |
244 | ||
335129a9 SG |
245 | set win [asm_win_name $cfunc] |
246 | if [winfo exists $win] { | |
637b1661 | 247 | delete_breakpoint_tag $win [pc_to_line $pclist($cfunc) $pc] |
335129a9 SG |
248 | } |
249 | } | |
754e5da2 SG |
250 | } |
251 | } | |
252 | ||
8532893d SG |
253 | # |
254 | # Local procedure: | |
255 | # | |
256 | # enable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land | |
257 | # | |
258 | # Description: | |
259 | # | |
260 | # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK | |
261 | # land of a breakpoint being enabled. This consists of unstippling the | |
262 | # specified breakpoint indicator. | |
263 | # | |
264 | ||
265 | proc enable_breakpoint {bpnum file line pc} { | |
266 | global wins | |
335129a9 SG |
267 | global cfunc pclist |
268 | ||
269 | if [info exists wins($file)] { | |
270 | $wins($file) tag configure $line -fgstipple {} | |
271 | } | |
754e5da2 | 272 | |
335129a9 SG |
273 | # If there's an assembly window, update that too |
274 | ||
275 | set win [asm_win_name $cfunc] | |
276 | if [winfo exists $win] { | |
637b1661 | 277 | $win tag configure [pc_to_line $pclist($cfunc) $pc] -fgstipple {} |
335129a9 | 278 | } |
754e5da2 SG |
279 | } |
280 | ||
8532893d SG |
281 | # |
282 | # Local procedure: | |
283 | # | |
284 | # disable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land | |
285 | # | |
286 | # Description: | |
287 | # | |
288 | # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK | |
289 | # land of a breakpoint being disabled. This consists of stippling the | |
290 | # specified breakpoint indicator. | |
291 | # | |
292 | ||
293 | proc disable_breakpoint {bpnum file line pc} { | |
294 | global wins | |
335129a9 SG |
295 | global cfunc pclist |
296 | ||
297 | if [info exists wins($file)] { | |
298 | $wins($file) tag configure $line -fgstipple gray50 | |
299 | } | |
754e5da2 | 300 | |
335129a9 SG |
301 | # If there's an assembly window, update that too |
302 | ||
303 | set win [asm_win_name $cfunc] | |
304 | if [winfo exists $win] { | |
637b1661 | 305 | $win tag configure [pc_to_line $pclist($cfunc) $pc] -fgstipple gray50 |
335129a9 | 306 | } |
8532893d SG |
307 | } |
308 | ||
309 | # | |
310 | # Local procedure: | |
311 | # | |
312 | # insert_breakpoint_tag (win line) - Insert a breakpoint tag in WIN. | |
313 | # | |
314 | # Description: | |
315 | # | |
316 | # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to insert a | |
317 | # breakpoint tag into window WIN at line LINE. | |
318 | # | |
754e5da2 | 319 | |
8532893d SG |
320 | proc insert_breakpoint_tag {win line} { |
321 | $win configure -state normal | |
322 | $win delete $line.0 | |
323 | $win insert $line.0 "B" | |
324 | $win tag add $line $line.0 | |
479f0f18 SG |
325 | $win tag add delete $line.0 "$line.0 lineend" |
326 | $win tag add margin $line.0 "$line.0 lineend" | |
8532893d SG |
327 | |
328 | $win configure -state disabled | |
329 | } | |
330 | ||
331 | # | |
332 | # Local procedure: | |
333 | # | |
334 | # delete_breakpoint_tag (win line) - Remove a breakpoint tag from WIN. | |
335 | # | |
336 | # Description: | |
337 | # | |
338 | # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to remove a | |
339 | # breakpoint tag from window WIN at line LINE. | |
340 | # | |
341 | ||
342 | proc delete_breakpoint_tag {win line} { | |
343 | $win configure -state normal | |
344 | $win delete $line.0 | |
746d1df4 SG |
345 | if {[string range $win 0 3] == ".src"} then { |
346 | $win insert $line.0 "\xa4" | |
347 | } else { | |
348 | $win insert $line.0 " " | |
349 | } | |
8532893d | 350 | $win tag delete $line |
479f0f18 SG |
351 | $win tag add delete $line.0 "$line.0 lineend" |
352 | $win tag add margin $line.0 "$line.0 lineend" | |
8532893d SG |
353 | $win configure -state disabled |
354 | } | |
754e5da2 | 355 | |
479f0f18 | 356 | proc gdbtk_tcl_busy {} { |
006e71e9 SG |
357 | .src.start configure -state disabled |
358 | .src.stop configure -state normal | |
359 | .src.step configure -state disabled | |
360 | .src.next configure -state disabled | |
361 | .src.continue configure -state disabled | |
362 | .src.finish configure -state disabled | |
363 | .src.up configure -state disabled | |
364 | .src.down configure -state disabled | |
365 | .src.bottom configure -state disabled | |
479f0f18 SG |
366 | .asm.stepi configure -state disabled |
367 | .asm.nexti configure -state disabled | |
368 | .asm.continue configure -state disabled | |
369 | .asm.finish configure -state disabled | |
370 | .asm.up configure -state disabled | |
371 | .asm.down configure -state disabled | |
372 | .asm.bottom configure -state disabled | |
373 | .asm.close configure -state disabled | |
374 | } | |
375 | ||
376 | proc gdbtk_tcl_idle {} { | |
006e71e9 SG |
377 | .src.start configure -state normal |
378 | .src.stop configure -state disabled | |
379 | .src.step configure -state normal | |
380 | .src.next configure -state normal | |
381 | .src.continue configure -state normal | |
382 | .src.finish configure -state normal | |
383 | .src.up configure -state normal | |
384 | .src.down configure -state normal | |
385 | .src.bottom configure -state normal | |
479f0f18 SG |
386 | .asm.stepi configure -state normal |
387 | .asm.nexti configure -state normal | |
388 | .asm.continue configure -state normal | |
389 | .asm.finish configure -state normal | |
390 | .asm.up configure -state normal | |
391 | .asm.down configure -state normal | |
392 | .asm.bottom configure -state normal | |
393 | .asm.close configure -state normal | |
394 | } | |
395 | ||
637b1661 SG |
396 | # |
397 | # Local procedure: | |
398 | # | |
399 | # decr (var val) - compliment to incr | |
400 | # | |
401 | # Description: | |
402 | # | |
403 | # | |
404 | proc decr {var {val 1}} { | |
405 | upvar $var num | |
406 | set num [expr $num - $val] | |
407 | return $num | |
408 | } | |
409 | ||
410 | # | |
411 | # Local procedure: | |
412 | # | |
413 | # pc_to_line (pclist pc) - convert PC to a line number. | |
414 | # | |
415 | # Description: | |
416 | # | |
417 | # Convert PC to a line number from PCLIST. If exact line isn't found, | |
418 | # we return the first line that starts before PC. | |
419 | # | |
420 | proc pc_to_line {pclist pc} { | |
421 | set line [lsearch -exact $pclist $pc] | |
422 | ||
423 | if {$line >= 1} { return $line } | |
424 | ||
425 | set line 1 | |
426 | foreach linepc [lrange $pclist 1 end] { | |
427 | if {$pc < $linepc} { decr line ; return $line } | |
428 | incr line | |
429 | } | |
430 | return [expr $line - 1] | |
431 | } | |
432 | ||
8532893d SG |
433 | # |
434 | # Menu: | |
435 | # | |
436 | # file popup menu - Define the file popup menu. | |
437 | # | |
438 | # Description: | |
439 | # | |
440 | # This menu just contains a bunch of buttons that do various things to | |
441 | # the line under the cursor. | |
442 | # | |
443 | # Items: | |
444 | # | |
445 | # Edit - Run the editor (specified by the environment variable EDITOR) on | |
446 | # this file, at the current line. | |
447 | # Breakpoint - Set a breakpoint at the current line. This just shoves | |
448 | # a `break' command at GDB with the appropriate file and line | |
449 | # number. Eventually, GDB calls us back (at gdbtk_tcl_breakpoint) | |
450 | # to notify us of where the breakpoint needs to show up. | |
451 | # | |
452 | ||
453 | menu .file_popup -cursor hand2 | |
454 | .file_popup add command -label "Not yet set" -state disabled | |
455 | .file_popup add separator | |
456 | .file_popup add command -label "Edit" -command {exec $editor +$selected_line $selected_file &} | |
457 | .file_popup add command -label "Set breakpoint" -command {gdb_cmd "break $selected_file:$selected_line"} | |
458 | ||
459 | # | |
460 | # Bindings: | |
461 | # | |
462 | # file popup menu - Define the file popup menu bindings. | |
463 | # | |
464 | # Description: | |
465 | # | |
466 | # This defines the binding for the file popup menu. Currently, there is | |
467 | # only one, which is activated when Button-1 is released. This causes | |
468 | # the menu to be unposted, releases the grab for the menu, and then | |
469 | # unhighlights the line under the cursor. After that, the selected menu | |
470 | # item is invoked. | |
471 | # | |
472 | ||
473 | bind .file_popup <Any-ButtonRelease-1> { | |
754e5da2 SG |
474 | global selected_win |
475 | ||
476 | # First, remove the menu, and release the pointer | |
477 | ||
8532893d SG |
478 | .file_popup unpost |
479 | grab release .file_popup | |
754e5da2 SG |
480 | |
481 | # Unhighlight the selected line | |
482 | ||
483 | $selected_win tag delete breaktag | |
754e5da2 SG |
484 | |
485 | # Actually invoke the menubutton here! | |
486 | ||
487 | tk_invokeMenu %W | |
754e5da2 SG |
488 | } |
489 | ||
8532893d SG |
490 | # |
491 | # Local procedure: | |
492 | # | |
493 | # file_popup_menu (win x y xrel yrel) - Popup the file popup menu. | |
494 | # | |
495 | # Description: | |
496 | # | |
497 | # This procedure is invoked as a result of a command binding in the | |
498 | # listing window. It does several things: | |
499 | # o - It highlights the line under the cursor. | |
500 | # o - It pops up the file popup menu which is intended to do | |
501 | # various things to the aforementioned line. | |
502 | # o - Grabs the mouse for the file popup menu. | |
503 | # | |
504 | ||
754e5da2 SG |
505 | # Button 1 has been pressed in a listing window. Pop up a menu. |
506 | ||
8532893d | 507 | proc file_popup_menu {win x y xrel yrel} { |
754e5da2 SG |
508 | global wins |
509 | global win_to_file | |
510 | global file_to_debug_file | |
511 | global highlight | |
512 | global selected_line | |
513 | global selected_file | |
514 | global selected_win | |
515 | ||
754e5da2 SG |
516 | # Map TK window name back to file name. |
517 | ||
518 | set file $win_to_file($win) | |
519 | ||
520 | set pos [$win index @$xrel,$yrel] | |
521 | ||
522 | # Record selected file and line for menu button actions | |
523 | ||
524 | set selected_file $file_to_debug_file($file) | |
525 | set selected_line [lindex [split $pos .] 0] | |
526 | set selected_win $win | |
527 | ||
528 | # Highlight the selected line | |
529 | ||
530 | eval $win tag config breaktag $highlight | |
531 | $win tag add breaktag "$pos linestart" "$pos linestart + 1l" | |
532 | ||
533 | # Post the menu near the pointer, (and grab it) | |
534 | ||
8532893d SG |
535 | .file_popup entryconfigure 0 -label "$selected_file:$selected_line" |
536 | .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10] | |
537 | grab .file_popup | |
754e5da2 SG |
538 | } |
539 | ||
8532893d SG |
540 | # |
541 | # Local procedure: | |
542 | # | |
543 | # listing_window_button_1 (win x y xrel yrel) - Handle button 1 in listing window | |
544 | # | |
545 | # Description: | |
546 | # | |
547 | # This procedure is invoked as a result of holding down button 1 in the | |
548 | # listing window. The action taken depends upon where the button was | |
549 | # pressed. If it was in the left margin (the breakpoint column), it | |
550 | # sets or clears a breakpoint. In the main text area, it will pop up a | |
551 | # menu. | |
552 | # | |
553 | ||
554 | proc listing_window_button_1 {win x y xrel yrel} { | |
555 | global wins | |
556 | global win_to_file | |
557 | global file_to_debug_file | |
558 | global highlight | |
559 | global selected_line | |
560 | global selected_file | |
561 | global selected_win | |
562 | global pos_to_breakpoint | |
563 | ||
564 | # Map TK window name back to file name. | |
565 | ||
566 | set file $win_to_file($win) | |
567 | ||
568 | set pos [split [$win index @$xrel,$yrel] .] | |
569 | ||
570 | # Record selected file and line for menu button actions | |
571 | ||
572 | set selected_file $file_to_debug_file($file) | |
573 | set selected_line [lindex $pos 0] | |
574 | set selected_col [lindex $pos 1] | |
575 | set selected_win $win | |
576 | ||
577 | # If we're in the margin, then toggle the breakpoint | |
578 | ||
579 | if {$selected_col < 8} { | |
580 | set pos_break $selected_file:$selected_line | |
581 | set pos $file:$selected_line | |
582 | set tmp pos_to_breakpoint($pos) | |
583 | if [info exists $tmp] { | |
584 | set bpnum [set $tmp] | |
585 | gdb_cmd "delete $bpnum" | |
586 | } else { | |
587 | gdb_cmd "break $pos_break" | |
588 | } | |
589 | return | |
590 | } | |
591 | ||
592 | # Post the menu near the pointer, (and grab it) | |
593 | ||
594 | .file_popup entryconfigure 0 -label "$selected_file:$selected_line" | |
595 | .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10] | |
596 | grab .file_popup | |
597 | } | |
598 | ||
599 | # | |
600 | # Local procedure: | |
601 | # | |
602 | # asm_window_button_1 (win x y xrel yrel) - Handle button 1 in asm window | |
603 | # | |
604 | # Description: | |
605 | # | |
606 | # This procedure is invoked as a result of holding down button 1 in the | |
607 | # assembly window. The action taken depends upon where the button was | |
608 | # pressed. If it was in the left margin (the breakpoint column), it | |
609 | # sets or clears a breakpoint. In the main text area, it will pop up a | |
610 | # menu. | |
611 | # | |
612 | ||
613 | proc asm_window_button_1 {win x y xrel yrel} { | |
614 | global wins | |
615 | global win_to_file | |
616 | global file_to_debug_file | |
617 | global highlight | |
618 | global selected_line | |
619 | global selected_file | |
620 | global selected_win | |
621 | global pos_to_breakpoint | |
622 | global pclist | |
623 | global cfunc | |
624 | ||
625 | set pos [split [$win index @$xrel,$yrel] .] | |
626 | ||
627 | # Record selected file and line for menu button actions | |
628 | ||
629 | set selected_line [lindex $pos 0] | |
630 | set selected_col [lindex $pos 1] | |
631 | set selected_win $win | |
632 | ||
633 | # Figure out the PC | |
634 | ||
635 | set pc [lindex $pclist($cfunc) $selected_line] | |
636 | ||
637 | # If we're in the margin, then toggle the breakpoint | |
638 | ||
746d1df4 | 639 | if {$selected_col < 11} { |
8532893d SG |
640 | set tmp pos_to_breakpoint($pc) |
641 | if [info exists $tmp] { | |
642 | set bpnum [set $tmp] | |
643 | gdb_cmd "delete $bpnum" | |
644 | } else { | |
645 | gdb_cmd "break *$pc" | |
646 | } | |
647 | return | |
648 | } | |
649 | ||
650 | # Post the menu near the pointer, (and grab it) | |
651 | ||
652 | # .file_popup entryconfigure 0 -label "$selected_file:$selected_line" | |
653 | # .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10] | |
654 | # grab .file_popup | |
655 | } | |
656 | ||
657 | # | |
658 | # Local procedure: | |
659 | # | |
660 | # do_nothing - Does absoultely nothing. | |
661 | # | |
662 | # Description: | |
663 | # | |
664 | # This procedure does nothing. It is used as a placeholder to allow | |
665 | # the disabling of bindings that would normally be inherited from the | |
666 | # parent widget. I can't think of any other way to do this. | |
667 | # | |
668 | ||
754e5da2 SG |
669 | proc do_nothing {} {} |
670 | ||
479f0f18 SG |
671 | # |
672 | # Local procedure: | |
673 | # | |
674 | # create_expr_win - Creat expression display window | |
675 | # | |
676 | # Description: | |
677 | # | |
678 | # Create the expression display window. | |
679 | # | |
680 | ||
681 | proc create_expr_win {} { | |
682 | toplevel .expr | |
683 | wm minsize .expr 1 1 | |
684 | wm title .expr Expression | |
685 | canvas .expr.c -yscrollcommand {.expr.scroll set} -cursor hand2 \ | |
686 | -borderwidth 2 -relief groove | |
687 | scrollbar .expr.scroll -orient vertical -command {.expr.c yview} | |
688 | entry .expr.entry -borderwidth 2 -relief groove | |
689 | ||
690 | pack .expr.entry -side bottom -fill x | |
691 | pack .expr.c -side left -fill both -expand yes | |
692 | pack .expr.scroll -side right -fill y | |
693 | ||
694 | .expr.c create text 100 0 -text "Text string" | |
695 | .expr.c create rectangle 245 195 255 205 -outline black -fill white | |
696 | } | |
697 | ||
698 | # | |
699 | # Local procedure: | |
700 | # | |
701 | # display_expression (expression) - Display EXPRESSION in display window | |
702 | # | |
703 | # Description: | |
704 | # | |
705 | # Display EXPRESSION and it's value in the expression display window. | |
706 | # | |
707 | ||
708 | proc display_expression {expression} { | |
709 | if ![winfo exists .expr] {create_expr_win} | |
710 | ||
711 | ||
712 | } | |
713 | ||
8532893d SG |
714 | # |
715 | # Local procedure: | |
716 | # | |
717 | # create_file_win (filename) - Create a win for FILENAME. | |
718 | # | |
719 | # Return value: | |
720 | # | |
721 | # The new text widget. | |
722 | # | |
723 | # Description: | |
724 | # | |
725 | # This procedure creates a text widget for FILENAME. It returns the | |
726 | # newly created widget. First, a text widget is created, and given basic | |
727 | # configuration info. Second, all the bindings are setup. Third, the | |
728 | # file FILENAME is read into the text widget. Fourth, margins and line | |
729 | # numbers are added. | |
730 | # | |
731 | ||
746d1df4 | 732 | proc create_file_win {filename debug_file} { |
754e5da2 SG |
733 | global breakpoint_file |
734 | global breakpoint_line | |
735 | ||
8532893d SG |
736 | # Replace all the dirty characters in $filename with clean ones, and generate |
737 | # a unique name for the text widget. | |
738 | ||
746d1df4 | 739 | regsub -all {\.} $filename {} temp |
006e71e9 | 740 | set win .src.text$temp |
8532893d | 741 | |
637b1661 SG |
742 | # Open the file, and read it into the text widget |
743 | ||
744 | if [catch "open $filename" fh] { | |
746d1df4 SG |
745 | # File can't be read. Put error message into .src.nofile window and return. |
746 | ||
747 | catch {destroy .src.nofile} | |
748 | text .src.nofile -height 25 -width 88 -relief raised \ | |
749 | -borderwidth 2 -yscrollcommand textscrollproc \ | |
750 | -setgrid true -cursor hand2 | |
751 | .src.nofile insert 0.0 $fh | |
752 | .src.nofile configure -state disabled | |
753 | bind .src.nofile <1> do_nothing | |
754 | bind .src.nofile <B1-Motion> do_nothing | |
755 | return .src.nofile | |
637b1661 SG |
756 | } |
757 | ||
8532893d SG |
758 | # Actually create and do basic configuration on the text widget. |
759 | ||
746d1df4 SG |
760 | text $win -height 25 -width 88 -relief raised -borderwidth 2 \ |
761 | -yscrollcommand textscrollproc -setgrid true -cursor hand2 | |
8532893d SG |
762 | |
763 | # Setup all the bindings | |
764 | ||
754e5da2 | 765 | bind $win <Enter> {focus %W} |
479f0f18 SG |
766 | # bind $win <1> {listing_window_button_1 %W %X %Y %x %y} |
767 | bind $win <1> do_nothing | |
754e5da2 | 768 | bind $win <B1-Motion> do_nothing |
479f0f18 | 769 | |
754e5da2 SG |
770 | bind $win n {gdb_cmd next ; update_ptr} |
771 | bind $win s {gdb_cmd step ; update_ptr} | |
772 | bind $win c {gdb_cmd continue ; update_ptr} | |
773 | bind $win f {gdb_cmd finish ; update_ptr} | |
774 | bind $win u {gdb_cmd up ; update_ptr} | |
775 | bind $win d {gdb_cmd down ; update_ptr} | |
8532893d | 776 | |
754e5da2 SG |
777 | $win delete 0.0 end |
778 | $win insert 0.0 [read $fh] | |
779 | close $fh | |
8532893d SG |
780 | |
781 | # Add margins (for annotations) and a line number to each line | |
782 | ||
754e5da2 SG |
783 | set numlines [$win index end] |
784 | set numlines [lindex [split $numlines .] 0] | |
785 | for {set i 1} {$i <= $numlines} {incr i} { | |
786 | $win insert $i.0 [format " %4d " $i] | |
479f0f18 SG |
787 | $win tag add source $i.8 "$i.0 lineend" |
788 | } | |
789 | ||
746d1df4 SG |
790 | # Add the breakdots |
791 | ||
792 | foreach i [gdb_sourcelines $debug_file] { | |
793 | $win delete $i.0 | |
794 | $win insert $i.0 "\xa4" | |
795 | $win tag add margin $i.0 $i.8 | |
796 | } | |
797 | ||
479f0f18 SG |
798 | $win tag bind margin <1> {listing_window_button_1 %W %X %Y %x %y} |
799 | $win tag bind source <1> { | |
800 | %W mark set anchor "@%x,%y wordstart" | |
801 | set last [%W index "@%x,%y wordend"] | |
802 | %W tag remove sel 0.0 anchor | |
803 | %W tag remove sel $last end | |
804 | %W tag add sel anchor $last | |
805 | } | |
806 | # $win tag bind source <Double-Button-1> { | |
807 | # %W mark set anchor "@%x,%y wordstart" | |
808 | # set last [%W index "@%x,%y wordend"] | |
809 | # %W tag remove sel 0.0 anchor | |
810 | # %W tag remove sel $last end | |
811 | # %W tag add sel anchor $last | |
812 | # echo "Selected [selection get]" | |
813 | # } | |
814 | $win tag bind source <B1-Motion> { | |
815 | %W tag remove sel 0.0 anchor | |
816 | %W tag remove sel $last end | |
817 | %W tag add sel anchor @%x,%y | |
754e5da2 | 818 | } |
479f0f18 SG |
819 | $win tag bind sel <1> do_nothing |
820 | $win tag bind sel <Double-Button-1> {display_expression [selection get]} | |
821 | $win tag raise sel | |
822 | ||
754e5da2 | 823 | |
8532893d SG |
824 | # Scan though the breakpoint data base and install any destined for this file |
825 | ||
754e5da2 SG |
826 | foreach bpnum [array names breakpoint_file] { |
827 | if {$breakpoint_file($bpnum) == $filename} { | |
828 | insert_breakpoint_tag $win $breakpoint_line($bpnum) | |
829 | } | |
830 | } | |
831 | ||
8532893d SG |
832 | # Disable the text widget to prevent user modifications |
833 | ||
754e5da2 SG |
834 | $win configure -state disabled |
835 | return $win | |
836 | } | |
837 | ||
8532893d SG |
838 | # |
839 | # Local procedure: | |
840 | # | |
637b1661 | 841 | # create_asm_win (funcname pc) - Create an assembly win for FUNCNAME. |
8532893d SG |
842 | # |
843 | # Return value: | |
844 | # | |
845 | # The new text widget. | |
846 | # | |
847 | # Description: | |
848 | # | |
849 | # This procedure creates a text widget for FUNCNAME. It returns the | |
850 | # newly created widget. First, a text widget is created, and given basic | |
851 | # configuration info. Second, all the bindings are setup. Third, the | |
852 | # function FUNCNAME is read into the text widget. | |
853 | # | |
854 | ||
637b1661 | 855 | proc create_asm_win {funcname pc} { |
8532893d SG |
856 | global breakpoint_file |
857 | global breakpoint_line | |
858 | global current_output_win | |
859 | global pclist | |
860 | ||
861 | # Replace all the dirty characters in $filename with clean ones, and generate | |
862 | # a unique name for the text widget. | |
863 | ||
335129a9 | 864 | set win [asm_win_name $funcname] |
8532893d SG |
865 | |
866 | # Actually create and do basic configuration on the text widget. | |
867 | ||
006e71e9 | 868 | text $win -height 25 -width 88 -relief raised -borderwidth 2 \ |
8532893d SG |
869 | -setgrid true -cursor hand2 -yscrollcommand asmscrollproc |
870 | ||
871 | # Setup all the bindings | |
872 | ||
873 | bind $win <Enter> {focus %W} | |
874 | bind $win <1> {asm_window_button_1 %W %X %Y %x %y} | |
875 | bind $win <B1-Motion> do_nothing | |
876 | bind $win n {gdb_cmd nexti ; update_ptr} | |
877 | bind $win s {gdb_cmd stepi ; update_ptr} | |
878 | bind $win c {gdb_cmd continue ; update_ptr} | |
879 | bind $win f {gdb_cmd finish ; update_ptr} | |
880 | bind $win u {gdb_cmd up ; update_ptr} | |
881 | bind $win d {gdb_cmd down ; update_ptr} | |
882 | ||
883 | # Disassemble the code, and read it into the new text widget | |
884 | ||
006e71e9 | 885 | set temp $current_output_win |
8532893d | 886 | set current_output_win $win |
637b1661 | 887 | gdb_cmd "disassemble $pc" |
006e71e9 | 888 | set current_output_win $temp |
8532893d SG |
889 | |
890 | set numlines [$win index end] | |
891 | set numlines [lindex [split $numlines .] 0] | |
637b1661 | 892 | decr numlines |
8532893d SG |
893 | |
894 | # Delete the first and last lines, cuz these contain useless info | |
895 | ||
896 | $win delete 1.0 2.0 | |
897 | $win delete {end - 1 lines} end | |
637b1661 | 898 | decr numlines 2 |
8532893d SG |
899 | |
900 | # Add margins (for annotations) and note the PC for each line | |
901 | ||
637b1661 | 902 | catch "unset pclist($funcname)" |
335129a9 | 903 | lappend pclist($funcname) Unused |
8532893d SG |
904 | for {set i 1} {$i <= $numlines} {incr i} { |
905 | scan [$win get $i.0 "$i.0 lineend"] "%s " pc | |
906 | lappend pclist($funcname) $pc | |
907 | $win insert $i.0 " " | |
908 | } | |
909 | ||
910 | ||
911 | # Scan though the breakpoint data base and install any destined for this file | |
912 | ||
913 | # foreach bpnum [array names breakpoint_file] { | |
914 | # if {$breakpoint_file($bpnum) == $filename} { | |
915 | # insert_breakpoint_tag $win $breakpoint_line($bpnum) | |
916 | # } | |
917 | # } | |
918 | ||
919 | # Disable the text widget to prevent user modifications | |
920 | ||
921 | $win configure -state disabled | |
922 | return $win | |
923 | } | |
924 | ||
925 | # | |
926 | # Local procedure: | |
927 | # | |
928 | # asmscrollproc (WINHEIGHT SCREENHEIGHT SCREENTOP SCREENBOT) - Update the | |
929 | # asm window scrollbar. | |
930 | # | |
931 | # Description: | |
932 | # | |
933 | # This procedure is called to update the assembler window's scrollbar. | |
934 | # | |
935 | ||
936 | proc asmscrollproc {args} { | |
937 | global asm_screen_height asm_screen_top asm_screen_bot | |
938 | ||
939 | eval ".asm.scroll set $args" | |
940 | set asm_screen_height [lindex $args 1] | |
941 | set asm_screen_top [lindex $args 2] | |
942 | set asm_screen_bot [lindex $args 3] | |
943 | } | |
944 | ||
945 | # | |
946 | # Local procedure: | |
947 | # | |
948 | # update_listing (linespec) - Update the listing window according to | |
949 | # LINESPEC. | |
950 | # | |
951 | # Description: | |
952 | # | |
953 | # This procedure is called from various places to update the listing | |
954 | # window based on LINESPEC. It is usually invoked with the result of | |
955 | # gdb_loc. | |
956 | # | |
957 | # It will move the cursor, and scroll the text widget if necessary. | |
958 | # Also, it will switch to another text widget if necessary, and update | |
959 | # the label widget too. | |
960 | # | |
961 | # LINESPEC is a list of the form: | |
962 | # | |
963 | # { DEBUG_FILE FUNCNAME FILENAME LINE }, where: | |
964 | # | |
965 | # DEBUG_FILE - is the abbreviated form of the file name. This is usually | |
966 | # the file name string given to the cc command. This is | |
967 | # primarily needed for breakpoint commands, and when an | |
968 | # abbreviated for of the filename is desired. | |
969 | # FUNCNAME - is the name of the function. | |
970 | # FILENAME - is the fully qualified (absolute) file name. It is usually | |
971 | # the same as $PWD/$DEBUG_FILE, where PWD is the working dir | |
972 | # at the time the cc command was given. This is used to | |
973 | # actually locate the file to be displayed. | |
974 | # LINE - The line number to be displayed. | |
975 | # | |
976 | # Usually, this procedure will just move the cursor one line down to the | |
977 | # next line to be executed. However, if the cursor moves out of range | |
978 | # or into another file, it will scroll the text widget so that the line | |
979 | # of interest is in the middle of the viewable portion of the widget. | |
980 | # | |
981 | ||
754e5da2 SG |
982 | proc update_listing {linespec} { |
983 | global pointers | |
984 | global screen_height | |
985 | global screen_top | |
986 | global screen_bot | |
987 | global wins cfile | |
988 | global current_label | |
989 | global win_to_file | |
990 | global file_to_debug_file | |
746d1df4 | 991 | global .src.label |
754e5da2 | 992 | |
8532893d SG |
993 | # Rip the linespec apart |
994 | ||
754e5da2 SG |
995 | set line [lindex $linespec 3] |
996 | set filename [lindex $linespec 2] | |
997 | set funcname [lindex $linespec 1] | |
998 | set debug_file [lindex $linespec 0] | |
999 | ||
8532893d SG |
1000 | # Sometimes there's no source file for this location |
1001 | ||
754e5da2 SG |
1002 | if {$filename == ""} {set filename Blank} |
1003 | ||
8532893d SG |
1004 | # If we want to switch files, we need to unpack the current text widget, and |
1005 | # stick in the new one. | |
1006 | ||
754e5da2 SG |
1007 | if {$filename != $cfile} then { |
1008 | pack forget $wins($cfile) | |
1009 | set cfile $filename | |
8532893d SG |
1010 | |
1011 | # Create a text widget for this file if necessary | |
1012 | ||
754e5da2 | 1013 | if ![info exists wins($cfile)] then { |
746d1df4 SG |
1014 | set wins($cfile) [create_file_win $cfile $debug_file] |
1015 | if {$wins($cfile) != ".src.nofile"} { | |
637b1661 SG |
1016 | set win_to_file($wins($cfile)) $cfile |
1017 | set file_to_debug_file($cfile) $debug_file | |
1018 | set pointers($cfile) 1.1 | |
1019 | } | |
754e5da2 SG |
1020 | } |
1021 | ||
8532893d SG |
1022 | # Pack the text widget into the listing widget, and scroll to the right place |
1023 | ||
746d1df4 SG |
1024 | pack $wins($cfile) -side left -expand yes -in .src.info \ |
1025 | -fill both -after .src.scroll | |
1026 | ||
1027 | # Make the scrollbar point at the new text widget | |
1028 | ||
1029 | .src.scroll configure -command "$wins($cfile) yview" | |
1030 | ||
754e5da2 SG |
1031 | $wins($cfile) yview [expr $line - $screen_height / 2] |
1032 | } | |
1033 | ||
8532893d SG |
1034 | # Update the label widget in case the filename or function name has changed |
1035 | ||
754e5da2 SG |
1036 | if {$current_label != "$filename.$funcname"} then { |
1037 | set tail [expr [string last / $filename] + 1] | |
746d1df4 SG |
1038 | set .src.label "[string range $filename $tail end] : ${funcname}()" |
1039 | # .src.label configure -text "[string range $filename $tail end] : ${funcname}()" | |
754e5da2 SG |
1040 | set current_label $filename.$funcname |
1041 | } | |
1042 | ||
8532893d SG |
1043 | # Update the pointer, scrolling the text widget if necessary to keep the |
1044 | # pointer in an acceptable part of the screen. | |
1045 | ||
754e5da2 SG |
1046 | if [info exists pointers($cfile)] then { |
1047 | $wins($cfile) configure -state normal | |
1048 | set pointer_pos $pointers($cfile) | |
1049 | $wins($cfile) configure -state normal | |
746d1df4 SG |
1050 | $wins($cfile) delete $pointer_pos "$pointer_pos + 2 char" |
1051 | $wins($cfile) insert $pointer_pos " " | |
754e5da2 SG |
1052 | |
1053 | set pointer_pos [$wins($cfile) index $line.1] | |
1054 | set pointers($cfile) $pointer_pos | |
1055 | ||
746d1df4 SG |
1056 | $wins($cfile) delete $pointer_pos "$pointer_pos + 2 char" |
1057 | $wins($cfile) insert $pointer_pos "->" | |
754e5da2 SG |
1058 | |
1059 | if {$line < $screen_top + 1 | |
1060 | || $line > $screen_bot} then { | |
1061 | $wins($cfile) yview [expr $line - $screen_height / 2] | |
1062 | } | |
1063 | ||
1064 | $wins($cfile) configure -state disabled | |
1065 | } | |
1066 | } | |
1067 | ||
8532893d SG |
1068 | # |
1069 | # Local procedure: | |
1070 | # | |
746d1df4 | 1071 | # create_asm_window - Open up the assembly window. |
8532893d SG |
1072 | # |
1073 | # Description: | |
1074 | # | |
1075 | # Create an assembly window if it doesn't exist. | |
1076 | # | |
1077 | ||
746d1df4 | 1078 | proc create_asm_window {} { |
8532893d SG |
1079 | global cfunc |
1080 | ||
1081 | if ![winfo exists .asm] { | |
1082 | set cfunc *None* | |
335129a9 SG |
1083 | set win [asm_win_name $cfunc] |
1084 | ||
006e71e9 SG |
1085 | build_framework .asm Assembly "*NIL*" |
1086 | ||
1087 | .asm.text configure -yscrollcommand asmscrollproc | |
8532893d | 1088 | |
006e71e9 SG |
1089 | frame .asm.row1 |
1090 | frame .asm.row2 | |
8532893d | 1091 | |
006e71e9 | 1092 | button .asm.stepi -width 6 -text Stepi \ |
8532893d | 1093 | -command {gdb_cmd stepi ; update_ptr} |
006e71e9 | 1094 | button .asm.nexti -width 6 -text Nexti \ |
8532893d | 1095 | -command {gdb_cmd nexti ; update_ptr} |
006e71e9 | 1096 | button .asm.continue -width 6 -text Cont \ |
8532893d | 1097 | -command {gdb_cmd continue ; update_ptr} |
006e71e9 | 1098 | button .asm.finish -width 6 -text Finish \ |
8532893d | 1099 | -command {gdb_cmd finish ; update_ptr} |
006e71e9 SG |
1100 | button .asm.up -width 6 -text Up -command {gdb_cmd up ; update_ptr} |
1101 | button .asm.down -width 6 -text Down \ | |
8532893d | 1102 | -command {gdb_cmd down ; update_ptr} |
006e71e9 | 1103 | button .asm.bottom -width 6 -text Bottom \ |
8532893d | 1104 | -command {gdb_cmd {frame 0} ; update_ptr} |
8532893d | 1105 | |
006e71e9 SG |
1106 | pack .asm.stepi .asm.continue .asm.up .asm.bottom -side left -padx 3 -pady 5 -in .asm.row1 |
1107 | pack .asm.nexti .asm.finish .asm.down -side left -padx 3 -pady 5 -in .asm.row2 | |
1108 | ||
1109 | pack .asm.row1 .asm.row2 -side top -anchor w | |
8532893d SG |
1110 | |
1111 | update | |
006e71e9 SG |
1112 | |
1113 | pack forget .asm.text | |
1114 | ||
1115 | update_assembly [gdb_loc] | |
8532893d SG |
1116 | } |
1117 | } | |
1118 | ||
746d1df4 SG |
1119 | proc reg_config_menu {} { |
1120 | global reg_format | |
1121 | ||
1122 | catch {destroy .reg.config} | |
1123 | toplevel .reg.config | |
1124 | wm geometry .reg.config +300+300 | |
1125 | wm title .reg.config "Register configuration" | |
1126 | wm iconname .reg.config "Reg config" | |
1127 | set regnames [gdb_regnames] | |
1128 | set num_regs [llength $regnames] | |
1129 | ||
1130 | button .reg.config.done -text Done -command {destroy .reg.config} | |
1131 | ||
1132 | pack .reg.config.done -side bottom -fill x | |
1133 | ||
1134 | # Since there can be lots of registers, we build the window with no more than | |
1135 | # 32 rows, and as many columns as needed. | |
1136 | ||
1137 | # First, figure out how many columns we need and create that many column frame | |
1138 | # widgets | |
1139 | ||
1140 | set ncols [expr ($num_regs + 31) / 32] | |
1141 | ||
1142 | for {set col 0} {$col < $ncols} {incr col} { | |
1143 | frame .reg.config.col$col | |
1144 | pack .reg.config.col$col -side left -anchor n | |
1145 | } | |
1146 | ||
1147 | # Now, create the checkbutton widgets and pack them in the appropriate columns | |
1148 | ||
1149 | set col 0 | |
1150 | set row 0 | |
1151 | for {set regnum 0} {$regnum < $num_regs} {incr regnum} { | |
1152 | set regname [lindex $regnames $regnum] | |
1153 | checkbutton .reg.config.col$col.$row -text $regname -pady 0 \ | |
cb3313c1 | 1154 | -variable regena($regnum) -relief flat -anchor w -bd 1 \ |
746d1df4 SG |
1155 | -command "recompute_reg_display_list $num_regs |
1156 | populate_reg_window | |
1157 | update_registers all" | |
1158 | ||
1159 | pack .reg.config.col$col.$row -side top -fill both | |
1160 | ||
1161 | incr row | |
1162 | if {$row >= 32} { | |
1163 | incr col | |
1164 | set row 0 | |
1165 | } | |
1166 | } | |
1167 | } | |
1168 | ||
335129a9 SG |
1169 | # |
1170 | # Local procedure: | |
1171 | # | |
746d1df4 | 1172 | # create_registers_window - Open up the register display window. |
335129a9 SG |
1173 | # |
1174 | # Description: | |
1175 | # | |
1176 | # Create the register display window, with automatic updates. | |
1177 | # | |
1178 | ||
746d1df4 SG |
1179 | proc create_registers_window {} { |
1180 | global reg_format | |
1181 | ||
1182 | if [winfo exists .reg] return | |
1183 | ||
1184 | # Create an initial register display list consisting of all registers | |
1185 | ||
1186 | if ![info exists reg_format] { | |
1187 | global reg_display_list | |
1188 | global changed_reg_list | |
cb3313c1 | 1189 | global regena |
746d1df4 SG |
1190 | |
1191 | set reg_format {} | |
1192 | set num_regs [llength [gdb_regnames]] | |
1193 | for {set regnum 0} {$regnum < $num_regs} {incr regnum} { | |
cb3313c1 | 1194 | set regena($regnum) 1 |
746d1df4 SG |
1195 | } |
1196 | recompute_reg_display_list $num_regs | |
1197 | set changed_reg_list $reg_display_list | |
1198 | } | |
1199 | ||
1200 | build_framework .reg Registers | |
1201 | ||
1202 | .reg.menubar.view.menu add command -label Natural | |
1203 | .reg.menubar.view.menu add command -label Config -command { | |
1204 | reg_config_menu } | |
1205 | ||
1206 | # Hex menu item | |
1207 | .reg.menubar.view.menu entryconfigure 0 -command { | |
1208 | global reg_format | |
1209 | ||
1210 | set reg_format x | |
1211 | update_registers all | |
1212 | } | |
1213 | # Decimal menu item | |
1214 | .reg.menubar.view.menu entryconfigure 1 -command { | |
1215 | global reg_format | |
1216 | ||
1217 | set reg_format d | |
1218 | update_registers all | |
1219 | } | |
1220 | # Octal menu item | |
1221 | .reg.menubar.view.menu entryconfigure 2 -command { | |
1222 | global reg_format | |
1223 | ||
1224 | set reg_format o | |
1225 | update_registers all | |
1226 | } | |
1227 | # Natural menu item | |
1228 | .reg.menubar.view.menu entryconfigure 3 -command { | |
1229 | global reg_format | |
1230 | ||
1231 | set reg_format {} | |
1232 | update_registers all | |
1233 | } | |
1234 | ||
1235 | destroy .reg.label | |
1236 | ||
1237 | # Install the reg names | |
1238 | ||
1239 | populate_reg_window | |
1240 | } | |
1241 | ||
cb3313c1 | 1242 | # Convert regena into a list of the enabled $regnums |
746d1df4 SG |
1243 | |
1244 | proc recompute_reg_display_list {num_regs} { | |
1245 | global reg_display_list | |
cb3313c1 SG |
1246 | global regmap |
1247 | global regena | |
746d1df4 SG |
1248 | |
1249 | catch {unset reg_display_list} | |
cb3313c1 SG |
1250 | |
1251 | set line 1 | |
746d1df4 | 1252 | for {set regnum 0} {$regnum < $num_regs} {incr regnum} { |
746d1df4 | 1253 | |
cb3313c1 | 1254 | if {[set regena($regnum)] != 0} { |
746d1df4 | 1255 | lappend reg_display_list $regnum |
cb3313c1 SG |
1256 | set regmap($regnum) $line |
1257 | incr line | |
746d1df4 SG |
1258 | } |
1259 | } | |
1260 | } | |
1261 | ||
1262 | # Fill out the register window with the names of the regs specified in | |
1263 | # reg_display_list. | |
1264 | ||
1265 | proc populate_reg_window {} { | |
1266 | global max_regname_width | |
1267 | global reg_display_list | |
1268 | ||
1269 | .reg.text configure -state normal | |
1270 | ||
1271 | .reg.text delete 0.0 end | |
1272 | ||
1273 | set regnames [eval gdb_regnames $reg_display_list] | |
1274 | ||
1275 | # Figure out the longest register name | |
335129a9 | 1276 | |
746d1df4 | 1277 | set max_regname_width 0 |
335129a9 | 1278 | |
746d1df4 SG |
1279 | foreach reg $regnames { |
1280 | set len [string length $reg] | |
1281 | if {$len > $max_regname_width} {set max_regname_width $len} | |
1282 | } | |
1283 | ||
1284 | set width [expr $max_regname_width + 15] | |
1285 | ||
1286 | set height [llength $regnames] | |
1287 | ||
1288 | if {$height > 60} {set height 60} | |
335129a9 | 1289 | |
746d1df4 SG |
1290 | .reg.text configure -height $height -width $width |
1291 | ||
1292 | foreach reg $regnames { | |
1293 | .reg.text insert end [format "%-*s \n" $max_regname_width ${reg}] | |
335129a9 | 1294 | } |
746d1df4 SG |
1295 | |
1296 | .reg.text yview 0 | |
1297 | .reg.text configure -state disabled | |
335129a9 SG |
1298 | } |
1299 | ||
1300 | # | |
1301 | # Local procedure: | |
1302 | # | |
1303 | # update_registers - Update the registers window. | |
1304 | # | |
1305 | # Description: | |
1306 | # | |
1307 | # This procedure updates the registers window. | |
1308 | # | |
1309 | ||
746d1df4 SG |
1310 | proc update_registers {which} { |
1311 | global max_regname_width | |
1312 | global reg_format | |
1313 | global reg_display_list | |
1314 | global changed_reg_list | |
1315 | global highlight | |
cb3313c1 | 1316 | global regmap |
335129a9 | 1317 | |
746d1df4 | 1318 | set margin [expr $max_regname_width + 1] |
006e71e9 | 1319 | set win .reg.text |
746d1df4 SG |
1320 | set winwidth [lindex [$win configure -width] 4] |
1321 | set valwidth [expr $winwidth - $margin] | |
335129a9 SG |
1322 | |
1323 | $win configure -state normal | |
1324 | ||
746d1df4 | 1325 | if {$which == "all"} { |
cb3313c1 | 1326 | set lineindex 1 |
746d1df4 SG |
1327 | foreach regnum $reg_display_list { |
1328 | set regval [gdb_fetch_registers $reg_format $regnum] | |
1329 | set regval [format "%-*s" $valwidth $regval] | |
cb3313c1 SG |
1330 | $win delete $lineindex.$margin "$lineindex.0 lineend" |
1331 | $win insert $lineindex.$margin $regval | |
1332 | incr lineindex | |
746d1df4 SG |
1333 | } |
1334 | $win configure -state disabled | |
1335 | return | |
1336 | } | |
335129a9 | 1337 | |
746d1df4 SG |
1338 | # Unhighlight the old values |
1339 | ||
1340 | foreach regnum $changed_reg_list { | |
1341 | $win tag delete $win.$regnum | |
1342 | } | |
1343 | ||
1344 | # Now, highlight the changed values of the interesting registers | |
1345 | ||
1346 | set changed_reg_list [eval gdb_changed_register_list $reg_display_list] | |
1347 | ||
cb3313c1 | 1348 | set lineindex 1 |
746d1df4 SG |
1349 | foreach regnum $changed_reg_list { |
1350 | set regval [gdb_fetch_registers $reg_format $regnum] | |
1351 | set regval [format "%-*s" $valwidth $regval] | |
cb3313c1 SG |
1352 | |
1353 | set lineindex $regmap($regnum) | |
746d1df4 SG |
1354 | $win delete $lineindex.$margin "$lineindex.0 lineend" |
1355 | $win insert $lineindex.$margin $regval | |
1356 | $win tag add $win.$regnum $lineindex.0 "$lineindex.0 lineend" | |
1357 | eval $win tag configure $win.$regnum $highlight | |
1358 | } | |
335129a9 | 1359 | |
335129a9 SG |
1360 | $win configure -state disabled |
1361 | } | |
1362 | ||
8532893d SG |
1363 | # |
1364 | # Local procedure: | |
1365 | # | |
1366 | # update_assembly - Update the assembly window. | |
1367 | # | |
1368 | # Description: | |
1369 | # | |
1370 | # This procedure updates the assembly window. | |
1371 | # | |
1372 | ||
1373 | proc update_assembly {linespec} { | |
1374 | global asm_pointers | |
1375 | global screen_height | |
1376 | global screen_top | |
1377 | global screen_bot | |
1378 | global wins cfunc | |
1379 | global current_label | |
1380 | global win_to_file | |
1381 | global file_to_debug_file | |
1382 | global current_asm_label | |
1383 | global pclist | |
1384 | global asm_screen_height asm_screen_top asm_screen_bot | |
746d1df4 | 1385 | global .asm.label |
8532893d SG |
1386 | |
1387 | # Rip the linespec apart | |
1388 | ||
1389 | set pc [lindex $linespec 4] | |
1390 | set line [lindex $linespec 3] | |
1391 | set filename [lindex $linespec 2] | |
1392 | set funcname [lindex $linespec 1] | |
1393 | set debug_file [lindex $linespec 0] | |
1394 | ||
335129a9 | 1395 | set win [asm_win_name $cfunc] |
8532893d SG |
1396 | |
1397 | # Sometimes there's no source file for this location | |
1398 | ||
1399 | if {$filename == ""} {set filename Blank} | |
1400 | ||
1401 | # If we want to switch funcs, we need to unpack the current text widget, and | |
1402 | # stick in the new one. | |
1403 | ||
637b1661 | 1404 | if {$funcname != $cfunc } { |
8532893d SG |
1405 | pack forget $win |
1406 | set cfunc $funcname | |
1407 | ||
335129a9 | 1408 | set win [asm_win_name $cfunc] |
8532893d SG |
1409 | |
1410 | # Create a text widget for this func if necessary | |
1411 | ||
637b1661 SG |
1412 | if {![winfo exists $win]} { |
1413 | create_asm_win $cfunc $pc | |
8532893d SG |
1414 | set asm_pointers($cfunc) 1.1 |
1415 | set current_asm_label NIL | |
1416 | } | |
1417 | ||
1418 | # Pack the text widget, and scroll to the right place | |
1419 | ||
1420 | pack $win -side left -expand yes -fill both \ | |
006e71e9 | 1421 | -after .asm.scroll |
746d1df4 | 1422 | .asm.scroll configure -command "$win yview" |
637b1661 | 1423 | set line [pc_to_line $pclist($cfunc) $pc] |
8532893d SG |
1424 | $win yview [expr $line - $asm_screen_height / 2] |
1425 | } | |
1426 | ||
1427 | # Update the label widget in case the filename or function name has changed | |
1428 | ||
335129a9 | 1429 | if {$current_asm_label != "$pc $funcname"} then { |
746d1df4 SG |
1430 | set .asm.label "$pc $funcname" |
1431 | # .asm.label configure -text "$pc $funcname" | |
335129a9 | 1432 | set current_asm_label "$pc $funcname" |
8532893d SG |
1433 | } |
1434 | ||
1435 | # Update the pointer, scrolling the text widget if necessary to keep the | |
1436 | # pointer in an acceptable part of the screen. | |
1437 | ||
1438 | if [info exists asm_pointers($cfunc)] then { | |
1439 | $win configure -state normal | |
1440 | set pointer_pos $asm_pointers($cfunc) | |
1441 | $win configure -state normal | |
746d1df4 SG |
1442 | $win delete $pointer_pos "$pointer_pos + 2 char" |
1443 | $win insert $pointer_pos " " | |
8532893d SG |
1444 | |
1445 | # Map the PC back to a line in the window | |
1446 | ||
637b1661 | 1447 | set line [pc_to_line $pclist($cfunc) $pc] |
8532893d SG |
1448 | |
1449 | if {$line == -1} { | |
1450 | echo "Can't find PC $pc" | |
1451 | return | |
1452 | } | |
1453 | ||
8532893d SG |
1454 | set pointer_pos [$win index $line.1] |
1455 | set asm_pointers($cfunc) $pointer_pos | |
1456 | ||
746d1df4 SG |
1457 | $win delete $pointer_pos "$pointer_pos + 2 char" |
1458 | $win insert $pointer_pos "->" | |
8532893d SG |
1459 | |
1460 | if {$line < $asm_screen_top + 1 | |
1461 | || $line > $asm_screen_bot} then { | |
1462 | $win yview [expr $line - $asm_screen_height / 2] | |
1463 | } | |
1464 | ||
1465 | # echo "Picking line $line" | |
1466 | # $win yview -pickplace $line | |
1467 | ||
1468 | $win configure -state disabled | |
1469 | } | |
1470 | } | |
1471 | ||
006e71e9 SG |
1472 | # |
1473 | # Local procedure: | |
1474 | # | |
1475 | # update_ptr - Update the listing window. | |
1476 | # | |
1477 | # Description: | |
1478 | # | |
1479 | # This routine will update the listing window using the result of | |
1480 | # gdb_loc. | |
1481 | # | |
1482 | ||
8532893d SG |
1483 | proc update_ptr {} { |
1484 | update_listing [gdb_loc] | |
1485 | if [winfo exists .asm] { | |
1486 | update_assembly [gdb_loc] | |
1487 | } | |
335129a9 | 1488 | if [winfo exists .reg] { |
746d1df4 | 1489 | update_registers changed |
335129a9 | 1490 | } |
8532893d SG |
1491 | } |
1492 | ||
006e71e9 | 1493 | # Make toplevel window disappear |
754e5da2 | 1494 | |
006e71e9 | 1495 | wm withdraw . |
754e5da2 | 1496 | |
754e5da2 SG |
1497 | proc files_command {} { |
1498 | toplevel .files_window | |
1499 | ||
1500 | wm minsize .files_window 1 1 | |
1501 | # wm overrideredirect .files_window true | |
1502 | listbox .files_window.list -geometry 30x20 -setgrid true | |
1503 | button .files_window.close -text Close -command {destroy .files_window} | |
1504 | tk_listboxSingleSelect .files_window.list | |
1505 | eval .files_window.list insert 0 [lsort [gdb_listfiles]] | |
1506 | pack .files_window.list -side top -fill both -expand yes | |
1507 | pack .files_window.close -side bottom -fill x -expand no -anchor s | |
1508 | bind .files_window.list <Any-ButtonRelease-1> { | |
1509 | set file [%W get [%W curselection]] | |
1510 | gdb_cmd "list $file:1,0" | |
1511 | update_listing [gdb_loc $file:1] | |
1512 | destroy .files_window} | |
1513 | } | |
1514 | ||
1515 | button .files -text Files -command files_command | |
1516 | ||
754e5da2 SG |
1517 | # Setup command window |
1518 | ||
006e71e9 | 1519 | proc build_framework {win {title GDBtk} {label {}}} { |
746d1df4 | 1520 | global ${win}.label |
006e71e9 SG |
1521 | |
1522 | toplevel ${win} | |
04576ab6 | 1523 | wm title ${win} $title |
006e71e9 SG |
1524 | wm minsize ${win} 1 1 |
1525 | ||
1526 | frame ${win}.menubar | |
1527 | ||
1528 | menubutton ${win}.menubar.file -padx 12 -text File \ | |
1529 | -menu ${win}.menubar.file.menu -underline 0 | |
1530 | ||
1531 | menu ${win}.menubar.file.menu | |
1532 | ${win}.menubar.file.menu add command -label Edit \ | |
1533 | -command {exec $editor +[expr ($screen_top + $screen_bot)/2] $cfile &} | |
1534 | ${win}.menubar.file.menu add command -label Close \ | |
1535 | -command "destroy ${win}" | |
1536 | ${win}.menubar.file.menu add command -label Quit \ | |
1537 | -command {gdb_cmd quit} | |
1538 | ||
1539 | menubutton ${win}.menubar.view -padx 12 -text View \ | |
1540 | -menu ${win}.menubar.view.menu -underline 0 | |
1541 | ||
1542 | menu ${win}.menubar.view.menu | |
1543 | ${win}.menubar.view.menu add command -label Hex -command {echo Hex} | |
1544 | ${win}.menubar.view.menu add command -label Decimal \ | |
1545 | -command {echo Decimal} | |
1546 | ${win}.menubar.view.menu add command -label Octal -command {echo Octal} | |
1547 | ||
1548 | menubutton ${win}.menubar.window -padx 12 -text Window \ | |
1549 | -menu ${win}.menubar.window.menu -underline 0 | |
1550 | ||
1551 | menu ${win}.menubar.window.menu | |
1552 | ${win}.menubar.window.menu add command -label Source \ | |
1553 | -command {echo Source} | |
1554 | ${win}.menubar.window.menu add command -label Command \ | |
1555 | -command {echo Command} | |
1556 | ${win}.menubar.window.menu add command -label Assembly \ | |
746d1df4 | 1557 | -command {create_asm_window ; update_ptr} |
006e71e9 | 1558 | ${win}.menubar.window.menu add command -label Register \ |
746d1df4 | 1559 | -command {create_registers_window ; update_ptr} |
006e71e9 SG |
1560 | |
1561 | menubutton ${win}.menubar.help -padx 12 -text Help \ | |
1562 | -menu ${win}.menubar.help.menu -underline 0 | |
1563 | ||
1564 | menu ${win}.menubar.help.menu | |
1565 | ${win}.menubar.help.menu add command -label "with GDBtk" \ | |
1566 | -command {echo "with GDBtk"} | |
1567 | ${win}.menubar.help.menu add command -label "with this window" \ | |
1568 | -command {echo "with this window"} | |
c981300c SG |
1569 | ${win}.menubar.help.menu add command -label "Report bug" \ |
1570 | -command {exec send-pr} | |
006e71e9 SG |
1571 | |
1572 | tk_menuBar ${win}.menubar ${win}.menubar.file ${win}.menubar.view \ | |
1573 | ${win}.menubar.window ${win}.menubar.help | |
1574 | pack ${win}.menubar.file ${win}.menubar.view ${win}.menubar.window \ | |
1575 | -side left | |
1576 | pack ${win}.menubar.help -side right | |
1577 | ||
1578 | frame ${win}.info | |
1579 | text ${win}.text -height 25 -width 80 -relief raised -borderwidth 2 \ | |
1580 | -setgrid true -cursor hand2 -yscrollcommand "${win}.scroll set" | |
1581 | ||
746d1df4 SG |
1582 | set ${win}.label $label |
1583 | label ${win}.label -textvariable ${win}.label -borderwidth 2 -relief raised | |
754e5da2 | 1584 | |
006e71e9 SG |
1585 | scrollbar ${win}.scroll -orient vertical -command "${win}.text yview" |
1586 | ||
1587 | pack ${win}.label -side bottom -fill x -in ${win}.info | |
1588 | pack ${win}.scroll -side right -fill y -in ${win}.info | |
1589 | pack ${win}.text -side left -expand yes -fill both -in ${win}.info | |
1590 | ||
1591 | pack ${win}.menubar -side top -fill x | |
1592 | pack ${win}.info -side top -fill both -expand yes | |
1593 | } | |
1594 | ||
746d1df4 SG |
1595 | proc create_source_window {} { |
1596 | global wins | |
1597 | global cfile | |
1598 | ||
1599 | build_framework .src Source "*No file*" | |
1600 | ||
1601 | frame .src.row1 | |
1602 | frame .src.row2 | |
1603 | ||
1604 | button .src.start -width 6 -text Start -command \ | |
1605 | {gdb_cmd {break main} | |
1606 | gdb_cmd {enable delete $bpnum} | |
1607 | gdb_cmd run | |
1608 | update_ptr } | |
1609 | button .src.stop -width 6 -text Stop -fg red -activeforeground red \ | |
1610 | -state disabled -command gdb_stop | |
1611 | button .src.step -width 6 -text Step \ | |
1612 | -command {gdb_cmd step ; update_ptr} | |
1613 | button .src.next -width 6 -text Next \ | |
1614 | -command {gdb_cmd next ; update_ptr} | |
1615 | button .src.continue -width 6 -text Cont \ | |
1616 | -command {gdb_cmd continue ; update_ptr} | |
1617 | button .src.finish -width 6 -text Finish \ | |
1618 | -command {gdb_cmd finish ; update_ptr} | |
1619 | button .src.up -width 6 -text Up -command {gdb_cmd up ; update_ptr} | |
1620 | button .src.down -width 6 -text Down \ | |
1621 | -command {gdb_cmd down ; update_ptr} | |
1622 | button .src.bottom -width 6 -text Bottom \ | |
1623 | -command {gdb_cmd {frame 0} ; update_ptr} | |
1624 | ||
1625 | pack .src.start .src.step .src.continue .src.up .src.bottom \ | |
1626 | -side left -padx 3 -pady 5 -in .src.row1 | |
1627 | pack .src.stop .src.next .src.finish .src.down -side left -padx 3 \ | |
1628 | -pady 5 -in .src.row2 | |
1629 | ||
1630 | pack .src.row1 .src.row2 -side top -anchor w | |
1631 | ||
1632 | $wins($cfile) insert 0.0 " This page intentionally left blank." | |
1633 | $wins($cfile) configure -width 88 -state disabled \ | |
1634 | -yscrollcommand textscrollproc | |
1635 | ||
1636 | proc textscrollproc {args} {global screen_height screen_top screen_bot | |
1637 | eval ".src.scroll set $args" | |
1638 | set screen_height [lindex $args 1] | |
1639 | set screen_top [lindex $args 2] | |
1640 | set screen_bot [lindex $args 3]} | |
1641 | } | |
754e5da2 | 1642 | |
746d1df4 | 1643 | proc create_command_window {} { |
754e5da2 SG |
1644 | global command_line |
1645 | ||
746d1df4 SG |
1646 | build_framework .cmd Command "* Command Buffer *" |
1647 | ||
754e5da2 | 1648 | set command_line {} |
746d1df4 SG |
1649 | |
1650 | gdb_cmd {set language c} | |
1651 | gdb_cmd {set height 0} | |
1652 | gdb_cmd {set width 0} | |
1653 | ||
1654 | bind .cmd.text <Enter> {focus %W} | |
1655 | bind .cmd.text <Delete> {delete_char %W} | |
1656 | bind .cmd.text <BackSpace> {delete_char %W} | |
1657 | bind .cmd.text <Control-u> {delete_line %W} | |
1658 | bind .cmd.text <Any-Key> { | |
1659 | global command_line | |
1660 | ||
1661 | %W insert end %A | |
1662 | %W yview -pickplace end | |
1663 | append command_line %A | |
1664 | } | |
1665 | bind .cmd.text <Key-Return> { | |
1666 | global command_line | |
1667 | ||
1668 | %W insert end \n | |
1669 | %W yview -pickplace end | |
1670 | gdb_cmd $command_line | |
1671 | set command_line {} | |
1672 | update_ptr | |
1673 | %W insert end "(gdb) " | |
1674 | %W yview -pickplace end | |
1675 | } | |
1676 | ||
1677 | proc delete_char {win} { | |
1678 | global command_line | |
1679 | ||
1680 | tk_textBackspace $win | |
1681 | $win yview -pickplace insert | |
1682 | set tmp [expr [string length $command_line] - 2] | |
1683 | set command_line [string range $command_line 0 $tmp] | |
754e5da2 | 1684 | } |
479f0f18 | 1685 | |
746d1df4 SG |
1686 | proc delete_line {win} { |
1687 | global command_line | |
754e5da2 | 1688 | |
746d1df4 SG |
1689 | $win delete {end linestart + 6 chars} end |
1690 | $win yview -pickplace insert | |
1691 | set command_line {} | |
1692 | } | |
754e5da2 SG |
1693 | } |
1694 | ||
746d1df4 | 1695 | # Setup the initial windows |
a5cffdc4 | 1696 | |
746d1df4 SG |
1697 | create_source_window |
1698 | ||
1699 | if {[tk colormodel .src.text] == "color"} { | |
1700 | set highlight "-background red2 -borderwidth 2 -relief sunk" | |
1701 | } else { | |
1702 | set fg [lindex [.src.text config -foreground] 4] | |
1703 | set bg [lindex [.src.text config -background] 4] | |
1704 | set highlight "-foreground $bg -background $fg -borderwidth 0" | |
a5cffdc4 | 1705 | } |
746d1df4 SG |
1706 | |
1707 | create_command_window | |
1708 | update |