1 # GDB GUI setup for GDB, the GNU debugger.
2 # Copyright 1994, 1995, 1996
3 # Free Software Foundation, Inc.
5 # Written by Stu Grossman <grossman@cygnus.com> of Cygnus Support.
7 # This file is part of GDB.
9 # This program is free software; you can redistribute it and/or modify
10 # it under the terms of the GNU General Public License as published by
11 # the Free Software Foundation; either version 2 of the License, or
12 # (at your option) any later version.
14 # This program is distributed in the hope that it will be useful,
15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 # GNU General Public License for more details.
19 # You should have received a copy of the GNU General Public License
20 # along with this program; if not, write to the Free Software
21 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24 set wins
($cfile) .src.
text
28 set breakpoint_file
(-1) {[garbage
]}
29 set disassemble_with_source nosource
30 set gdb_prompt
"(gdb) "
32 # Hint: The following can be toggled from a tclsh window after
33 # using the gdbtk "tk tclsh" command to open the window.
36 #option add *Foreground Black
37 #option add *Background White
38 #option add *Font -*-*-medium-r-normal--18-*-*-*-m-*-*-1
40 proc echo
string {puts stdout
$string}
42 # Assign elements from LIST to variables named in ARGS. FIXME replace
43 # with TclX version someday.
44 proc lassign
{list args
} {
45 set len
[expr {[llength $args] - 1}]
47 upvar [lindex $args $len] local
48 set local
[lindex $list $len]
56 # decr (var val) - compliment to incr
61 proc decr
{var
{val
1}} {
63 set num
[expr {$num - $val}]
68 # Center a window on the screen.
70 proc center_window
{toplevel} {
71 # Withdraw and update, to ensure geometry computations are finished.
75 set x
[expr {[winfo screenwidth
$toplevel] / 2
76 - [winfo reqwidth
$toplevel] / 2
77 - [winfo vrootx
$toplevel]}]
78 set y
[expr {[winfo screenheight
$toplevel] / 2
79 - [winfo reqheight
$toplevel] / 2
80 - [winfo vrooty
$toplevel]}]
81 wm geometry
$toplevel +${x
}+${y
}
82 wm deiconify
$toplevel
86 # Rearrange the bindtags so the widget comes after the class. I was
87 # always for Ousterhout putting the class bindings first, but no...
89 proc bind_widget_after_class
{widget
} {
90 set class
[winfo class
$widget]
92 foreach tag
[bindtags $widget] {
93 if {$tag == $widget} {
98 lappend newList
$widget
102 bindtags $widget $newList
106 # Make sure line number $LINE is visible in the text widget. But be
107 # more clever than the "see" command: if LINE is not currently
108 # displayed, arrange for LINE to be centered. There are cases in
109 # which this does not work, so as a last resort we revert to "see".
111 # This is inefficient, but probably not slow enough to actually
114 proc ensure_line_visible
{text line
} {
115 set pixHeight
[winfo height
$text]
116 # Compute height of widget in lines. This fails if a line is wider
117 # than the screen. FIXME.
118 set topLine
[lindex [split [$text index
@0,0] .
] 0]
119 set botLine
[lindex [split [$text index
@0,${pixHeight
}] .
] 0]
121 if {$line > $topLine && $line < $botLine} then
{
122 # Onscreen, and not on the very edge.
126 set newTop
[expr {$line - ($botLine - $topLine)}]
127 if {$newTop < 0} then
{
130 $text yview moveto
$newTop
132 # In case the above failed.
136 if {[info exists env
(EDITOR
)]} then
{
137 set editor
$env(EDITOR
)
144 # These functions are called by GDB (from C code) to do various things in
145 # TK-land. All start with the prefix `gdbtk_tcl_' to make them easy to find.
151 # gdbtk_tcl_fputs (text) - Output text to the command window
155 # GDB calls this to output TEXT to the GDB command window. The text is
156 # placed at the end of the text widget. Note that output may not occur,
157 # due to buffering. Use gdbtk_tcl_flush to cause an immediate update.
160 proc gdbtk_tcl_fputs
{arg
} {
161 .cmd.
text insert end
"$arg"
165 proc gdbtk_tcl_fputs_error
{arg
} {
166 .cmd.
text insert end
"$arg"
173 # gdbtk_tcl_flush () - Flush output to the command window
177 # GDB calls this to force all buffered text to the GDB command window.
180 proc gdbtk_tcl_flush
{} {
188 # gdbtk_tcl_query (message) - Create a yes/no query dialog box
192 # GDB calls this to create a yes/no dialog box containing MESSAGE. GDB
193 # is hung while the dialog box is active (ie: no commands will work),
194 # however windows can still be refreshed in case of damage or exposure.
197 proc gdbtk_tcl_query
{message} {
198 # FIXME We really want a Help button here. But Tk's brain-damaged
199 # modal dialogs won't really allow it. Should have async dialog
201 set result
[tk_dialog .query
"gdb : query" "$message" questhead
0 Yes No
]
202 return [expr {!$result}]
208 # gdbtk_start_variable_annotation (args ...) -
212 # Not yet implemented.
215 proc gdbtk_tcl_start_variable_annotation
{valaddr ref_type stor_cl
216 cum_expr field type_cast
} {
217 echo
"gdbtk_tcl_start_variable_annotation $valaddr $ref_type $stor_cl $cum_expr $field $type_cast"
223 # gdbtk_end_variable_annotation (args ...) -
227 # Not yet implemented.
230 proc gdbtk_tcl_end_variable_annotation
{} {
231 echo gdbtk_tcl_end_variable_annotation
237 # gdbtk_tcl_breakpoint (action bpnum file line) - Notify the TK
238 # interface of changes to breakpoints.
242 # GDB calls this to notify TK of changes to breakpoints. ACTION is one
244 # create - Notify of breakpoint creation
245 # delete - Notify of breakpoint deletion
246 # modify - Notify of breakpoint modification
249 # file line pc type enabled disposition silent ignore_count commands cond_string thread hit_count
251 proc gdbtk_tcl_breakpoint
{action bpnum
} {
252 set bpinfo
[gdb_get_breakpoint_info
$bpnum]
253 set file [lindex $bpinfo 0]
254 set line
[lindex $bpinfo 1]
255 set pc
[lindex $bpinfo 2]
256 set enable
[lindex $bpinfo 4]
258 if {$action == "modify"} {
259 if {$enable == "1"} {
266 ${action
}_breakpoint
$bpnum $file $line $pc
272 # gdbtk_tcl_readline_begin (message) - Notify Tk to open an interaction
273 # window and start gathering user input
277 # GDB calls this to notify TK that it needs to open an interaction
278 # window, displaying the given message, and be prepared to accept
279 # calls to gdbtk_tcl_readline to gather user input.
281 proc gdbtk_tcl_readline_begin
{message} {
284 # If another readline window already exists, just bring it to the front.
285 if {[winfo exists .rl
]} {raise .rl
; return}
287 # Create top level frame with scrollbar and text widget.
289 wm title .rl
"Interaction Window"
290 wm iconname .rl
"Input"
291 message .rl.msg
-text $message -aspect 7500 -justify left
292 text .rl.
text -width 80 -height 20 -setgrid true
-cursor hand2
\
293 -yscrollcommand {.rl.scroll
set}
294 scrollbar .rl.scroll
-command {.rl.
text yview
}
295 pack .rl.msg
-side top
-fill x
296 pack .rl.scroll
-side right
-fill y
297 pack .rl.
text -side left
-fill both
-expand true
299 # When the user presses return, get the text from the command start mark to the
300 # current insert point, stash it in the readline text variable, and update the
301 # command start mark to the current insert point
302 bind .rl.
text <Return
> {
303 set readline_text
[.rl.
text get cmdstart
{end
- 1 char
}]
304 .rl.
text mark
set cmdstart insert
306 bind .rl.
text <BackSpace
> {
307 if [%W compare insert
> cmdstart
] {
308 %W delete
{insert
- 1 char
} insert
314 bind .rl.
text <Any-Key
> {
315 if [%W compare insert
< cmdstart
] {
316 %W mark
set insert end
319 bind .rl.
text <Control-u
> {
320 %W delete cmdstart
"insert lineend"
323 bindtags .rl.
text {.rl.
text Text all
}
329 # gdbtk_tcl_readline (prompt) - Get one user input line
333 # GDB calls this to get one line of input from the user interaction
334 # window, using "prompt" as the command line prompt.
336 proc gdbtk_tcl_readline
{prompt
} {
339 .rl.
text insert end
$prompt
340 .rl.
text mark
set cmdstart insert
341 .rl.
text mark gravity cmdstart left
344 # Make this window the current one for input.
347 tkwait variable readline_text
349 return $readline_text
355 # gdbtk_tcl_readline_end - Terminate a user interaction
359 # GDB calls this when it is done getting interactive user input.
360 # Destroy the interaction window.
362 proc gdbtk_tcl_readline_end
{} {
363 if {[winfo exists .rl
]} { destroy .rl
}
366 proc create_breakpoints_window
{} {
369 if {[winfo exists .breakpoints
]} {raise .breakpoints
; return}
371 build_framework .breakpoints
"Breakpoints" ""
373 # First, delete all the old view menu entries
375 .breakpoints.menubar.view.
menu delete
0 last
379 destroy .breakpoints.
label
381 # Replace text with a canvas and fix the scrollbars
383 destroy .breakpoints.
text
384 scrollbar .breakpoints.scrollx
-orient horizontal
\
385 -command {.breakpoints.c xview
} -relief sunken
386 canvas .breakpoints.c
-relief sunken
-bd 2 \
388 -yscrollcommand {.breakpoints.scroll
set} \
389 -xscrollcommand {.breakpoints.scrollx
set}
390 .breakpoints.scroll configure
-command {.breakpoints.c yview
}
392 pack .breakpoints.scrollx
-side bottom
-fill x
-in .breakpoints.
info
393 pack .breakpoints.c
-side left
-expand yes
-fill both
\
394 -in .breakpoints.
info
398 # Create a frame for each breakpoint
400 foreach bpnum
[gdb_get_breakpoint_list
] {
401 add_breakpoint_frame
$bpnum
405 # Create a frame for bpnum in the .breakpoints canvas
407 proc add_breakpoint_frame
{bpnum
} {
412 if {![winfo exists .breakpoints
]} return
414 set bpinfo
[gdb_get_breakpoint_info
$bpnum]
416 lassign
$bpinfo file line pc type enabled
($bpnum) disposition
($bpnum) \
417 silent ignore_count commands cond thread hit_count
419 set f .breakpoints.c.
$bpnum
421 if {![winfo exists
$f]} {
422 frame $f -relief sunken
-bd 2
424 label $f.id
-text "#$bpnum $file:$line ($pc)" \
425 -relief flat
-bd 2 -anchor w
427 label $f.hit_count.
label -text "Hit count:" -relief flat
\
428 -bd 2 -anchor w
-width 11
429 label $f.hit_count.val
-text $hit_count -relief flat
\
431 checkbutton $f.hit_count.enabled
-text Enabled
\
432 -variable enabled
($bpnum) -anchor w
-relief flat
434 pack $f.hit_count.
label $f.hit_count.val
-side left
435 pack $f.hit_count.enabled
-side right
438 label $f.thread.
label -text "Thread: " -relief flat
-bd 2 \
440 entry $f.thread.
entry -bd 2 -relief sunken
-width 10
441 $f.thread.
entry insert end
$thread
442 pack $f.thread.
label -side left
443 pack $f.thread.
entry -side left
-fill x
446 label $f.cond.
label -text "Condition: " -relief flat
-bd 2 \
448 entry $f.cond.
entry -bd 2 -relief sunken
449 $f.cond.
entry insert end
$cond
450 pack $f.cond.
label -side left
451 pack $f.cond.
entry -side left
-fill x
-expand yes
453 frame $f.ignore_count
454 label $f.ignore_count.
label -text "Ignore count: " \
455 -relief flat
-bd 2 -width 11 -anchor w
456 entry $f.ignore_count.
entry -bd 2 -relief sunken
-width 10
457 $f.ignore_count.
entry insert end
$ignore_count
458 pack $f.ignore_count.
label -side left
459 pack $f.ignore_count.
entry -side left
-fill x
463 label $f.disps.
label -text "Disposition: " -relief flat
-bd 2 \
466 radiobutton $f.disps.delete
-text Delete
\
467 -variable disposition
($bpnum) -anchor w
-relief flat
\
468 -command "gdb_cmd \"delete break $bpnum\"" \
471 radiobutton $f.disps.disable
-text Disable
\
472 -variable disposition
($bpnum) -anchor w
-relief flat
\
473 -command "gdb_cmd \"disable break $bpnum\"" \
476 radiobutton $f.disps.donttouch
-text "Leave alone" \
477 -variable disposition
($bpnum) -anchor w
-relief flat
\
478 -command "gdb_cmd \"enable break $bpnum\"" \
481 pack $f.disps.
label $f.disps.delete
$f.disps.disable
\
482 $f.disps.donttouch
-side left
-anchor w
483 text $f.commands
-relief sunken
-bd 2 -setgrid true
\
484 -cursor hand2
-height 3 -width 30
486 foreach line
$commands {
487 $f.commands insert end
"${line}\n"
490 pack $f.id
-side top
-anchor nw
-fill x
491 pack $f.hit_count
$f.cond
$f.thread
$f.ignore_count
$f.disps
\
492 $f.commands
-side top
-fill x
-anchor nw
495 set tag
[.breakpoints.c create window
0 $bpframe_lasty -window $f -anchor nw
]
497 set bbox
[.breakpoints.c bbox
$tag]
499 set bpframe_lasty
[lindex $bbox 3]
501 .breakpoints.c configure
-width [lindex $bbox 2]
504 # Delete a breakpoint frame
506 proc delete_breakpoint_frame
{bpnum
} {
509 if {![winfo exists .breakpoints
]} return
511 # First, clear the canvas
513 .breakpoints.c delete all
515 # Now, repopulate it with all but the doomed breakpoint
518 foreach bp
[gdb_get_breakpoint_list
] {
520 add_breakpoint_frame
$bp
525 proc asm_win_name
{funcname
} {
526 if {$funcname == "*None*"} {return .asm.
text}
528 regsub -all {\.
} $funcname _ temp
530 return .asm.func_
${temp
}
536 # create_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
540 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
541 # land of breakpoint creation. This consists of recording the file and
542 # line number in the breakpoint_file and breakpoint_line arrays. Also,
543 # if there is already a window associated with FILE, it is updated with
547 proc create_breakpoint
{bpnum
file line pc
} {
549 global breakpoint_file
550 global breakpoint_line
551 global pos_to_breakpoint
552 global pos_to_bpcount
556 # Record breakpoint locations
558 set breakpoint_file
($bpnum) $file
559 set breakpoint_line
($bpnum) $line
560 set pos_to_breakpoint
($file:$line) $bpnum
561 if {![info exists pos_to_bpcount
($file:$line)]} {
562 set pos_to_bpcount
($file:$line) 0
564 incr pos_to_bpcount
($file:$line)
565 set pos_to_breakpoint
($pc) $bpnum
566 if {![info exists pos_to_bpcount
($pc)]} {
567 set pos_to_bpcount
($pc) 0
569 incr pos_to_bpcount
($pc)
571 # If there's a window for this file, update it
573 if {[info exists wins
($file)]} {
574 insert_breakpoint_tag
$wins($file) $line
577 # If there's an assembly window, update that too
579 set win
[asm_win_name
$cfunc]
580 if {[winfo exists
$win]} {
581 insert_breakpoint_tag
$win [pc_to_line
$pclist($cfunc) $pc]
584 # Update the breakpoints window
586 add_breakpoint_frame
$bpnum
592 # delete_breakpoint (bpnum file line pc) - Delete breakpoint info from TK land
596 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
597 # land of breakpoint destruction. This consists of removing the file and
598 # line number from the breakpoint_file and breakpoint_line arrays. Also,
599 # if there is already a window associated with FILE, the tags are removed
603 proc delete_breakpoint
{bpnum
file line pc
} {
605 global breakpoint_file
606 global breakpoint_line
607 global pos_to_breakpoint
608 global pos_to_bpcount
611 # Save line number and file for later
613 set line
$breakpoint_line($bpnum)
615 set file $breakpoint_file($bpnum)
617 # Reset breakpoint annotation info
619 if {$pos_to_bpcount($file:$line) > 0} {
620 decr pos_to_bpcount
($file:$line)
622 if {$pos_to_bpcount($file:$line) == 0} {
623 catch "unset pos_to_breakpoint($file:$line)"
625 unset breakpoint_file
($bpnum)
626 unset breakpoint_line
($bpnum)
628 # If there's a window for this file, update it
630 if {[info exists wins
($file)]} {
631 delete_breakpoint_tag
$wins($file) $line
636 # If there's an assembly window, update that too
638 if {$pos_to_bpcount($pc) > 0} {
639 decr pos_to_bpcount
($pc)
641 if {$pos_to_bpcount($pc) == 0} {
642 catch "unset pos_to_breakpoint($pc)"
644 set win
[asm_win_name
$cfunc]
645 if {[winfo exists
$win]} {
646 delete_breakpoint_tag
$win [pc_to_line
$pclist($cfunc) $pc]
651 delete_breakpoint_frame
$bpnum
657 # enable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
661 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
662 # land of a breakpoint being enabled. This consists of unstippling the
663 # specified breakpoint indicator.
666 proc enable_breakpoint
{bpnum
file line pc
} {
671 if {[info exists wins
($file)]} {
672 $wins($file) tag configure
$line -fgstipple {}
675 # If there's an assembly window, update that too
677 set win
[asm_win_name
$cfunc]
678 if {[winfo exists
$win]} {
679 $win tag configure
[pc_to_line
$pclist($cfunc) $pc] -fgstipple {}
682 # If there's a breakpoint window, update that too
684 if {[winfo exists .breakpoints
]} {
685 set enabled
($bpnum) 1
692 # disable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
696 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
697 # land of a breakpoint being disabled. This consists of stippling the
698 # specified breakpoint indicator.
701 proc disable_breakpoint
{bpnum
file line pc
} {
706 if {[info exists wins
($file)]} {
707 $wins($file) tag configure
$line -fgstipple gray50
710 # If there's an assembly window, update that too
712 set win
[asm_win_name
$cfunc]
713 if {[winfo exists
$win]} {
714 $win tag configure
[pc_to_line
$pclist($cfunc) $pc] -fgstipple gray50
717 # If there's a breakpoint window, update that too
719 if {[winfo exists .breakpoints
]} {
720 set enabled
($bpnum) 0
727 # insert_breakpoint_tag (win line) - Insert a breakpoint tag in WIN.
731 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to insert a
732 # breakpoint tag into window WIN at line LINE.
735 proc insert_breakpoint_tag
{win line
} {
736 $win configure
-state normal
738 $win insert
$line.0 "B"
739 $win tag add margin
$line.0 $line.8
741 $win configure
-state disabled
747 # delete_breakpoint_tag (win line) - Remove a breakpoint tag from WIN.
751 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to remove a
752 # breakpoint tag from window WIN at line LINE.
755 proc delete_breakpoint_tag
{win line
} {
756 $win configure
-state normal
758 if {[string range
$win 0 3] == ".src"} then
{
759 $win insert
$line.0 "\xa4"
761 $win insert
$line.0 " "
763 $win tag add margin
$line.0 $line.8
764 $win configure
-state disabled
767 proc gdbtk_tcl_busy
{} {
768 if {[winfo exists .cmd
]} {
769 .cmd.
text configure
-state disabled
771 if {[winfo exists .src
]} {
772 .src.start configure
-state disabled
773 .src.stop configure
-state normal
774 .src.step configure
-state disabled
775 .src.next configure
-state disabled
776 .src.
continue configure
-state disabled
777 .src.finish configure
-state disabled
778 .src.up configure
-state disabled
779 .src.down configure
-state disabled
780 .src.bottom configure
-state disabled
782 if {[winfo exists .asm
]} {
783 .asm.stepi configure
-state disabled
784 .asm.nexti configure
-state disabled
785 .asm.
continue configure
-state disabled
786 .asm.finish configure
-state disabled
787 .asm.up configure
-state disabled
788 .asm.down configure
-state disabled
789 .asm.bottom configure
-state disabled
794 proc gdbtk_tcl_idle
{} {
795 if {[winfo exists .cmd
]} {
796 .cmd.
text configure
-state normal
798 if {[winfo exists .src
]} {
799 .src.start configure
-state normal
800 .src.stop configure
-state disabled
801 .src.step configure
-state normal
802 .src.next configure
-state normal
803 .src.
continue configure
-state normal
804 .src.finish configure
-state normal
805 .src.up configure
-state normal
806 .src.down configure
-state normal
807 .src.bottom configure
-state normal
809 if {[winfo exists .asm
]} {
810 .asm.stepi configure
-state normal
811 .asm.nexti configure
-state normal
812 .asm.
continue configure
-state normal
813 .asm.finish configure
-state normal
814 .asm.up configure
-state normal
815 .asm.down configure
-state normal
816 .asm.bottom configure
-state normal
824 # pc_to_line (pclist pc) - convert PC to a line number.
828 # Convert PC to a line number from PCLIST. If exact line isn't found,
829 # we return the first line that starts before PC.
831 proc pc_to_line
{pclist pc
} {
832 set line
[lsearch -exact $pclist $pc]
834 if {$line >= 1} { return $line }
837 foreach linepc
[lrange $pclist 1 end
] {
838 if {$pc < $linepc} { decr line
; return $line }
841 return [expr {$line - 1}]
847 # file popup menu - Define the file popup menu.
851 # This menu just contains a bunch of buttons that do various things to
852 # the line under the cursor.
856 # Edit - Run the editor (specified by the environment variable EDITOR) on
857 # this file, at the current line.
858 # Breakpoint - Set a breakpoint at the current line. This just shoves
859 # a `break' command at GDB with the appropriate file and line
860 # number. Eventually, GDB calls us back (at gdbtk_tcl_breakpoint)
861 # to notify us of where the breakpoint needs to show up.
864 menu .file_popup
-cursor hand2
-tearoff 0
865 .file_popup add command
-label "Not yet set" -state disabled
866 .file_popup add separator
867 .file_popup add command
-label "Edit" \
868 -command {exec $editor +$selected_line $selected_file &}
869 .file_popup add command
-label "Set breakpoint" \
870 -command {gdb_cmd
"break $selected_file:$selected_line"}
872 # Use this procedure to get the GDB core to execute the string `cmd'. This is
873 # a wrapper around gdb_cmd, which will catch errors, and send output to the
874 # command window. It will also cause all of the other windows to be updated.
876 proc interactive_cmd
{cmd
} {
877 catch {gdb_cmd
"$cmd"} result
878 .cmd.
text insert end
$result
886 # file popup menu - Define the file popup menu bindings.
890 # This defines the binding for the file popup menu. It simply
891 # unhighlights the line under the cursor.
894 bind .file_popup
<Any-ButtonRelease-1
> {
896 # Unhighlight the selected line
897 $selected_win tag delete breaktag
903 # listing_window_popup (win x y xrel yrel) - Handle popups for listing window
907 # This procedure is invoked by holding down button 2 (usually) in the
908 # listing window. The action taken depends upon where the button was
909 # pressed. If it was in the left margin (the breakpoint column), it
910 # sets or clears a breakpoint. In the main text area, it will pop up a
914 proc listing_window_popup
{win x y xrel yrel
} {
917 global file_to_debug_file
922 global pos_to_breakpoint
924 # Map TK window name back to file name.
926 set file $win_to_file($win)
928 set pos
[split [$win index
@$xrel,$yrel] .
]
930 # Record selected file and line for menu button actions
932 set selected_file
$file_to_debug_file($file)
933 set selected_line
[lindex $pos 0]
934 set selected_col
[lindex $pos 1]
935 set selected_win
$win
937 # Post the menu near the pointer, (and grab it)
939 .file_popup entryconfigure
0 -label "$selected_file:$selected_line"
941 tk_popup .file_popup
$x $y
947 # toggle_breakpoint (win x y xrel yrel) - Handle clicks on breakdots
951 # This procedure sets or clears breakpoints where the button clicked.
954 proc toggle_breakpoint
{win x y xrel yrel
} {
957 global file_to_debug_file
962 global pos_to_breakpoint
964 # Map TK window name back to file name.
966 set file $win_to_file($win)
968 set pos
[split [$win index
@$xrel,$yrel] .
]
970 # Record selected file and line
972 set selected_file
$file_to_debug_file($file)
973 set selected_line
[lindex $pos 0]
974 set selected_col
[lindex $pos 1]
975 set selected_win
$win
977 # If we're in the margin, then toggle the breakpoint
979 if {$selected_col < 8} { # this is alway true actually
980 set pos_break
$selected_file:$selected_line
981 set pos
$file:$selected_line
982 set tmp pos_to_breakpoint
($pos)
983 if {[info exists
$tmp]} {
985 gdb_cmd
"delete $bpnum"
987 gdb_cmd
"break $pos_break"
996 # asm_window_button_1 (win x y xrel yrel) - Handle button 1 in asm window
1000 # This procedure is invoked as a result of holding down button 1 in the
1001 # assembly window. The action taken depends upon where the button was
1002 # pressed. If it was in the left margin (the breakpoint column), it
1003 # sets or clears a breakpoint. In the main text area, it will pop up a
1007 proc asm_window_button_1
{win x y xrel yrel
} {
1010 global file_to_debug_file
1012 global selected_line
1013 global selected_file
1015 global pos_to_breakpoint
1019 set pos
[split [$win index
@$xrel,$yrel] .
]
1021 # Record selected file and line for menu button actions
1023 set selected_line
[lindex $pos 0]
1024 set selected_col
[lindex $pos 1]
1025 set selected_win
$win
1029 set pc
[lindex $pclist($cfunc) $selected_line]
1031 # If we're in the margin, then toggle the breakpoint
1033 if {$selected_col < 11} {
1034 set tmp pos_to_breakpoint
($pc)
1035 if {[info exists
$tmp]} {
1036 set bpnum
[set $tmp]
1037 gdb_cmd
"delete $bpnum"
1039 gdb_cmd
"break *$pc"
1044 # Post the menu near the pointer, (and grab it)
1046 # .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
1047 # .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
1054 # do_nothing - Does absolutely nothing.
1058 # This procedure does nothing. It is used as a placeholder to allow
1059 # the disabling of bindings that would normally be inherited from the
1060 # parent widget. I can't think of any other way to do this.
1063 proc do_nothing
{} {}
1068 # not_implemented_yet - warn that a feature is unavailable
1072 # This procedure warns that something doesn't actually work yet.
1075 proc not_implemented_yet
{message} {
1076 tk_dialog .unimpl
"gdb : unimpl" \
1077 "$message: not implemented in the interface yet" \
1084 # create_expr_window - Create expression display window
1088 # Create the expression display window.
1091 # Set delete_expr_num, and set -state of Delete button.
1092 proc expr_update_button
{num
} {
1093 global delete_expr_num
1094 set delete_expr_num
$num
1095 if {$num > 0} then
{
1100 .
expr.buts.delete configure
-state $state
1103 proc add_expr
{expr} {
1104 global expr_update_list
1112 checkbutton $e.updates.
$f -text "" -relief flat
\
1113 -variable expr_update_list
($expr_num)
1114 text $e.expressions.
$f -width 20 -height 1
1115 $e.expressions.
$f insert
0.0 $expr
1116 bind $e.expressions.
$f <1> "update_expr $expr_num"
1117 text $e.values.
$f -width 20 -height 1
1119 # Set up some bindings.
1120 foreach frame {updates expressions values
} {
1121 bind $e.
$frame.
$f <FocusIn
> "expr_update_button $expr_num"
1122 bind $e.
$frame.
$f <FocusOut
> "expr_update_button 0"
1125 update_expr
$expr_num
1127 pack $e.updates.
$f -side top
1128 pack $e.expressions.
$f -side top
-expand yes
-fill x
1129 pack $e.values.
$f -side top
-expand yes
-fill x
1132 proc delete_expr
{} {
1133 global delete_expr_num
1134 global expr_update_list
1136 if {$delete_expr_num > 0} then
{
1138 set f e
${delete_expr_num
}
1140 destroy $e.updates.
$f $e.expressions.
$f $e.values.
$f
1141 unset expr_update_list
($delete_expr_num)
1145 proc update_expr
{expr_num
} {
1146 global expr_update_list
1151 set expr [$e.expressions.
$f get
0.0 end
]
1152 $e.values.
$f delete
0.0 end
1153 if {! [catch {gdb_eval
$expr} val
]} {
1154 $e.values.
$f insert
0.0 $val
1156 # FIXME consider flashing widget here.
1160 proc update_exprs
{} {
1161 global expr_update_list
1163 foreach expr_num
[array names expr_update_list
] {
1164 if {$expr_update_list($expr_num)} {
1165 update_expr
$expr_num
1170 proc create_expr_window
{} {
1172 global delete_expr_num
1173 global expr_update_list
1175 if {[winfo exists .
expr]} {raise .
expr ; return}
1177 # All the state about individual expressions is stored in the
1178 # expression window widgets, so when it is deleted, the
1179 # previous values of the expression global variables become
1180 # invalid. Reset to a known initial state.
1182 set delete_expr_num
0
1183 catch {unset expr_update_list
}
1184 set expr_update_list
(0) 0
1187 wm title .
expr "GDB Expressions"
1188 wm iconname .
expr "Expressions"
1190 frame .
expr.entryframe
-borderwidth 2 -relief raised
1191 label .
expr.entryframe.entrylab
-text "Expression: "
1192 entry .
expr.entryframe.
entry -borderwidth 2 -relief sunken
1193 bind .
expr.entryframe.
entry <Return
> {
1194 add_expr
[.
expr.entryframe.
entry get
]
1195 .
expr.entryframe.
entry delete
0 end
1198 pack .
expr.entryframe.entrylab
-side left
1199 pack .
expr.entryframe.
entry -side left
-fill x
-expand yes
1201 frame .
expr.buts
-borderwidth 2 -relief raised
1203 button .
expr.buts.delete
-text Delete
-command delete_expr
\
1206 button .
expr.buts.
close -text Close
-command {destroy .
expr}
1207 button .
expr.buts.help
-text Help
-state disabled
1209 pack .
expr.buts.delete
-side left
1210 pack .
expr.buts.help .
expr.buts.
close -side right
1212 pack .
expr.buts
-side bottom
-fill x
1213 pack .
expr.entryframe
-side bottom
-fill x
1215 frame .
expr.exprs
-borderwidth 2 -relief raised
1217 # Use three subframes so columns will line up. Easier than
1218 # dealing with BLT for a table geometry manager. Someday Tk
1219 # will have one, use it then. FIXME this messes up keyboard
1221 frame .
expr.exprs.updates
-borderwidth 0 -relief flat
1222 frame .
expr.exprs.expressions
-borderwidth 0 -relief flat
1223 frame .
expr.exprs.values
-borderwidth 0 -relief flat
1225 label .
expr.exprs.updates.
label -text Update
1226 pack .
expr.exprs.updates.
label -side top
-anchor w
1227 label .
expr.exprs.expressions.
label -text Expression
1228 pack .
expr.exprs.expressions.
label -side top
-anchor w
1229 label .
expr.exprs.values.
label -text Value
1230 pack .
expr.exprs.values.
label -side top
-anchor w
1232 pack .
expr.exprs.updates
-side left
1233 pack .
expr.exprs.values .
expr.exprs.expressions
\
1234 -side right
-expand 1 -fill x
1236 pack .
expr.exprs
-side top
-fill both
-expand 1 -anchor w
1242 # display_expression (expression) - Display EXPRESSION in display window
1246 # Display EXPRESSION and its value in the expression display window.
1249 proc display_expression
{expression
} {
1252 add_expr
$expression
1258 # create_file_win (filename) - Create a win for FILENAME.
1262 # The new text widget.
1266 # This procedure creates a text widget for FILENAME. It returns the
1267 # newly created widget. First, a text widget is created, and given basic
1268 # configuration info. Second, all the bindings are setup. Third, the
1269 # file FILENAME is read into the text widget. Fourth, margins and line
1270 # numbers are added.
1273 proc create_file_win
{filename debug_file
} {
1274 global breakpoint_file
1275 global breakpoint_line
1277 global debug_interface
1279 # Replace all the dirty characters in $filename with clean ones, and generate
1280 # a unique name for the text widget.
1282 regsub -all {\.
} $filename {} temp
1283 set win .src.
text$temp
1285 # Open the file, and read it into the text widget
1287 if {[catch "open $filename" fh
]} {
1288 # File can't be read. Put error message into .src.nofile window and return.
1290 catch {destroy .src.nofile
}
1291 text .src.nofile
-height 25 -width 88 -relief sunken
\
1292 -borderwidth 2 -yscrollcommand ".src.scroll set" \
1293 -setgrid true
-cursor hand2
1294 .src.nofile insert
0.0 $fh
1295 .src.nofile configure
-state disabled
1296 bind .src.nofile
<1> do_nothing
1297 bind .src.nofile
<B1-Motion
> do_nothing
1301 # Actually create and do basic configuration on the text widget.
1303 text $win -height 25 -width 88 -relief sunken
-borderwidth 2 \
1304 -yscrollcommand ".src.scroll set" -setgrid true
-cursor hand2
1306 # Setup all the bindings
1308 bind $win <Enter
> {focus %W
}
1309 bind $win <1> do_nothing
1310 bind $win <B1-Motion
> do_nothing
1312 bind $win <Key-Alt_R
> do_nothing
1313 bind $win <Key-Alt_L
> do_nothing
1314 bind $win <Key-Prior
> "$win yview {@0,0 - 10 lines}"
1315 bind $win <Key-Next
> "$win yview {@0,0 + 10 lines}"
1316 bind $win <Key-Up
> "$win yview {@0,0 - 1 lines}"
1317 bind $win <Key-Down
> "$win yview {@0,0 + 1 lines}"
1318 bind $win <Key-Home
> {update_listing
[gdb_loc
]}
1319 bind $win <Key-End
> "$win see end"
1321 bind $win n
{interactive_cmd next
}
1322 bind $win s
{interactive_cmd step
}
1323 bind $win c
{interactive_cmd
continue}
1324 bind $win f
{interactive_cmd finish
}
1325 bind $win u
{interactive_cmd up
}
1326 bind $win d
{interactive_cmd down
}
1328 if $debug_interface {
1329 bind $win <Control-C
> {
1335 $win insert
0.0 [read $fh]
1338 # Add margins (for annotations) and a line number to each line (if requested)
1340 set numlines
[$win index end
]
1341 set numlines
[lindex [split $numlines .
] 0]
1342 if {$line_numbers} {
1343 for {set i
1} {$i <= $numlines} {incr i
} {
1344 $win insert
$i.0 [format " %4d " $i]
1345 $win tag add
source $i.8 "$i.0 lineend"
1348 for {set i
1} {$i <= $numlines} {incr i
} {
1349 $win insert
$i.0 " "
1350 $win tag add
source $i.8 "$i.0 lineend"
1356 foreach i
[gdb_sourcelines
$debug_file] {
1358 $win insert
$i.0 "\xa4"
1359 $win tag add margin
$i.0 $i.8
1362 # A debugging trick to highlight sensitive regions.
1363 if $debug_interface {
1364 $win tag
bind source <Enter
> {
1365 %W tag configure
source -background yellow
1367 $win tag
bind source <Leave
> {
1368 %W tag configure
source -background green
1370 $win tag
bind margin
<Enter
> {
1371 %W tag configure margin
-background red
1373 $win tag
bind margin
<Leave
> {
1374 %W tag configure margin
-background skyblue
1378 $win tag
bind margin
<1> {
1379 toggle_breakpoint
%W
%X
%Y
%x
%y
1382 $win tag
bind source <1> {
1383 %W mark
set anchor
"@%x,%y wordstart"
1384 set last
[%W index
"@%x,%y wordend"]
1385 %W tag remove sel
0.0 anchor
1386 %W tag remove sel
$last end
1387 %W tag add sel anchor
$last
1389 # $win tag bind source <Double-Button-1> {
1390 # %W mark set anchor "@%x,%y wordstart"
1391 # set last [%W index "@%x,%y wordend"]
1392 # %W tag remove sel 0.0 anchor
1393 # %W tag remove sel $last end
1394 # %W tag add sel anchor $last
1395 # echo "Selected [selection get]"
1397 $win tag
bind source <B1-Motion
> {
1398 %W tag remove sel
0.0 anchor
1399 %W tag remove sel
$last end
1400 %W tag add sel anchor
@%x
,%y
1402 $win tag
bind sel
<1> break
1403 $win tag
bind sel
<Double-Button-1
> {
1404 display_expression
[selection get
]
1407 $win tag
bind sel
<B1-Motion
> break
1410 $win tag
bind source <2> {
1411 listing_window_popup
%W
%X
%Y
%x
%y
1414 # Make these bindings do nothing on the text window -- they
1415 # are completely handled by the tag bindings above.
1417 bind $win <B1-Motion
> break
1418 bind $win <Double-Button-1
> break
1420 # Scan though the breakpoint data base and install any destined for this file
1422 foreach bpnum
[array names breakpoint_file
] {
1423 if {$breakpoint_file($bpnum) == $filename} {
1424 insert_breakpoint_tag
$win $breakpoint_line($bpnum)
1428 # Disable the text widget to prevent user modifications
1430 $win configure
-state disabled
1437 # create_asm_win (funcname pc) - Create an assembly win for FUNCNAME.
1441 # The new text widget.
1445 # This procedure creates a text widget for FUNCNAME. It returns the
1446 # newly created widget. First, a text widget is created, and given basic
1447 # configuration info. Second, all the bindings are setup. Third, the
1448 # function FUNCNAME is read into the text widget.
1451 proc create_asm_win
{funcname pc
} {
1452 global breakpoint_file
1453 global breakpoint_line
1455 global disassemble_with_source
1457 # Replace all the dirty characters in $filename with clean ones, and generate
1458 # a unique name for the text widget.
1460 set win
[asm_win_name
$funcname]
1462 # Actually create and do basic configuration on the text widget.
1464 text $win -height 25 -width 80 -relief sunken
-borderwidth 2 \
1465 -setgrid true
-cursor hand2
-yscrollcommand ".asm.scroll set"
1467 # Setup all the bindings
1469 bind $win <Enter
> {focus %W
}
1470 bind $win <1> {asm_window_button_1
%W
%X
%Y
%x
%y
; break}
1471 bind $win <B1-Motion
> break
1472 bind $win <Double-Button-1
> break
1474 bind $win <Key-Alt_R
> do_nothing
1475 bind $win <Key-Alt_L
> do_nothing
1477 bind $win n
{interactive_cmd nexti
}
1478 bind $win s
{interactive_cmd stepi
}
1479 bind $win c
{interactive_cmd
continue}
1480 bind $win f
{interactive_cmd finish
}
1481 bind $win u
{interactive_cmd up
}
1482 bind $win d
{interactive_cmd down
}
1484 # Disassemble the code, and read it into the new text widget
1486 $win insert end
[gdb_disassemble
$disassemble_with_source $pc]
1488 set numlines
[$win index end
]
1489 set numlines
[lindex [split $numlines .
] 0]
1492 # Delete the first and last lines, cuz these contain useless info
1494 # $win delete 1.0 2.0
1495 # $win delete {end - 1 lines} end
1498 # Add margins (for annotations) and note the PC for each line
1500 catch "unset pclist($funcname)"
1501 lappend pclist
($funcname) Unused
1502 for {set i
1} {$i <= $numlines} {incr i
} {
1503 scan [$win get
$i.0 "$i.0 lineend"] "%s " pc
1504 lappend pclist
($funcname) $pc
1505 $win insert
$i.0 " "
1508 # Scan though the breakpoint data base and install any destined for this file
1510 # foreach bpnum [array names breakpoint_file] {
1511 # if {$breakpoint_file($bpnum) == $filename} {
1512 # insert_breakpoint_tag $win $breakpoint_line($bpnum)
1516 # Disable the text widget to prevent user modifications
1518 $win configure
-state disabled
1525 # update_listing (linespec) - Update the listing window according to
1530 # This procedure is called from various places to update the listing
1531 # window based on LINESPEC. It is usually invoked with the result of
1534 # It will move the cursor, and scroll the text widget if necessary.
1535 # Also, it will switch to another text widget if necessary, and update
1536 # the label widget too.
1538 # LINESPEC is a list of the form:
1540 # { DEBUG_FILE FUNCNAME FILENAME LINE }, where:
1542 # DEBUG_FILE - is the abbreviated form of the file name. This is usually
1543 # the file name string given to the cc command. This is
1544 # primarily needed for breakpoint commands, and when an
1545 # abbreviated for of the filename is desired.
1546 # FUNCNAME - is the name of the function.
1547 # FILENAME - is the fully qualified (absolute) file name. It is usually
1548 # the same as $PWD/$DEBUG_FILE, where PWD is the working dir
1549 # at the time the cc command was given. This is used to
1550 # actually locate the file to be displayed.
1551 # LINE - The line number to be displayed.
1553 # Usually, this procedure will just move the cursor one line down to the
1554 # next line to be executed. However, if the cursor moves out of range
1555 # or into another file, it will scroll the text widget so that the line
1556 # of interest is in the middle of the viewable portion of the widget.
1559 proc update_listing
{linespec
} {
1562 global current_label
1564 global file_to_debug_file
1567 # Rip the linespec apart
1569 lassign
$linespec debug_file funcname
filename line
1571 # Sometimes there's no source file for this location
1573 if {$filename == ""} {set filename Blank
}
1575 # If we want to switch files, we need to unpack the current text widget, and
1576 # stick in the new one.
1578 if {$filename != $cfile} then
{
1579 pack forget
$wins($cfile)
1582 # Create a text widget for this file if necessary
1584 if {![info exists wins
($cfile)]} then
{
1585 set wins
($cfile) [create_file_win
$cfile $debug_file]
1586 if {$wins($cfile) != ".src.nofile"} {
1587 set win_to_file
($wins($cfile)) $cfile
1588 set file_to_debug_file
($cfile) $debug_file
1589 set pointers
($cfile) 1.1
1593 # Pack the text widget into the listing widget, and scroll to the right place
1595 pack $wins($cfile) -side left
-expand yes
-in .src.
info \
1596 -fill both
-after .src.scroll
1598 # Make the scrollbar point at the new text widget
1600 .src.scroll configure
-command "$wins($cfile) yview"
1602 # $wins($cfile) see "${line}.0 linestart"
1603 ensure_line_visible
$wins($cfile) $line
1606 # Update the label widget in case the filename or function name has changed
1608 if {$current_label != "$filename.$funcname"} then
{
1609 set tail
[expr [string last
/ $filename] + 1]
1610 set .src.
label "[string range $filename $tail end] : ${funcname}()"
1611 # .src.label configure -text "[string range $filename $tail end] : ${funcname}()"
1612 set current_label
$filename.
$funcname
1615 # Update the pointer, scrolling the text widget if necessary to keep the
1616 # pointer in an acceptable part of the screen.
1618 if {[info exists pointers
($cfile)]} then
{
1619 $wins($cfile) configure
-state normal
1620 set pointer_pos
$pointers($cfile)
1621 $wins($cfile) configure
-state normal
1622 $wins($cfile) delete
$pointer_pos "$pointer_pos + 2 char"
1623 $wins($cfile) insert
$pointer_pos " "
1625 set pointer_pos
[$wins($cfile) index
$line.1]
1626 set pointers
($cfile) $pointer_pos
1628 $wins($cfile) delete
$pointer_pos "$pointer_pos + 2 char"
1629 $wins($cfile) insert
$pointer_pos "->"
1630 ensure_line_visible
$wins($cfile) $line
1631 $wins($cfile) configure
-state disabled
1638 # create_asm_window - Open up the assembly window.
1642 # Create an assembly window if it doesn't exist.
1645 proc create_asm_window
{} {
1648 if {[winfo exists .asm
]} {raise .asm
; return}
1651 set win
[asm_win_name
$cfunc]
1653 build_framework .asm Assembly
"*NIL*"
1655 # First, delete all the old menu entries
1657 .asm.menubar.view.
menu delete
0 last
1659 .asm.
text configure
-yscrollcommand ".asm.scroll set"
1664 button .asm.stepi
-width 6 -text Stepi
\
1665 -command {interactive_cmd stepi
}
1666 button .asm.nexti
-width 6 -text Nexti
\
1667 -command {interactive_cmd nexti
}
1668 button .asm.
continue -width 6 -text Cont
\
1669 -command {interactive_cmd
continue}
1670 button .asm.finish
-width 6 -text Finish
\
1671 -command {interactive_cmd finish
}
1672 button .asm.up
-width 6 -text Up
-command {interactive_cmd up
}
1673 button .asm.down
-width 6 -text Down
\
1674 -command {interactive_cmd down
}
1675 button .asm.bottom
-width 6 -text Bottom
\
1676 -command {interactive_cmd
{frame 0}}
1678 pack .asm.stepi .asm.
continue .asm.up .asm.bottom
-side left
-padx 3 -pady 5 -in .asm.row1
1679 pack .asm.nexti .asm.finish .asm.down
-side left
-padx 3 -pady 5 -in .asm.row2
1681 pack .asm.row2 .asm.row1
-side bottom
-anchor w
-before .asm.
info
1685 update_assembly
[gdb_loc
]
1687 # We do this update_assembly to get the proper value of disassemble-from-exec.
1689 # exec file menu item
1690 .asm.menubar.view.
menu add
radiobutton -label "Exec file" \
1691 -variable disassemble-from-exec
-value 1
1692 # target memory menu item
1693 .asm.menubar.view.
menu add
radiobutton -label "Target memory" \
1694 -variable disassemble-from-exec
-value 0
1696 # Disassemble with source
1697 .asm.menubar.view.
menu add
checkbutton -label "Source" \
1698 -variable disassemble_with_source
-onvalue source \
1699 -offvalue nosource
-command {
1700 foreach asm
[info command .asm.func_
*] {
1704 update_assembly
[gdb_loc
]
1708 proc reg_config_menu
{} {
1709 catch {destroy .reg.config
}
1710 toplevel .reg.config
1711 wm geometry .reg.config
+300+300
1712 wm title .reg.config
"Register configuration"
1713 wm iconname .reg.config
"Reg config"
1714 set regnames
[gdb_regnames
]
1715 set num_regs
[llength $regnames]
1717 frame .reg.config.buts
1719 button .reg.config.done
-text " Done " -command "
1720 recompute_reg_display_list $num_regs
1722 update_registers all
1723 destroy .reg.config "
1725 button .reg.config.
update -text Update
-command "
1726 recompute_reg_display_list $num_regs
1728 update_registers all "
1730 pack .reg.config.buts
-side bottom
-fill x
1732 pack .reg.config.done
-side left
-fill x
-expand yes
-in .reg.config.buts
1733 pack .reg.config.
update -side right
-fill x
-expand yes
-in .reg.config.buts
1735 # Since there can be lots of registers, we build the window with no more than
1736 # 32 rows, and as many columns as needed.
1738 # First, figure out how many columns we need and create that many column frame
1741 set ncols
[expr ($num_regs + 31) / 32]
1743 for {set col
0} {$col < $ncols} {incr col
} {
1744 frame .reg.config.col
$col
1745 pack .reg.config.col
$col -side left
-anchor n
1748 # Now, create the checkbutton widgets and pack them in the appropriate columns
1752 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1753 set regname
[lindex $regnames $regnum]
1754 checkbutton .reg.config.col
$col.
$row -text $regname -pady 0 \
1755 -variable regena
($regnum) -relief flat
-anchor w
-bd 1
1757 pack .reg.config.col
$col.
$row -side top
-fill both
1770 # create_registers_window - Open up the register display window.
1774 # Create the register display window, with automatic updates.
1777 proc create_registers_window
{} {
1778 global reg_format_natural
1779 global reg_format_decimal
1780 global reg_format_hex
1781 global reg_format_octal
1782 global reg_format_raw
1783 global reg_format_binary
1784 global reg_format_unsigned
1786 # If we already have a register window, just use that one.
1788 if {[winfo exists .reg
]} {raise .reg
; return}
1790 # Create an initial register display list consisting of all registers
1794 build_framework .reg Registers
1796 # First, delete all the old menu entries
1798 .reg.menubar.view.
menu delete
0 last
1801 .reg.menubar.view.
menu add
checkbutton -label $reg_format_natural(label) \
1802 -variable reg_format_natural
(enable
) -onvalue on
-offvalue off
\
1803 -command {update_registers redraw
}
1806 .reg.menubar.view.
menu add
checkbutton -label $reg_format_decimal(label) \
1807 -variable reg_format_decimal
(enable
) -onvalue on
-offvalue off
\
1808 -command {update_registers redraw
}
1811 .reg.menubar.view.
menu add
checkbutton -label $reg_format_hex(label) \
1812 -variable reg_format_hex
(enable
) -onvalue on
-offvalue off
\
1813 -command {update_registers redraw
}
1816 .reg.menubar.view.
menu add
checkbutton -label $reg_format_octal(label) \
1817 -variable reg_format_octal
(enable
) -onvalue on
-offvalue off
\
1818 -command {update_registers redraw
}
1821 .reg.menubar.view.
menu add
checkbutton -label $reg_format_binary(label) \
1822 -variable reg_format_binary
(enable
) -onvalue on
-offvalue off
\
1823 -command {update_registers redraw
}
1825 # Unsigned menu item
1826 .reg.menubar.view.
menu add
checkbutton -label $reg_format_unsigned(label) \
1827 -variable reg_format_unsigned
(enable
) -onvalue on
-offvalue off
\
1828 -command {update_registers redraw
}
1831 .reg.menubar.view.
menu add
checkbutton -label $reg_format_raw(label) \
1832 -variable reg_format_raw
(enable
) -onvalue on
-offvalue off
\
1833 -command {update_registers redraw
}
1836 .reg.menubar.view.
menu add separator
1838 .reg.menubar.view.
menu add command
-label Config
\
1839 -command { reg_config_menu
}
1843 # Install the reg names
1846 update_registers all
1849 proc init_reg_info
{} {
1850 global reg_format_natural
1851 global reg_format_decimal
1852 global reg_format_hex
1853 global reg_format_octal
1854 global reg_format_raw
1855 global reg_format_binary
1856 global reg_format_unsigned
1860 if {![info exists reg_format_hex
]} {
1861 global reg_display_list
1862 global changed_reg_list
1865 set long_size
[lindex [gdb_cmd
{p sizeof
(long
)}] 2]
1866 set double_size
[lindex [gdb_cmd
{p sizeof
(double
)}] 2]
1868 # The natural format may print floats or doubles as floating point,
1869 # which typically takes more room that printing ints on the same
1870 # machine. We assume that if longs are 8 bytes that this is
1871 # probably a 64 bit machine. (FIXME)
1872 set reg_format_natural
(label) Natural
1873 set reg_format_natural
(enable
) on
1874 set reg_format_natural
(format) {}
1875 if {$long_size == 8} then
{
1876 set reg_format_natural
(width
) 25
1878 set reg_format_natural
(width
) 16
1881 set reg_format_decimal
(label) Decimal
1882 set reg_format_decimal
(enable
) off
1883 set reg_format_decimal
(format) d
1884 if {$long_size == 8} then
{
1885 set reg_format_decimal
(width
) 21
1887 set reg_format_decimal
(width
) 12
1890 set reg_format_hex
(label) Hex
1891 set reg_format_hex
(enable
) off
1892 set reg_format_hex
(format) x
1893 set reg_format_hex
(width
) [expr $long_size * 2 + 3]
1895 set reg_format_octal
(label) Octal
1896 set reg_format_octal
(enable
) off
1897 set reg_format_octal
(format) o
1898 set reg_format_octal
(width
) [expr $long_size * 8 / 3 + 3]
1900 set reg_format_raw
(label) Raw
1901 set reg_format_raw
(enable
) off
1902 set reg_format_raw
(format) r
1903 set reg_format_raw
(width
) [expr $double_size * 2 + 3]
1905 set reg_format_binary
(label) Binary
1906 set reg_format_binary
(enable
) off
1907 set reg_format_binary
(format) t
1908 set reg_format_binary
(width
) [expr $long_size * 8 + 1]
1910 set reg_format_unsigned
(label) Unsigned
1911 set reg_format_unsigned
(enable
) off
1912 set reg_format_unsigned
(format) u
1913 if {$long_size == 8} then
{
1914 set reg_format_unsigned
(width
) 21
1916 set reg_format_unsigned
(width
) 11
1919 set num_regs
[llength [gdb_regnames
]]
1920 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1921 set regena
($regnum) 1
1923 recompute_reg_display_list
$num_regs
1924 #set changed_reg_list $reg_display_list
1925 set changed_reg_list
{}
1929 # Convert regena into a list of the enabled $regnums
1931 proc recompute_reg_display_list
{num_regs
} {
1932 global reg_display_list
1936 catch {unset reg_display_list
}
1937 set reg_display_list
{}
1940 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1942 if {[set regena
($regnum)] != 0} {
1943 lappend reg_display_list
$regnum
1944 set regmap
($regnum) $line
1950 # Fill out the register window with the names of the regs specified in
1953 proc populate_reg_window
{} {
1954 global reg_format_natural
1955 global reg_format_decimal
1956 global reg_format_hex
1957 global reg_format_octal
1958 global reg_format_raw
1959 global reg_format_binary
1960 global reg_format_unsigned
1961 global max_regname_width
1962 global reg_display_list
1965 $win configure
-state normal
1967 # Clear the entire widget and insert a blank line at the top where
1968 # the column labels will appear.
1970 $win insert end
"\n"
1972 if {[llength $reg_display_list] > 0} {
1973 set regnames
[eval gdb_regnames
$reg_display_list]
1978 # Figure out the longest register name
1980 set max_regname_width
0
1982 foreach reg
$regnames {
1983 set len
[string length
$reg]
1984 if {$len > $max_regname_width} {set max_regname_width
$len}
1987 set width
[expr $max_regname_width + 15]
1989 set height
[expr [llength $regnames] + 1]
1991 if {$height > 60} {set height
60}
1993 $win configure
-height $height -width $width
1994 foreach reg
$regnames {
1995 $win insert end
[format "%-*s\n" $width ${reg
}]
1998 #Delete the blank line left at end by last insertion.
1999 if {[llength $regnames] > 0} {
2000 $win delete
{end
- 1 char
} end
2003 $win configure
-state disabled
2009 # update_registers - Update the registers window.
2013 # This procedure updates the registers window according to the value of
2017 proc update_registers
{which
} {
2018 global max_regname_width
2019 global reg_format_natural
2020 global reg_format_decimal
2021 global reg_format_hex
2022 global reg_format_octal
2023 global reg_format_binary
2024 global reg_format_unsigned
2025 global reg_format_raw
2026 global reg_display_list
2027 global changed_reg_list
2031 # margin is the column where we start printing values
2032 set margin
[expr $max_regname_width + 1]
2034 $win configure
-state normal
2036 if {$which == "all" ||
$which == "redraw"} {
2037 set display_list
$reg_display_list
2038 $win delete
1.0 1.end
2039 $win insert
1.0 [format "%*s" $max_regname_width " "]
2040 foreach format {natural decimal unsigned hex octal raw
binary } {
2042 set var reg_format_
$format$field
2043 if {[set $var] == "on"} {
2045 set var reg_format_
$format$field
2046 set label [set $var]
2048 set var reg_format_
$format$field
2049 set var
[format "%*s" [set $var] $label]
2050 $win insert
1.end
$var
2054 # Unhighlight the old values
2055 foreach regnum
$changed_reg_list {
2056 $win tag delete
$win.
$regnum
2058 set changed_reg_list
[eval gdb_changed_register_list
$reg_display_list]
2059 set display_list
$changed_reg_list
2061 foreach regnum
$display_list {
2062 set lineindex
$regmap($regnum)
2063 $win delete
$lineindex.
$margin "$lineindex.0 lineend"
2064 foreach format {natural decimal unsigned hex octal raw
binary } {
2066 set var reg_format_
$format$field
2067 if {[set $var] == "on"} {
2069 set var reg_format_
$format$field
2070 set regval
[gdb_fetch_registers
[set $var] $regnum]
2072 set var reg_format_
$format$field
2073 set regval
[format "%*s" [set $var] $regval]
2074 $win insert
$lineindex.end
$regval
2078 # Now, highlight the changed values of the interesting registers
2079 if {$which != "all"} {
2080 foreach regnum
$changed_reg_list {
2081 set lineindex
$regmap($regnum)
2082 $win tag add
$win.
$regnum $lineindex.0 "$lineindex.0 lineend"
2083 eval $win tag configure
$win.
$regnum $highlight
2086 set winwidth
$margin
2087 foreach format {natural decimal unsigned hex octal raw
binary} {
2089 set var reg_format_
$format$field
2090 if {[set $var] == "on"} {
2092 set var reg_format_
$format$field
2093 set winwidth
[expr $winwidth + [set $var]]
2096 $win configure
-width $winwidth
2097 $win configure
-state disabled
2103 # update_assembly - Update the assembly window.
2107 # This procedure updates the assembly window.
2110 proc update_assembly
{linespec
} {
2113 global current_label
2115 global file_to_debug_file
2116 global current_asm_label
2120 # Rip the linespec apart
2122 lassign
$linespec debug_file funcname
filename line pc
2124 set win
[asm_win_name
$cfunc]
2126 # Sometimes there's no source file for this location
2128 if {$filename == ""} {set filename Blank
}
2130 # If we want to switch funcs, we need to unpack the current text widget, and
2131 # stick in the new one.
2133 if {$funcname != $cfunc } {
2137 set win
[asm_win_name
$cfunc]
2139 # Create a text widget for this func if necessary
2141 if {![winfo exists
$win]} {
2142 create_asm_win
$cfunc $pc
2143 set asm_pointers
($cfunc) 1.1
2144 set current_asm_label NIL
2147 # Pack the text widget, and scroll to the right place
2150 pack $win -side left
-expand yes
-fill both
\
2152 .asm.scroll configure
-command "$win yview"
2153 set line
[pc_to_line
$pclist($cfunc) $pc]
2154 ensure_line_visible
$win $line
2158 # Update the label widget in case the filename or function name has changed
2160 if {$current_asm_label != "$pc $funcname"} then
{
2161 set .asm.
label "$pc $funcname"
2162 set current_asm_label
"$pc $funcname"
2165 # Update the pointer, scrolling the text widget if necessary to keep the
2166 # pointer in an acceptable part of the screen.
2168 if {[info exists asm_pointers
($cfunc)]} then
{
2169 $win configure
-state normal
2170 set pointer_pos
$asm_pointers($cfunc)
2171 $win configure
-state normal
2172 $win delete
$pointer_pos "$pointer_pos + 2 char"
2173 $win insert
$pointer_pos " "
2175 # Map the PC back to a line in the window
2177 set line
[pc_to_line
$pclist($cfunc) $pc]
2180 echo
"Can't find PC $pc"
2184 set pointer_pos
[$win index
$line.1]
2185 set asm_pointers
($cfunc) $pointer_pos
2187 $win delete
$pointer_pos "$pointer_pos + 2 char"
2188 $win insert
$pointer_pos "->"
2189 ensure_line_visible
$win $line
2190 $win configure
-state disabled
2197 # update_ptr - Update the listing window.
2201 # This routine will update the listing window using the result of
2205 proc update_ptr
{} {
2206 update_listing
[gdb_loc
]
2207 if {[winfo exists .asm
]} {
2208 update_assembly
[gdb_loc
]
2210 if {[winfo exists .reg
]} {
2211 update_registers changed
2213 if {[winfo exists .
expr]} {
2216 if {[winfo exists .autocmd
]} {
2221 # Make toplevel window disappear
2225 proc files_command
{} {
2226 toplevel .files_window
2228 wm minsize .files_window
1 1
2229 # wm overrideredirect .files_window true
2230 listbox .files_window.
list -width 30 -height 20 -setgrid true
\
2231 -yscrollcommand {.files_window.scroll
set} -relief sunken
\
2233 scrollbar .files_window.scroll
-orient vertical
\
2234 -command {.files_window.
list yview
} -relief sunken
2235 button .files_window.
close -text Close
-command {destroy .files_window
}
2236 .files_window.
list configure
-selectmode single
2238 # Get the file list from GDB, sort it, and insert into the widget.
2239 eval .files_window.
list insert
0 [lsort [gdb_listfiles
]]
2241 pack .files_window.
close -side bottom
-fill x
-expand no
-anchor s
2242 pack .files_window.scroll
-side right
-fill both
2243 pack .files_window.
list -side left
-fill both
-expand yes
2244 bind .files_window.
list <ButtonRelease-1
> {
2245 set file [%W get
[%W curselection
]]
2246 gdb_cmd
"list $file:1,0"
2247 update_listing
[gdb_loc
$file:1]
2248 destroy .files_window
2250 # We must execute the listbox binding first, because it
2251 # references the widget that will be destroyed by the widget
2252 # binding for Button-Release-1. Otherwise we try to use
2253 # .files_window.list after the .files_window is destroyed.
2254 bind_widget_after_class .files_window.
list
2257 button .files
-text Files
-command files_command
2259 proc apply_filespec
{label default command
} {
2260 set filename [FSBox
$label $default]
2261 if {$filename != ""} {
2262 if {[catch {gdb_cmd
"$command $filename"} retval
]} {
2263 tk_dialog .filespec_error
"gdb : $label error" \
2264 "Error in command \"$command $filename\"" error \
2273 proc run_editor
{editor
file} {
2274 # FIXME should use index of line in middle of window, not line at
2277 set lineNo
[lindex [split [$wins($file) index
@0,0] .
] 0]
2278 exec $editor +$lineNo $file
2281 # Setup command window
2282 proc build_framework
{win
{title GDBtk
} {label {}}} {
2286 wm title
${win
} $title
2287 wm minsize
${win
} 1 1
2289 frame ${win
}.menubar
2291 menubutton ${win
}.menubar.
file -padx 12 -text File
\
2292 -menu ${win
}.menubar.
file.
menu -underline 0
2294 menu ${win
}.menubar.
file.
menu
2295 ${win
}.menubar.
file.
menu add command
-label File...
\
2296 -command {apply_filespec File a.out
file}
2297 ${win
}.menubar.
file.
menu add command
-label Target...
\
2298 -command { not_implemented_yet
"target" }
2299 ${win
}.menubar.
file.
menu add command
-label Edit
\
2300 -command {run_editor
$editor $cfile}
2301 ${win
}.menubar.
file.
menu add separator
2302 ${win
}.menubar.
file.
menu add command
-label "Exec File..." \
2303 -command {apply_filespec
{Exec File
} a.out exec-file
}
2304 ${win
}.menubar.
file.
menu add command
-label "Symbol File..." \
2305 -command {apply_filespec
{Symbol File
} a.out symbol-file
}
2306 ${win
}.menubar.
file.
menu add command
-label "Add Symbol File..." \
2307 -command { not_implemented_yet
"menu item, add symbol file" }
2308 ${win
}.menubar.
file.
menu add command
-label "Core File..." \
2309 -command {apply_filespec
{Core File
} core core-file
}
2311 ${win
}.menubar.
file.
menu add separator
2312 ${win
}.menubar.
file.
menu add command
-label Close
\
2313 -command "destroy ${win}"
2314 ${win
}.menubar.
file.
menu add separator
2315 ${win
}.menubar.
file.
menu add command
-label Quit
\
2316 -command {interactive_cmd quit
}
2318 menubutton ${win
}.menubar.commands
-padx 12 -text Commands
\
2319 -menu ${win
}.menubar.commands.
menu -underline 0
2321 menu ${win
}.menubar.commands.
menu
2322 ${win
}.menubar.commands.
menu add command
-label Run
\
2323 -command {interactive_cmd run
}
2324 ${win
}.menubar.commands.
menu add command
-label Step
\
2325 -command {interactive_cmd step
}
2326 ${win
}.menubar.commands.
menu add command
-label Next
\
2327 -command {interactive_cmd next
}
2328 ${win
}.menubar.commands.
menu add command
-label Continue
\
2329 -command {interactive_cmd
continue}
2330 ${win
}.menubar.commands.
menu add separator
2331 ${win
}.menubar.commands.
menu add command
-label Stepi
\
2332 -command {interactive_cmd stepi
}
2333 ${win
}.menubar.commands.
menu add command
-label Nexti
\
2334 -command {interactive_cmd nexti
}
2336 menubutton ${win
}.menubar.view
-padx 12 -text Options
\
2337 -menu ${win
}.menubar.view.
menu -underline 0
2339 menu ${win
}.menubar.view.
menu
2340 ${win
}.menubar.view.
menu add command
-label Hex
\
2342 ${win
}.menubar.view.
menu add command
-label Decimal
\
2343 -command {echo Decimal
}
2344 ${win
}.menubar.view.
menu add command
-label Octal
\
2345 -command {echo Octal
}
2347 menubutton ${win
}.menubar.window
-padx 12 -text Window
\
2348 -menu ${win
}.menubar.window.
menu -underline 0
2350 menu ${win
}.menubar.window.
menu
2351 ${win
}.menubar.window.
menu add command
-label Command
\
2352 -command create_command_window
2353 ${win
}.menubar.window.
menu add separator
2354 ${win
}.menubar.window.
menu add command
-label Source
\
2355 -command create_source_window
2356 ${win
}.menubar.window.
menu add command
-label Assembly
\
2357 -command create_asm_window
2358 ${win
}.menubar.window.
menu add separator
2359 ${win
}.menubar.window.
menu add command
-label Registers
\
2360 -command create_registers_window
2361 ${win
}.menubar.window.
menu add command
-label Expressions
\
2362 -command create_expr_window
2363 ${win
}.menubar.window.
menu add command
-label "Auto Command" \
2364 -command create_autocmd_window
2365 ${win
}.menubar.window.
menu add command
-label Breakpoints
\
2366 -command create_breakpoints_window
2368 # ${win}.menubar.window.menu add separator
2369 # ${win}.menubar.window.menu add command -label Files \
2370 # -command { not_implemented_yet "files window" }
2372 menubutton ${win
}.menubar.help
-padx 12 -text Help
\
2373 -menu ${win
}.menubar.help.
menu -underline 0
2375 menu ${win
}.menubar.help.
menu
2376 ${win
}.menubar.help.
menu add command
-label "with GDBtk" \
2377 -command {echo
"with GDBtk"}
2378 ${win
}.menubar.help.
menu add command
-label "with this window" \
2379 -command {echo
"with this window"}
2380 ${win
}.menubar.help.
menu add command
-label "Report bug" \
2381 -command {exec send-pr
}
2383 pack ${win
}.menubar.
file \
2384 ${win
}.menubar.view
\
2385 ${win
}.menubar.window
-side left
2386 pack ${win
}.menubar.help
-side right
2389 text ${win
}.
text -height 25 -width 80 -relief sunken
-borderwidth 2 \
2390 -setgrid true
-cursor hand2
-yscrollcommand "${win}.scroll set"
2392 set ${win
}.
label $label
2393 label ${win
}.
label -textvariable ${win
}.
label -borderwidth 2 -relief sunken
2395 scrollbar ${win
}.scroll
-orient vertical
-command "${win}.text yview" \
2398 bind $win <Key-Alt_R
> do_nothing
2399 bind $win <Key-Alt_L
> do_nothing
2401 pack ${win
}.
label -side bottom
-fill x
-in ${win
}.
info
2402 pack ${win
}.scroll
-side right
-fill y
-in ${win
}.
info
2403 pack ${win
}.
text -side left
-expand yes
-fill both
-in ${win
}.
info
2405 pack ${win
}.menubar
-side top
-fill x
2406 pack ${win
}.
info -side top
-fill both
-expand yes
2409 proc create_source_window
{} {
2413 if {[winfo exists .src
]} {raise .src
; return}
2415 build_framework .src Source
"*No file*"
2417 # First, delete all the old view menu entries
2419 .src.menubar.view.
menu delete
0 last
2421 # Source file selection
2422 .src.menubar.view.
menu add command
-label "Select source file" \
2423 -command files_command
2425 # Line numbers enable/disable menu item
2426 .src.menubar.view.
menu add
checkbutton -variable line_numbers
\
2427 -label "Line numbers" -onvalue 1 -offvalue 0 -command {
2428 foreach source [array names wins
] {
2429 if {$source == "Blank"} continue
2430 destroy $wins($source)
2434 update_listing
[gdb_loc
]
2440 button .src.start
-width 6 -text Start
-command \
2441 {interactive_cmd
{break main
}
2442 interactive_cmd
{enable delete
$bpnum}
2443 interactive_cmd run
}
2444 button .src.stop
-width 6 -text Stop
-fg red
-activeforeground red
\
2445 -state disabled
-command gdb_stop
2446 button .src.step
-width 6 -text Step
\
2447 -command {interactive_cmd step
}
2448 button .src.next
-width 6 -text Next
\
2449 -command {interactive_cmd next
}
2450 button .src.
continue -width 6 -text Cont
\
2451 -command {interactive_cmd
continue}
2452 button .src.finish
-width 6 -text Finish
\
2453 -command {interactive_cmd finish
}
2454 button .src.up
-width 6 -text Up
\
2455 -command {interactive_cmd up
}
2456 button .src.down
-width 6 -text Down
\
2457 -command {interactive_cmd down
}
2458 button .src.bottom
-width 6 -text Bottom
\
2459 -command {interactive_cmd
{frame 0}}
2461 pack .src.start .src.step .src.
continue .src.up .src.bottom
\
2462 -side left
-padx 3 -pady 5 -in .src.row1
2463 pack .src.stop .src.next .src.finish .src.down
-side left
-padx 3 \
2464 -pady 5 -in .src.row2
2466 pack .src.row2 .src.row1
-side bottom
-anchor w
-before .src.
info
2468 $wins($cfile) insert
0.0 " This page intentionally left blank."
2469 $wins($cfile) configure
-width 88 -state disabled
\
2470 -yscrollcommand ".src.scroll set"
2473 proc update_autocmd
{} {
2474 global .autocmd.
label
2475 global accumulate_output
2477 catch {gdb_cmd
"${.autocmd.label}"} result
2478 if {!$accumulate_output} { .autocmd.
text delete
0.0 end
}
2479 .autocmd.
text insert end
$result
2480 .autocmd.
text see end
2483 proc create_autocmd_window
{} {
2484 global .autocmd.
label
2486 if {[winfo exists .autocmd
]} {raise .autocmd
; return}
2488 build_framework .autocmd
"Auto Command" ""
2490 # First, delete all the old view menu entries
2492 .autocmd.menubar.view.
menu delete
0 last
2494 # Accumulate output option
2496 .autocmd.menubar.view.
menu add
checkbutton \
2497 -variable accumulate_output
\
2498 -label "Accumulate output" -onvalue 1 -offvalue 0
2500 # Now, create entry widget with label
2502 frame .autocmd.entryframe
2504 entry .autocmd.
entry -borderwidth 2 -relief sunken
2505 bind .autocmd.
entry <Key-Return
> {
2506 set .autocmd.
label [.autocmd.
entry get
]
2507 .autocmd.
entry delete
0 end
2510 label .autocmd.entrylab
-text "Command: "
2512 pack .autocmd.entrylab
-in .autocmd.entryframe
-side left
2513 pack .autocmd.
entry -in .autocmd.entryframe
-side left
-fill x
-expand yes
2515 pack .autocmd.entryframe
-side bottom
-fill x
-before .autocmd.
info
2518 # Return the longest common prefix in SLIST. Can be empty string.
2520 proc find_lcp slist
{
2521 # Handle trivial cases where list is empty or length 1
2522 if {[llength $slist] <= 1} {return [lindex $slist 0]}
2524 set prefix
[lindex $slist 0]
2525 set prefixlast
[expr [string length
$prefix] - 1]
2527 foreach str
[lrange $slist 1 end
] {
2528 set test_str
[string range
$str 0 $prefixlast]
2529 while {[string compare
$test_str $prefix] != 0} {
2531 set prefix
[string range
$prefix 0 $prefixlast]
2532 set test_str
[string range
$str 0 $prefixlast]
2534 if {$prefixlast < 0} break
2539 # Look through COMPLETIONS to generate the suffix needed to do command
2540 # completion on CMD.
2542 proc find_completion
{cmd completions
} {
2543 # Get longest common prefix
2544 set lcp
[find_lcp
$completions]
2545 set cmd_len
[string length
$cmd]
2546 # Return suffix beyond end of cmd
2547 return [string range
$lcp $cmd_len end
]
2550 proc create_command_window
{} {
2556 if {[winfo exists .cmd
]} {raise .cmd
; return}
2558 build_framework .cmd Command
"* Command Buffer *"
2560 # Put focus on command area.
2565 gdb_cmd
{set language c
}
2566 gdb_cmd
{set height
0}
2567 gdb_cmd
{set width
0}
2569 bind .cmd.
text <Control-c
> gdb_stop
2571 # Tk uses the Motifism that Delete means delete forward. I
2572 # hate this, and I'm not gonna take it any more.
2573 set bsBinding
[bind Text
<BackSpace
>]
2574 bind .cmd.
text <Delete
> "delete_char %W ; $bsBinding; break"
2575 bind .cmd.
text <BackSpace
> {
2576 if {([%W cget
-state] == "disabled")} { break }
2579 bind .cmd.
text <Control-u
> {
2580 if {([%W cget
-state] == "disabled")} { break }
2584 bind .cmd.
text <Any-Key
> {
2585 if {([%W cget
-state] == "disabled")} { break }
2589 append command_line
%A
2592 bind .cmd.
text <Key-Return
> {
2593 if {([%W cget
-state] == "disabled")} { break }
2596 interactive_cmd
$command_line
2599 # catch "gdb_cmd [list $command_line]" result
2600 # %W insert end $result
2603 %W insert end
"$gdb_prompt"
2607 bind .cmd.
text <Button-2
> {
2608 %W insert end
[selection get
]
2610 append command_line
[selection get
]
2613 bind .cmd.
text <B2-Motion
> break
2614 bind .cmd.
text <ButtonRelease-2
> break
2615 bind .cmd.
text <Key-Tab
> {
2616 if {([%W cget
-state] == "disabled")} { break }
2617 set choices
[gdb_cmd
"complete $command_line"]
2618 set choices
[string trimright
$choices \n]
2619 set choices
[split $choices \n]
2621 # Just do completion if this is the first tab
2624 set completion
[find_completion
$command_line $choices]
2625 append command_line
$completion
2626 # Here is where the completion is actually done. If there
2627 # is one match, complete the command and print a space.
2628 # If two or more matches, complete the command and beep.
2629 # If no match, just beep.
2630 switch [llength $choices] {
2633 %W insert end
"$completion "
2634 append command_line
" "
2639 %W insert end
$completion
2645 # User hit another consecutive tab. List the choices.
2646 # Note that at this point, choices may contain commands
2647 # with spaces. We have to lop off everything before (and
2648 # including) the last space so that the completion list
2649 # only shows the possibilities for the last token.
2650 set choices
[lsort $choices]
2651 if {[regexp ".* " $command_line prefix
]} {
2652 regsub -all $prefix $choices {} choices
2654 %W insert end
"\n[join $choices { }]\n$gdb_prompt$command_line"
2661 # Trim one character off the command line. The argument is ignored.
2663 proc delete_char
{win
} {
2665 set tmp
[expr [string length
$command_line] - 2]
2666 set command_line
[string range
$command_line 0 $tmp]
2669 # FIXME: This should actually check that the first characters of the current
2670 # line match the gdb prompt, since the user can move the insertion point
2671 # anywhere. It should also check that the insertion point is in the last
2672 # line of the text widget.
2674 proc delete_line
{win
} {
2678 set tmp
[string length
$gdb_prompt]
2679 $win delete
"insert linestart + $tmp chars" "insert lineend"
2686 # simple file selector.
2688 # Mario Jorge Silva msilva@cs.Berkeley.EDU
2689 # University of California Berkeley Ph: +1(510)642-8248
2690 # Computer Science Division, 571 Evans Hall Fax: +1(510)642-5775
2694 # Copyright 1993 Regents of the University of California
2695 # Permission to use, copy, modify, and distribute this
2696 # software and its documentation for any purpose and without
2697 # fee is hereby granted, provided that this copyright
2698 # notice appears in all copies. The University of California
2699 # makes no representations about the suitability of this
2700 # software for any purpose. It is provided "as is" without
2701 # express or implied warranty.
2705 # names starting with "fileselect" are reserved by this module
2706 # no other names used.
2707 # Hack - FSBox is defined instead of fileselect for backwards compatibility
2710 # this is the proc that creates the file selector box
2711 # purpose - comment string
2712 # defaultName - initial value for name
2713 # cmd - command to eval upon OK
2714 # errorHandler - command to eval upon Cancel
2715 # If neither cmd or errorHandler are specified, the return value
2716 # of the FSBox procedure is the selected file name.
2718 proc FSBox
{{purpose
"Select file:"} {defaultName
""} {cmd
""} {errorHandler
2722 if {[Exwin_Toplevel
$w "Select File" FileSelect
]} {
2723 # path independent names for the widgets
2725 set fileselect
(list) $w.
file.sframe.
list
2726 set fileselect
(scroll
) $w.
file.sframe.scroll
2727 set fileselect
(direntry
) $w.
file.f1.direntry
2728 set fileselect
(entry) $w.
file.f2.
entry
2729 set fileselect
(ok
) $w.but.ok
2730 set fileselect
(cancel
) $w.but.cancel
2731 set fileselect
(msg
) $w.
label
2733 set fileselect
(result
) "" ;# value to return if no callback procedures
2736 Widget_Label
$w label {top fillx pady
10 padx
20} -anchor w
-width 24
2737 Widget_Frame
$w file Dialog
{left expand fill
} -bd 10
2739 Widget_Frame
$w.
file f1 Exmh
{top fillx
}
2740 Widget_Label
$w.
file.f1
label {left
} -text "Dir"
2741 Widget_Entry
$w.
file.f1 direntry
{right fillx expand
} -width 30
2743 Widget_Frame
$w.
file sframe
2745 scrollbar $w.
file.sframe.yscroll
-relief sunken
\
2746 -command [list $w.
file.sframe.
list yview
]
2747 listbox $w.
file.sframe.
list -relief sunken
\
2748 -yscroll [list $w.
file.sframe.yscroll
set] -setgrid 1
2749 pack append $w.
file.sframe
\
2750 $w.
file.sframe.yscroll
{right filly
} \
2751 $w.
file.sframe.
list {left expand fill
}
2753 Widget_Frame
$w.
file f2 Exmh
{top fillx
}
2754 Widget_Label
$w.
file.f2
label {left
} -text Name
2755 Widget_Entry
$w.
file.f2
entry {right fillx expand
}
2758 $w.but.quit configure
-text Cancel
\
2759 -command [list fileselect.cancel.cmd
$w]
2761 Widget_AddBut
$w.but ok OK
\
2762 [list fileselect.ok.cmd
$w $cmd $errorHandler] {left padx
1}
2764 Widget_AddBut
$w.but
list List
\
2765 [list fileselect.
list.cmd
$w] {left padx
1}
2766 Widget_CheckBut
$w.but listall
"List all" fileselect
(pattern
)
2767 $w.but.listall configure
-onvalue "{*,.*}" -offvalue "*" \
2768 -command {fileselect.
list.cmd
$fileselect(direntry
)}
2769 $w.but.listall deselect
2771 # Set up bindings for the browser.
2772 foreach ww
[list $w $fileselect(entry)] {
2773 bind $ww <Return
> [list $fileselect(ok
) invoke
]
2774 bind $ww <Control-c
> [list $fileselect(cancel
) invoke
]
2776 bind $fileselect(direntry
) <Return
> [list fileselect.
list.cmd
%W
]
2777 bind $fileselect(direntry
) <Tab
> [list fileselect.tab.dircmd
]
2778 bind $fileselect(entry) <Tab
> [list fileselect.tab.filecmd
]
2780 $fileselect(list) configure
-selectmode single
2782 bind $fileselect(list) <Button-1
> {
2783 # puts stderr "button 1 release"
2784 $fileselect(entry) delete
0 end
2785 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2788 bind $fileselect(list) <Key
> {
2789 $fileselect(entry) delete
0 end
2790 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2793 bind $fileselect(list) <Double-ButtonPress-1
> {
2794 # puts stderr "double button 1"
2795 $fileselect(entry) delete
0 end
2796 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2797 $fileselect(ok
) invoke
2800 bind $fileselect(list) <Return
> {
2801 $fileselect(entry) delete
0 end
2802 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2803 $fileselect(ok
) invoke
2806 set fileselect
(text) $purpose
2807 $fileselect(msg
) configure
-text $purpose
2808 $fileselect(entry) delete
0 end
2809 $fileselect(entry) insert
0 [file tail
$defaultName]
2811 if {[info exists fileselect
(lastDir
)] && ![string length
$defaultName]} {
2812 set dir
$fileselect(lastDir
)
2814 set dir
[file dirname
$defaultName]
2816 set fileselect
(pwd) [pwd]
2818 $fileselect(direntry
) delete
0 end
2819 $fileselect(direntry
) insert
0 [pwd]/
2821 $fileselect(list) delete
0 end
2822 $fileselect(list) insert
0 "Big directory:"
2823 $fileselect(list) insert
1 $dir
2824 $fileselect(list) insert
2 "Press Return for Listing"
2826 fileselect.
list.cmd
$fileselect(direntry
) startup
2828 # set kbd focus to entry widget
2830 # Exwin_ToplevelFocus $w $fileselect(entry)
2832 # Wait for button hits if no callbacks are defined
2834 if {"$cmd" == "" && "$errorHandler" == ""} {
2835 # wait for the box to be destroyed
2838 tkwait variable fileselect
(result
)
2841 set path
$fileselect(result
)
2842 set fileselect
(lastDir
) [pwd]
2843 fileselect.
cd $fileselect(pwd)
2844 return [string trimright
[string trim
$path] /]
2846 fileselect.
cd $fileselect(pwd)
2850 proc fileselect.
cd { dir
} {
2852 if {[catch {cd $dir} err
]} {
2857 # auxiliary button procedures
2859 proc fileselect.yck
{ {tag
{}} } {
2861 $fileselect(msg
) configure
-text "Yck! $tag"
2864 proc fileselect.ok
{} {
2866 $fileselect(msg
) configure
-text $fileselect(text)
2869 proc fileselect.cancel.cmd
{w
} {
2871 set fileselect
(result
) {}
2875 proc fileselect.
list.cmd
{w
{state normal
}} {
2877 set seldir
[$fileselect(direntry
) get
]
2878 if {[catch {glob $seldir} dir
]} {
2879 fileselect.yck
"glob failed"
2882 if {[llength $dir] > 1} {
2883 set dir
[file dirname
$seldir]
2884 set pat
[file tail
$seldir]
2886 set pat
$fileselect(pattern
)
2890 if {[file isdirectory
$dir]} {
2891 fileselect.getfiles
$dir $pat $state
2892 focus $fileselect(entry)
2894 fileselect.yck
"not a dir"
2898 proc fileselect.ok.cmd
{w cmd errorHandler
} {
2900 set selname
[$fileselect(entry) get
]
2901 set seldir
[$fileselect(direntry
) get
]
2903 if {[string match
/* $selname]} {
2904 set selected
$selname
2906 if {[string match ~
* $selname]} {
2907 set selected
$selname
2909 set selected
$seldir/$selname
2913 # some nasty file names may cause "file isdirectory" to return an error
2914 if {[catch {file isdirectory
$selected} isdir
]} {
2915 fileselect.yck
"isdirectory failed"
2918 if {[catch {glob $selected} globlist
]} {
2919 if {![file isdirectory
[file dirname
$selected]]} {
2920 fileselect.yck
"bad pathname"
2923 set globlist
$selected
2928 if {[llength $globlist] > 1} {
2929 set dir
[file dirname
$selected]
2930 set pat
[file tail
$selected]
2931 fileselect.getfiles
$dir $pat
2934 set selected
$globlist
2936 if {[file isdirectory
$selected]} {
2937 fileselect.getfiles
$selected $fileselect(pattern
)
2938 $fileselect(entry) delete
0 end
2945 set fileselect
(result
) $selected
2950 proc fileselect.getfiles
{ dir
{pat
*} {state normal
} } {
2952 $fileselect(msg
) configure
-text Listing...
2955 set currentDir
[pwd]
2957 if {[catch {set files
[lsort [glob -nocomplain $pat]]} err
]} {
2958 $fileselect(msg
) configure
-text $err
2959 $fileselect(list) delete
0 end
2965 # Normal case - show current directory
2966 $fileselect(direntry
) delete
0 end
2967 $fileselect(direntry
) insert
0 [pwd]/
2970 # Directory already OK (tab related)
2973 # Changing directory (tab related)
2974 fileselect.
cd $currentDir
2977 # Avoid listing huge directories upon startup.
2978 $fileselect(direntry
) delete
0 end
2979 $fileselect(direntry
) insert
0 [pwd]/
2980 if {[llength $files] > 32} {
2987 # build a reordered list of the files: directories are displayed first
2988 # and marked with a trailing "/"
2989 if {[string compare
$dir /]} {
2990 fileselect.putfiles
$files [expr {($pat == "*") ?
1 : 0}]
2992 fileselect.putfiles
$files
2997 proc fileselect.putfiles
{files
{dotdot
0} } {
3000 $fileselect(list) delete
0 end
3002 $fileselect(list) insert end
"../"
3005 if {[file isdirectory
$i]} {
3006 $fileselect(list) insert end
$i/
3008 $fileselect(list) insert end
$i
3013 proc FileExistsDialog
{ name
} {
3016 set fileExists
(ok
) 0
3018 message $w.msg
-aspect 1000
3019 pack $w.msg
-side top
-fill both
-padx 20 -pady 20
3020 $w.but.quit config
-text Cancel
-command {FileExistsCancel
}
3021 button $w.but.ok
-text OK
-command {FileExistsOK
}
3022 pack $w.but.ok
-side left
3023 bind $w.msg
<Return
> {FileExistsOK
}
3025 $w.msg config
-text "Warning: file exists
3027 OK to overwrite it?"
3029 set fileExists
(focus) [focus]
3032 tkwait variable fileExists
(ok
)
3035 return $fileExists(ok
)
3038 proc FileExistsCancel
{} {
3040 set fileExists
(ok
) 0
3043 proc FileExistsOK
{} {
3045 set fileExists
(ok
) 1
3048 proc fileselect.getfiledir
{ dir
{basedir
[pwd]} } {
3051 set path
[$fileselect(direntry
) get
]
3055 if {[string index
$path 0] == "~"} {
3059 set path
[$fileselect(entry) get
]
3061 if {[catch {set listFile
[glob -nocomplain $path*]}]} {
3064 foreach el
$listFile {
3066 if {[file isdirectory
$el]} {
3067 lappend returnList
[file tail
$el]
3069 } elseif
{![file isdirectory
$el]} {
3070 lappend returnList
[file tail
$el]
3077 proc fileselect.gethead
{ list } {
3080 for {set i
0} {[string length
[lindex $list 0]] > $i}\
3081 {incr i
; set returnHead
$returnHead$thisChar} {
3082 set thisChar
[string index
[lindex $list 0] $i]
3084 if {[string length
$el] < $i} {
3087 if {$thisChar != [string index
$el $i]} {
3095 # FIXME this function is a crock. Can write tilde expanding function
3096 # in terms of glob and quote_glob; do so.
3097 proc fileselect.expand.tilde
{ } {
3100 set entry [$fileselect(direntry
) get
]
3101 set dir
[string range
$entry 1 [string length
$entry]]
3109 ## look in /etc/passwd
3110 if {[file exists
/etc
/passwd
]} {
3111 if {[catch {set users
[exec cat
/etc
/passwd | sed s
/:.
*//]} err
]} {
3112 puts "Error\#1 $err"
3115 set list [split $users "\n"]
3117 if {[lsearch -exact $list "+"] != -1} {
3118 if {[catch {set users
[exec ypcat passwd | sed s
/:.
*//]} err
]} {
3119 puts "Error\#2 $err"
3122 set list [concat $list [split $users "\n"]]
3124 $fileselect(list) delete
0 end
3126 if {[string match
$dir* $el]} {
3127 lappend listmatch
$el
3128 $fileselect(list) insert end
$el
3131 set addings
[fileselect.gethead
$listmatch]
3132 if {$addings == ""} {
3135 $fileselect(direntry
) delete
0 end
3136 if {[llength $listmatch] == 1} {
3137 $fileselect(direntry
) insert
0 [file dirname ~
$addings/]
3138 fileselect.getfiles
[$fileselect(direntry
) get
]
3140 $fileselect(direntry
) insert
0 ~
$addings
3144 proc fileselect.tab.dircmd
{ } {
3147 set dir
[$fileselect(direntry
) get
]
3149 $fileselect(direntry
) delete
0 end
3150 $fileselect(direntry
) insert
0 [pwd]
3151 if {[string compare
[pwd] "/"]} {
3152 $fileselect(direntry
) insert end
/
3156 if {[catch {set tmp
[file isdirectory
[file dirname
$dir]]}]} {
3157 if {[string index
$dir 0] == "~"} {
3158 fileselect.expand.tilde
3165 set dirFile
[fileselect.getfiledir
1 $dir]
3166 if {![llength $dirFile]} {
3169 if {[llength $dirFile] == 1} {
3170 $fileselect(direntry
) delete
0 end
3171 $fileselect(direntry
) insert
0 [file dirname
$dir]
3172 if {[string compare
[file dirname
$dir] /]} {
3173 $fileselect(direntry
) insert end
/[lindex $dirFile 0]/
3175 $fileselect(direntry
) insert end
[lindex $dirFile 0]/
3177 fileselect.getfiles
[$fileselect(direntry
) get
] \
3178 "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
3181 set headFile
[fileselect.gethead
$dirFile]
3182 $fileselect(direntry
) delete
0 end
3183 $fileselect(direntry
) insert
0 [file dirname
$dir]
3184 if {[string compare
[file dirname
$dir] /]} {
3185 $fileselect(direntry
) insert end
/$headFile
3187 $fileselect(direntry
) insert end
$headFile
3189 if {$headFile == "" && [file isdirectory
$dir]} {
3190 fileselect.getfiles
$dir\
3191 "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
3193 fileselect.getfiles
[file dirname
$dir]\
3194 "[file tail [$fileselect(direntry) get]]*" newdir
3198 proc fileselect.tab.filecmd
{ } {
3201 set dir
[$fileselect(direntry
) get
]
3205 if {![file isdirectory
$dir]} {
3206 error "dir $dir doesn't exist"
3208 set listFile
[fileselect.getfiledir
0 $dir]
3210 if {![llength $listFile]} {
3213 if {[llength $listFile] == 1} {
3214 $fileselect(entry) delete
0 end
3215 $fileselect(entry) insert
0 [lindex $listFile 0]
3218 set headFile
[fileselect.gethead
$listFile]
3219 $fileselect(entry) delete
0 end
3220 $fileselect(entry) insert
0 $headFile
3221 fileselect.getfiles
$dir "[$fileselect(entry) get]$fileselect(pattern)" opt
3224 proc Exwin_Toplevel
{ path name
{class Dialog
} {dismiss yes
}} {
3226 if {[catch {wm state
$path} state
]} {
3227 set t
[Widget_Toplevel
$path $name $class]
3228 if {![info exists exwin
(toplevels
)]} {
3229 set exwin
(toplevels
) [option get . exwinPaths
{}]
3231 set ix
[lsearch $exwin(toplevels
) $t]
3233 lappend exwin
(toplevels
) $t
3235 if {$dismiss == "yes"} {
3236 set f
[Widget_Frame
$t but Menubar
{top fill
}]
3237 Widget_AddBut
$f quit
"Dismiss" [list Exwin_Dismiss
$path]
3241 if {$state != "normal"} {
3243 wm geometry
$path $exwin(geometry
,$path)
3244 # Exmh_Debug Exwin_Toplevel $path $exwin(geometry,$path)
3254 proc Exwin_Dismiss
{ path
{geo ok
} } {
3258 set exwin
(geometry
,$path) [wm geometry
$path]
3261 set exwin
(geometry
,$path) [string trimleft
[wm geometry
$path] 0123456789x
]
3264 catch {unset exwin
(geometry
,$path)}
3270 proc Widget_Toplevel
{ path name
{class Dialog
} {x
{}} {y
{}} } {
3271 set self
[toplevel $path -class $class]
3272 set usergeo
[option get
$path position Position
]
3273 if {$usergeo != {}} {
3274 if {[catch {wm geometry
$self $usergeo} err
]} {
3275 # Exmh_Debug Widget_Toplevel $self $usergeo => $err
3278 if {($x != {}) && ($y != {})} {
3279 # Exmh_Debug Event position $self +$x+$y
3280 wm geometry
$self +$x+$y
3283 wm title
$self $name
3288 proc Widget_Frame
{par child
{class GDB
} {where
{top expand fill
}} args
} {
3292 set self
$par.
$child
3294 eval {frame $self -class $class} $args
3295 pack append $par $self $where
3299 proc Widget_AddBut
{par but txt cmd
{where
{right padx
1}} } {
3300 # Create a Packed button. Return the button pathname
3301 set cmd2
[list button $par.
$but -text $txt -command $cmd]
3302 if {[catch $cmd2 t
]} {
3303 puts stderr
"Widget_AddBut (warning) $t"
3304 eval $cmd2 {-font fixed
}
3306 pack append $par $par.
$but $where
3310 proc Widget_CheckBut
{par but txt var
{where
{right padx
1}} } {
3311 # Create a check button. Return the button pathname
3312 set cmd
[list checkbutton $par.
$but -text $txt -variable $var]
3313 if {[catch $cmd t
]} {
3314 puts stderr
"Widget_CheckBut (warning) $t"
3315 eval $cmd {-font fixed
}
3317 pack append $par $par.
$but $where
3321 proc Widget_Label
{ frame {name
label} {where
{left fill
}} args
} {
3322 set cmd
[list label $frame.
$name ]
3323 if {[catch [concat $cmd $args] t
]} {
3324 puts stderr
"Widget_Label (warning) $t"
3325 eval $cmd $args {-font fixed
}
3327 pack append $frame $frame.
$name $where
3331 proc Widget_Entry
{ frame {name
entry} {where
{left fill
}} args
} {
3332 set cmd
[list entry $frame.
$name ]
3333 if {[catch [concat $cmd $args] t
]} {
3334 puts stderr
"Widget_Entry (warning) $t"
3335 eval $cmd $args {-font fixed
}
3337 pack append $frame $frame.
$name $where
3341 # End of fileselect.tcl.
3344 # Create a copyright window and center it on the screen. Arrange for
3345 # it to disappear when the user clicks it, or after a suitable period
3348 proc create_copyright_window
{} {
3350 message .c.m
-text [gdb_cmd
{show version
}] -aspect 500 -relief raised
3353 bind .c.m
<1> {destroy .c
}
3354 bind .c
<Leave
> {destroy .c
}
3355 # "suitable period" currently means "30 seconds".
3357 if {[winfo exists .c
]} then
{
3366 # Begin support primarily for debugging the tcl/tk portion of gdbtk. You can
3367 # start gdbtk, and then issue the command "tk tclsh" and a window will pop up
3368 # giving you direct access to the tcl interpreter. With this, it is very easy
3369 # to examine the values of global variables, directly invoke routines that are
3370 # part of the gdbtk interface, replace existing proc's with new ones, etc.
3371 # This code was inspired from example 11-3 in Brent Welch's "Practical
3372 # Programming in Tcl and Tk"
3374 set tcl_prompt
"tcl> "
3376 # Get the current command that user has typed, from cmdstart to end of text
3377 # widget. Evaluate it, insert result back into text widget, issue a new
3378 # prompt, update text widget and update command start mark.
3380 proc evaluate_tcl_command
{ twidget
} {
3383 set command
[$twidget get cmdstart end
]
3384 if [info complete
$command] {
3385 set err
[catch {uplevel #0 $command} result]
3386 $twidget insert insert
\n$result\n
3387 $twidget insert insert
$tcl_prompt
3389 $twidget mark
set cmdstart insert
3394 # Create the evaluation window and set up the keybindings to evaluate the
3395 # last single line entered by the user. FIXME: allow multiple lines?
3400 # If another evaluation window already exists, just bring it to the front.
3401 if {[winfo exists .
eval]} {raise .
eval ; return}
3403 # Create top level frame with scrollbar and text widget.
3405 wm title .
eval "Tcl Evaluation"
3406 wm iconname .
eval "Tcl"
3407 text .
eval.
text -width 80 -height 20 -setgrid true
-cursor hand2
\
3408 -yscrollcommand {.
eval.scroll
set}
3409 scrollbar .
eval.scroll
-command {.
eval.
text yview
}
3410 pack .
eval.scroll
-side right
-fill y
3411 pack .
eval.
text -side left
-fill both
-expand true
3413 # Insert the tcl_prompt and initialize the cmdstart mark
3414 .
eval.
text insert insert
$tcl_prompt
3415 .
eval.
text mark
set cmdstart insert
3416 .
eval.
text mark gravity cmdstart left
3418 # Make this window the current one for input.
3421 # Keybindings that limit input and evaluate things
3422 bind .
eval.
text <Return
> { evaluate_tcl_command .
eval.
text ; break }
3423 bind .
eval.
text <BackSpace
> {
3424 if [%W compare insert
> cmdstart
] {
3425 %W delete
{insert
- 1 char
} insert
3431 bind .
eval.
text <Any-Key
> {
3432 if [%W compare insert
< cmdstart
] {
3433 %W mark
set insert end
3436 bind .
eval.
text <Control-u
> {
3437 %W delete cmdstart
"insert lineend"
3440 bindtags .
eval.
text {.
eval.
text Text all
}
3443 # This proc is executed just prior to falling into the Tk main event loop.
3444 proc gdbtk_tcl_preloop
{} {
3446 .cmd.
text insert end
"$gdb_prompt"
3451 # FIXME need to handle mono here. In Tk4 that is more complicated.
3452 set highlight
"-background red2 -borderwidth 2 -relief sunken"
3454 # Setup the initial windows
3455 create_source_window
3456 create_command_window
3458 # Make this last so user actually sees it.
3459 create_copyright_window
3463 if {[file exists ~
/.gdbtkinit
]} {