set line_numbers 1
set breakpoint_file(-1) {[garbage]}
set disassemble_with_source nosource
-set expr_update_list(0) 0
+set gdb_prompt "(gdb) "
+
+# Hint: The following can be toggled from a tclsh window after
+# using the gdbtk "tk tclsh" command to open the window.
+set debug_interface 0
#option add *Foreground Black
#option add *Background White
#
# Center a window on the screen.
#
-proc center_window toplevel {
+proc center_window {toplevel} {
# Withdraw and update, to ensure geometry computations are finished.
wm withdraw $toplevel
update idletasks
bindtags $widget $newList
}
+#
+# Make sure line number $LINE is visible in the text widget. But be
+# more clever than the "see" command: if LINE is not currently
+# displayed, arrange for LINE to be centered. There are cases in
+# which this does not work, so as a last resort we revert to "see".
+#
+# This is inefficient, but probably not slow enough to actually
+# notice.
+#
+proc ensure_line_visible {text line} {
+ set pixHeight [winfo height $text]
+ # Compute height of widget in lines. This fails if a line is wider
+ # than the screen. FIXME.
+ set topLine [lindex [split [$text index @0,0] .] 0]
+ set botLine [lindex [split [$text index @0,${pixHeight}] .] 0]
+
+ if {$line > $topLine && $line < $botLine} then {
+ # Onscreen, and not on the very edge.
+ return
+ }
+
+ set newTop [expr {$line - ($botLine - $topLine)}]
+ if {$newTop < 0} then {
+ set newTop 0
+ }
+ $text yview moveto $newTop
+
+ # In case the above failed.
+ $text see ${line}.0
+}
+
if {[info exists env(EDITOR)]} then {
set editor $env(EDITOR)
} else {
${action}_breakpoint $bpnum $file $line $pc
}
+#
+# GDB Callback:
+#
+# gdbtk_tcl_readline_begin (message) - Notify Tk to open an interaction
+# window and start gathering user input
+#
+# Description:
+#
+# GDB calls this to notify TK that it needs to open an interaction
+# window, displaying the given message, and be prepared to accept
+# calls to gdbtk_tcl_readline to gather user input.
+
+proc gdbtk_tcl_readline_begin {message} {
+ global readline_text
+
+ # If another readline window already exists, just bring it to the front.
+ if {[winfo exists .rl]} {raise .rl ; return}
+
+ # Create top level frame with scrollbar and text widget.
+ toplevel .rl
+ wm title .rl "Interaction Window"
+ wm iconname .rl "Input"
+ message .rl.msg -text $message -aspect 7500 -justify left
+ text .rl.text -width 80 -height 20 -setgrid true -cursor hand2 \
+ -yscrollcommand {.rl.scroll set}
+ scrollbar .rl.scroll -command {.rl.text yview}
+ pack .rl.msg -side top -fill x
+ pack .rl.scroll -side right -fill y
+ pack .rl.text -side left -fill both -expand true
+
+ # When the user presses return, get the text from the command start mark to the
+ # current insert point, stash it in the readline text variable, and update the
+ # command start mark to the current insert point
+ bind .rl.text <Return> {
+ set readline_text [.rl.text get cmdstart {end - 1 char}]
+ .rl.text mark set cmdstart insert
+ }
+ bind .rl.text <BackSpace> {
+ if [%W compare insert > cmdstart] {
+ %W delete {insert - 1 char} insert
+ } else {
+ bell
+ }
+ break
+ }
+ bind .rl.text <Any-Key> {
+ if [%W compare insert < cmdstart] {
+ %W mark set insert end
+ }
+ }
+ bind .rl.text <Control-u> {
+ %W delete cmdstart "insert lineend"
+ %W see insert
+ }
+ bindtags .rl.text {.rl.text Text all}
+}
+
+#
+# GDB Callback:
+#
+# gdbtk_tcl_readline (prompt) - Get one user input line
+#
+# Description:
+#
+# GDB calls this to get one line of input from the user interaction
+# window, using "prompt" as the command line prompt.
+
+proc gdbtk_tcl_readline {prompt} {
+ global readline_text
+
+ .rl.text insert end $prompt
+ .rl.text mark set cmdstart insert
+ .rl.text mark gravity cmdstart left
+ .rl.text see insert
+
+ # Make this window the current one for input.
+ focus .rl.text
+ grab .rl
+ tkwait variable readline_text
+ grab release .rl
+ return $readline_text
+}
+
+#
+# GDB Callback:
+#
+# gdbtk_tcl_readline_end - Terminate a user interaction
+#
+# Description:
+#
+# GDB calls this when it is done getting interactive user input.
+# Destroy the interaction window.
+
+proc gdbtk_tcl_readline_end {} {
+ if {[winfo exists .rl]} { destroy .rl }
+}
+
proc create_breakpoints_window {} {
global bpframe_lasty
# Create a frame for bpnum in the .breakpoints canvas
-proc add_breakpoint_frame bpnum {
+proc add_breakpoint_frame {bpnum} {
global bpframe_lasty
global enabled
global disposition
# Delete a breakpoint frame
-proc delete_breakpoint_frame bpnum {
+proc delete_breakpoint_frame {bpnum} {
global bpframe_lasty
if {![winfo exists .breakpoints]} return
$win configure -state normal
$win delete $line.0
$win insert $line.0 "B"
- $win tag add $line $line.0
- $win tag add delete $line.0 "$line.0 lineend"
- $win tag add margin $line.0 "$line.0 lineend"
+ $win tag add margin $line.0 $line.8
$win configure -state disabled
}
} else {
$win insert $line.0 " "
}
- $win tag delete $line
- $win tag add delete $line.0 "$line.0 lineend"
- $win tag add margin $line.0 "$line.0 lineend"
+ $win tag add margin $line.0 $line.8
$win configure -state disabled
}
proc gdbtk_tcl_busy {} {
+ if {[winfo exists .cmd]} {
+ .cmd.text configure -state disabled
+ }
if {[winfo exists .src]} {
.src.start configure -state disabled
.src.stop configure -state normal
}
proc gdbtk_tcl_idle {} {
+ if {[winfo exists .cmd]} {
+ .cmd.text configure -state normal
+ }
if {[winfo exists .src]} {
.src.start configure -state normal
.src.stop configure -state disabled
.src.down configure -state normal
.src.bottom configure -state normal
}
-
if {[winfo exists .asm]} {
.asm.stepi configure -state normal
.asm.nexti configure -state normal
#
# Local procedure:
#
-# file_popup_menu (win x y xrel yrel) - Popup the file popup menu.
+# listing_window_popup (win x y xrel yrel) - Handle popups for listing window
#
# Description:
#
-# This procedure is invoked as a result of a command binding in the
-# listing window. It does several things:
-# o - It highlights the line under the cursor.
-# o - It pops up the file popup menu which is intended to do
-# various things to the aforementioned line.
-# o - Grabs the mouse for the file popup menu.
+# This procedure is invoked by holding down button 2 (usually) in the
+# listing window. The action taken depends upon where the button was
+# pressed. If it was in the left margin (the breakpoint column), it
+# sets or clears a breakpoint. In the main text area, it will pop up a
+# menu.
#
-# Button 1 has been pressed in a listing window. Pop up a menu.
-
-proc file_popup_menu {win x y xrel yrel} {
+proc listing_window_popup {win x y xrel yrel} {
global wins
global win_to_file
global file_to_debug_file
global selected_line
global selected_file
global selected_win
+ global pos_to_breakpoint
# Map TK window name back to file name.
set file $win_to_file($win)
- set pos [$win index @$xrel,$yrel]
+ set pos [split [$win index @$xrel,$yrel] .]
# Record selected file and line for menu button actions
set selected_file $file_to_debug_file($file)
- set selected_line [lindex [split $pos .] 0]
+ set selected_line [lindex $pos 0]
+ set selected_col [lindex $pos 1]
set selected_win $win
-# Highlight the selected line
-
- eval $win tag config breaktag $highlight
- $win tag add breaktag "$pos linestart" "$pos linestart + 1l"
-
# Post the menu near the pointer, (and grab it)
.file_popup entryconfigure 0 -label "$selected_file:$selected_line"
- tk_popup .file_popup $x $y
+
+ tk_popup .file_popup $x $y
}
#
# Local procedure:
#
-# listing_window_button_1 (win x y xrel yrel) - Handle button 1 in listing window
+# toggle_breakpoint (win x y xrel yrel) - Handle clicks on breakdots
#
# Description:
#
-# This procedure is invoked as a result of holding down button 1 in the
-# listing window. The action taken depends upon where the button was
-# pressed. If it was in the left margin (the breakpoint column), it
-# sets or clears a breakpoint. In the main text area, it will pop up a
-# menu.
+# This procedure sets or clears breakpoints where the button clicked.
#
-proc listing_window_button_1 {win x y xrel yrel} {
+proc toggle_breakpoint {win x y xrel yrel} {
global wins
global win_to_file
global file_to_debug_file
set pos [split [$win index @$xrel,$yrel] .]
-# Record selected file and line for menu button actions
+# Record selected file and line
set selected_file $file_to_debug_file($file)
set selected_line [lindex $pos 0]
# If we're in the margin, then toggle the breakpoint
- if {$selected_col < 8} {
- set pos_break $selected_file:$selected_line
- set pos $file:$selected_line
- set tmp pos_to_breakpoint($pos)
- if {[info exists $tmp]} {
- set bpnum [set $tmp]
- gdb_cmd "delete $bpnum"
- } else {
- gdb_cmd "break $pos_break"
- }
- return
+ if {$selected_col < 8} { # this is alway true actually
+ set pos_break $selected_file:$selected_line
+ set pos $file:$selected_line
+ set tmp pos_to_breakpoint($pos)
+ if {[info exists $tmp]} {
+ set bpnum [set $tmp]
+ gdb_cmd "delete $bpnum"
+ } else {
+ gdb_cmd "break $pos_break"
+ }
+ return
}
-
-# Post the menu near the pointer, (and grab it)
-
- .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
-
- tk_popup .file_popup $x $y
}
#
# Create the expression display window.
#
-set expr_num 0
-set delete_expr_num 0
-
# Set delete_expr_num, and set -state of Delete button.
proc expr_update_button {num} {
global delete_expr_num
proc delete_expr {} {
global delete_expr_num
+ global expr_update_list
+
if {$delete_expr_num > 0} then {
set e .expr.exprs
set f e${delete_expr_num}
destroy $e.updates.$f $e.expressions.$f $e.values.$f
-
- # FIXME should we unset an element of expr_update_list here?
+ unset expr_update_list($delete_expr_num)
}
}
}
proc create_expr_window {} {
+ global expr_num
+ global delete_expr_num
+ global expr_update_list
if {[winfo exists .expr]} {raise .expr ; return}
+ # All the state about individual expressions is stored in the
+ # expression window widgets, so when it is deleted, the
+ # previous values of the expression global variables become
+ # invalid. Reset to a known initial state.
+ set expr_num 0
+ set delete_expr_num 0
+ catch {unset expr_update_list}
+ set expr_update_list(0) 0
+
toplevel .expr
wm title .expr "GDB Expressions"
wm iconname .expr "Expressions"
global breakpoint_file
global breakpoint_line
global line_numbers
+ global debug_interface
# Replace all the dirty characters in $filename with clean ones, and generate
# a unique name for the text widget.
bind $win u {interactive_cmd up}
bind $win d {interactive_cmd down}
+ if $debug_interface {
+ bind $win <Control-C> {
+ puts stdout burp
+ }
+ }
+
$win delete 0.0 end
$win insert 0.0 [read $fh]
close $fh
$win tag add margin $i.0 $i.8
}
- $win tag bind margin <1> {listing_window_button_1 %W %X %Y %x %y}
+ # A debugging trick to highlight sensitive regions.
+ if $debug_interface {
+ $win tag bind source <Enter> {
+ %W tag configure source -background yellow
+ }
+ $win tag bind source <Leave> {
+ %W tag configure source -background green
+ }
+ $win tag bind margin <Enter> {
+ %W tag configure margin -background red
+ }
+ $win tag bind margin <Leave> {
+ %W tag configure margin -background skyblue
+ }
+ }
+
+ $win tag bind margin <1> {
+ toggle_breakpoint %W %X %Y %x %y
+ }
+
$win tag bind source <1> {
%W mark set anchor "@%x,%y wordstart"
set last [%W index "@%x,%y wordend"]
%W tag remove sel $last end
%W tag add sel anchor @%x,%y
}
- $win tag bind sel <1> do_nothing
- $win tag bind sel <Double-Button-1> {display_expression [selection get]}
- $win tag raise sel
+ $win tag bind sel <1> break
+ $win tag bind sel <Double-Button-1> {
+ display_expression [selection get]
+ break
+ }
+ $win tag bind sel <B1-Motion> break
+ $win tag lower sel
+
+ $win tag bind source <2> {
+ listing_window_popup %W %X %Y %x %y
+ }
+ # Make these bindings do nothing on the text window -- they
+ # are completely handled by the tag bindings above.
+ bind $win <1> break
+ bind $win <B1-Motion> break
+ bind $win <Double-Button-1> break
# Scan though the breakpoint data base and install any destined for this file
# Setup all the bindings
bind $win <Enter> {focus %W}
- bind $win <1> {asm_window_button_1 %W %X %Y %x %y}
- bind $win <B1-Motion> do_nothing
+ bind $win <1> {asm_window_button_1 %W %X %Y %x %y; break}
+ bind $win <B1-Motion> break
+ bind $win <Double-Button-1> break
bind $win <Key-Alt_R> do_nothing
bind $win <Key-Alt_L> do_nothing
.src.scroll configure -command "$wins($cfile) yview"
- $wins($cfile) see "${line}.0 linestart"
+ # $wins($cfile) see "${line}.0 linestart"
+ ensure_line_visible $wins($cfile) $line
}
# Update the label widget in case the filename or function name has changed
$wins($cfile) delete $pointer_pos "$pointer_pos + 2 char"
$wins($cfile) insert $pointer_pos "->"
- $wins($cfile) see "${line}.0 linestart"
+ ensure_line_visible $wins($cfile) $line
$wins($cfile) configure -state disabled
}
}
#
proc create_registers_window {} {
- global reg_format
+ global reg_format_natural
+ global reg_format_decimal
+ global reg_format_hex
+ global reg_format_octal
+ global reg_format_raw
+ global reg_format_binary
+ global reg_format_unsigned
- if {[winfo exists .reg]} {raise .reg ; return}
+ # If we already have a register window, just use that one.
-# Create an initial register display list consisting of all registers
+ if {[winfo exists .reg]} {raise .reg ; return}
- if {![info exists reg_format]} {
- global reg_display_list
- global changed_reg_list
- global regena
+ # Create an initial register display list consisting of all registers
- set reg_format {}
- set num_regs [llength [gdb_regnames]]
- for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
- set regena($regnum) 1
- }
- recompute_reg_display_list $num_regs
- set changed_reg_list $reg_display_list
- }
+ init_reg_info
- build_framework .reg Registers
+ build_framework .reg Registers
-# First, delete all the old menu entries
+ # First, delete all the old menu entries
+
+ .reg.menubar.view.menu delete 0 last
+
+ # Natural menu item
+ .reg.menubar.view.menu add checkbutton -label $reg_format_natural(label) \
+ -variable reg_format_natural(enable) -onvalue on -offvalue off \
+ -command {update_registers redraw}
+
+ # Decimal menu item
+ .reg.menubar.view.menu add checkbutton -label $reg_format_decimal(label) \
+ -variable reg_format_decimal(enable) -onvalue on -offvalue off \
+ -command {update_registers redraw}
+
+ # Hex menu item
+ .reg.menubar.view.menu add checkbutton -label $reg_format_hex(label) \
+ -variable reg_format_hex(enable) -onvalue on -offvalue off \
+ -command {update_registers redraw}
- .reg.menubar.view.menu delete 0 last
+ # Octal menu item
+ .reg.menubar.view.menu add checkbutton -label $reg_format_octal(label) \
+ -variable reg_format_octal(enable) -onvalue on -offvalue off \
+ -command {update_registers redraw}
-# Hex menu item
- .reg.menubar.view.menu add radiobutton -label Hex \
- -command {set reg_format x ; update_registers all}
+ # Binary menu item
+ .reg.menubar.view.menu add checkbutton -label $reg_format_binary(label) \
+ -variable reg_format_binary(enable) -onvalue on -offvalue off \
+ -command {update_registers redraw}
-# Decimal menu item
- .reg.menubar.view.menu add radiobutton -label Decimal \
- -command {set reg_format d ; update_registers all}
+ # Unsigned menu item
+ .reg.menubar.view.menu add checkbutton -label $reg_format_unsigned(label) \
+ -variable reg_format_unsigned(enable) -onvalue on -offvalue off \
+ -command {update_registers redraw}
-# Octal menu item
- .reg.menubar.view.menu add radiobutton -label Octal \
- -command {set reg_format o ; update_registers all}
+ # Raw menu item
+ .reg.menubar.view.menu add checkbutton -label $reg_format_raw(label) \
+ -variable reg_format_raw(enable) -onvalue on -offvalue off \
+ -command {update_registers redraw}
-# Natural menu item
- .reg.menubar.view.menu add radiobutton -label Natural \
- -command {set reg_format {} ; update_registers all}
+ # Config menu item
+ .reg.menubar.view.menu add separator
-# Config menu item
- .reg.menubar.view.menu add separator
+ .reg.menubar.view.menu add command -label Config \
+ -command { reg_config_menu }
- .reg.menubar.view.menu add command -label Config -command {
- reg_config_menu }
+ destroy .reg.label
+
+ # Install the reg names
+
+ populate_reg_window
+ update_registers all
+}
+
+proc init_reg_info {} {
+ global reg_format_natural
+ global reg_format_decimal
+ global reg_format_hex
+ global reg_format_octal
+ global reg_format_raw
+ global reg_format_binary
+ global reg_format_unsigned
+ global long_size
+ global double_size
+
+ if {![info exists reg_format_hex]} {
+ global reg_display_list
+ global changed_reg_list
+ global regena
- destroy .reg.label
+ set long_size [lindex [gdb_cmd {p sizeof(long)}] 2]
+ set double_size [lindex [gdb_cmd {p sizeof(double)}] 2]
+
+ # The natural format may print floats or doubles as floating point,
+ # which typically takes more room that printing ints on the same
+ # machine. We assume that if longs are 8 bytes that this is
+ # probably a 64 bit machine. (FIXME)
+ set reg_format_natural(label) Natural
+ set reg_format_natural(enable) on
+ set reg_format_natural(format) {}
+ if {$long_size == 8} then {
+ set reg_format_natural(width) 25
+ } else {
+ set reg_format_natural(width) 16
+ }
-# Install the reg names
+ set reg_format_decimal(label) Decimal
+ set reg_format_decimal(enable) off
+ set reg_format_decimal(format) d
+ if {$long_size == 8} then {
+ set reg_format_decimal(width) 21
+ } else {
+ set reg_format_decimal(width) 12
+ }
+
+ set reg_format_hex(label) Hex
+ set reg_format_hex(enable) off
+ set reg_format_hex(format) x
+ set reg_format_hex(width) [expr $long_size * 2 + 3]
+
+ set reg_format_octal(label) Octal
+ set reg_format_octal(enable) off
+ set reg_format_octal(format) o
+ set reg_format_octal(width) [expr $long_size * 8 / 3 + 3]
+
+ set reg_format_raw(label) Raw
+ set reg_format_raw(enable) off
+ set reg_format_raw(format) r
+ set reg_format_raw(width) [expr $double_size * 2 + 3]
+
+ set reg_format_binary(label) Binary
+ set reg_format_binary(enable) off
+ set reg_format_binary(format) t
+ set reg_format_binary(width) [expr $long_size * 8 + 1]
+
+ set reg_format_unsigned(label) Unsigned
+ set reg_format_unsigned(enable) off
+ set reg_format_unsigned(format) u
+ if {$long_size == 8} then {
+ set reg_format_unsigned(width) 21
+ } else {
+ set reg_format_unsigned(width) 11
+ }
- populate_reg_window
- update_registers all
+ set num_regs [llength [gdb_regnames]]
+ for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
+ set regena($regnum) 1
+ }
+ recompute_reg_display_list $num_regs
+ #set changed_reg_list $reg_display_list
+ set changed_reg_list {}
+ }
}
# Convert regena into a list of the enabled $regnums
global regena
catch {unset reg_display_list}
+ set reg_display_list {}
- set line 1
+ set line 2
for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
if {[set regena($regnum)] != 0} {
# reg_display_list.
proc populate_reg_window {} {
- global max_regname_width
- global reg_display_list
-
- .reg.text configure -state normal
-
- .reg.text delete 0.0 end
-
+ global reg_format_natural
+ global reg_format_decimal
+ global reg_format_hex
+ global reg_format_octal
+ global reg_format_raw
+ global reg_format_binary
+ global reg_format_unsigned
+ global max_regname_width
+ global reg_display_list
+
+ set win .reg.text
+ $win configure -state normal
+
+ # Clear the entire widget and insert a blank line at the top where
+ # the column labels will appear.
+ $win delete 0.0 end
+ $win insert end "\n"
+
+ if {[llength $reg_display_list] > 0} {
set regnames [eval gdb_regnames $reg_display_list]
+ } else {
+ set regnames {}
+ }
-# Figure out the longest register name
-
- set max_regname_width 0
+ # Figure out the longest register name
- foreach reg $regnames {
- set len [string length $reg]
- if {$len > $max_regname_width} {set max_regname_width $len}
- }
+ set max_regname_width 0
- set width [expr $max_regname_width + 15]
+ foreach reg $regnames {
+ set len [string length $reg]
+ if {$len > $max_regname_width} {set max_regname_width $len}
+ }
- set height [llength $regnames]
+ set width [expr $max_regname_width + 15]
- if {$height > 60} {set height 60}
+ set height [expr [llength $regnames] + 1]
- .reg.text configure -height $height -width $width
+ if {$height > 60} {set height 60}
- foreach reg $regnames {
- .reg.text insert end [format "%-*s \n" $max_regname_width ${reg}]
- }
+ $win configure -height $height -width $width
+ foreach reg $regnames {
+ $win insert end [format "%-*s\n" $width ${reg}]
+ }
- .reg.text yview 0
- .reg.text configure -state disabled
+ #Delete the blank line left at end by last insertion.
+ if {[llength $regnames] > 0} {
+ $win delete {end - 1 char} end
+ }
+ $win yview 0
+ $win configure -state disabled
}
#
#
# Description:
#
-# This procedure updates the registers window.
+# This procedure updates the registers window according to the value of
+# the "which" arg.
#
proc update_registers {which} {
- global max_regname_width
- global reg_format
- global reg_display_list
- global changed_reg_list
- global highlight
- global regmap
-
- set margin [expr $max_regname_width + 1]
- set win .reg.text
- set winwidth [lindex [$win configure -width] 4]
- set valwidth [expr $winwidth - $margin]
-
- $win configure -state normal
-
- if {$which == "all"} {
- set lineindex 1
- foreach regnum $reg_display_list {
- set regval [gdb_fetch_registers $reg_format $regnum]
- set regval [format "%-*s" $valwidth $regval]
- $win delete $lineindex.$margin "$lineindex.0 lineend"
- $win insert $lineindex.$margin $regval
- incr lineindex
- }
- $win configure -state disabled
- return
+ global max_regname_width
+ global reg_format_natural
+ global reg_format_decimal
+ global reg_format_hex
+ global reg_format_octal
+ global reg_format_binary
+ global reg_format_unsigned
+ global reg_format_raw
+ global reg_display_list
+ global changed_reg_list
+ global highlight
+ global regmap
+
+ # margin is the column where we start printing values
+ set margin [expr $max_regname_width + 1]
+ set win .reg.text
+ $win configure -state normal
+
+ if {$which == "all" || $which == "redraw"} {
+ set display_list $reg_display_list
+ $win delete 1.0 1.end
+ $win insert 1.0 [format "%*s" $max_regname_width " "]
+ foreach format {natural decimal unsigned hex octal raw binary } {
+ set field (enable)
+ set var reg_format_$format$field
+ if {[set $var] == "on"} {
+ set field (label)
+ set var reg_format_$format$field
+ set label [set $var]
+ set field (width)
+ set var reg_format_$format$field
+ set var [format "%*s" [set $var] $label]
+ $win insert 1.end $var
+ }
}
-
-# Unhighlight the old values
-
+ } else {
+ # Unhighlight the old values
foreach regnum $changed_reg_list {
- $win tag delete $win.$regnum
+ $win tag delete $win.$regnum
}
-
-# Now, highlight the changed values of the interesting registers
-
set changed_reg_list [eval gdb_changed_register_list $reg_display_list]
-
- set lineindex 1
+ set display_list $changed_reg_list
+ }
+ foreach regnum $display_list {
+ set lineindex $regmap($regnum)
+ $win delete $lineindex.$margin "$lineindex.0 lineend"
+ foreach format {natural decimal unsigned hex octal raw binary } {
+ set field (enable)
+ set var reg_format_$format$field
+ if {[set $var] == "on"} {
+ set field (format)
+ set var reg_format_$format$field
+ set regval [gdb_fetch_registers [set $var] $regnum]
+ set field (width)
+ set var reg_format_$format$field
+ set regval [format "%*s" [set $var] $regval]
+ $win insert $lineindex.end $regval
+ }
+ }
+ }
+ # Now, highlight the changed values of the interesting registers
+ if {$which != "all"} {
foreach regnum $changed_reg_list {
- set regval [gdb_fetch_registers $reg_format $regnum]
- set regval [format "%-*s" $valwidth $regval]
-
- set lineindex $regmap($regnum)
- $win delete $lineindex.$margin "$lineindex.0 lineend"
- $win insert $lineindex.$margin $regval
- $win tag add $win.$regnum $lineindex.0 "$lineindex.0 lineend"
- eval $win tag configure $win.$regnum $highlight
+ set lineindex $regmap($regnum)
+ $win tag add $win.$regnum $lineindex.0 "$lineindex.0 lineend"
+ eval $win tag configure $win.$regnum $highlight
}
-
- $win configure -state disabled
+ }
+ set winwidth $margin
+ foreach format {natural decimal unsigned hex octal raw binary} {
+ set field (enable)
+ set var reg_format_$format$field
+ if {[set $var] == "on"} {
+ set field (width)
+ set var reg_format_$format$field
+ set winwidth [expr $winwidth + [set $var]]
+ }
+ }
+ $win configure -width $winwidth
+ $win configure -state disabled
}
#
-after .asm.scroll
.asm.scroll configure -command "$win yview"
set line [pc_to_line $pclist($cfunc) $pc]
- $win see "${line}.0 linestart"
+ ensure_line_visible $win $line
update
}
$win delete $pointer_pos "$pointer_pos + 2 char"
$win insert $pointer_pos "->"
- $win yview "${line}.0 linestart"
+ ensure_line_visible $win $line
$win configure -state disabled
}
}
wm minsize .files_window 1 1
# wm overrideredirect .files_window true
- listbox .files_window.list -geometry 30x20 -setgrid true \
+ listbox .files_window.list -width 30 -height 20 -setgrid true \
-yscrollcommand {.files_window.scroll set} -relief sunken \
-borderwidth 2
scrollbar .files_window.scroll -orient vertical \
button .files_window.close -text Close -command {destroy .files_window}
.files_window.list configure -selectmode single
- # Get the file list from GDB, sort it, and format it as one entry per line.
- set lastSeen {}; # Value that won't appear in
- # list.
- set fileList {}
- foreach file [lsort [gdb_listfiles]] {
- if {$file != $lastSeen} then {
- lappend fileList $file
- set lastSeen $file
- }
- }
- set filelist [join [lsort [gdb_listfiles]] "\n"]
-
- # Insert the file list into the widget
-
- eval .files_window.list insert 0 $filelist
+ # Get the file list from GDB, sort it, and insert into the widget.
+ eval .files_window.list insert 0 [lsort [gdb_listfiles]]
pack .files_window.close -side bottom -fill x -expand no -anchor s
pack .files_window.scroll -side right -fill both
pack .files_window.list -side left -fill both -expand yes
- bind .files_window.list <Any-ButtonRelease-1> {
+ bind .files_window.list <ButtonRelease-1> {
set file [%W get [%W curselection]]
gdb_cmd "list $file:1,0"
update_listing [gdb_loc $file:1]
destroy .files_window
}
+ # We must execute the listbox binding first, because it
+ # references the widget that will be destroyed by the widget
+ # binding for Button-Release-1. Otherwise we try to use
+ # .files_window.list after the .files_window is destroyed.
+ bind_widget_after_class .files_window.list
}
button .files -text Files -command files_command
proc create_command_window {} {
global command_line
global saw_tab
+ global gdb_prompt
set saw_tab 0
if {[winfo exists .cmd]} {raise .cmd ; return}
gdb_cmd {set height 0}
gdb_cmd {set width 0}
+ bind .cmd.text <Control-c> gdb_stop
+
# Tk uses the Motifism that Delete means delete forward. I
# hate this, and I'm not gonna take it any more.
set bsBinding [bind Text <BackSpace>]
bind .cmd.text <Delete> "delete_char %W ; $bsBinding; break"
- bind .cmd.text <BackSpace> {delete_char %W}
- bind .cmd.text <Control-c> gdb_stop
- bind .cmd.text <Control-u> {delete_line %W ; break}
+ bind .cmd.text <BackSpace> {
+ if {([%W cget -state] == "disabled")} { break }
+ delete_char %W
+ }
+ bind .cmd.text <Control-u> {
+ if {([%W cget -state] == "disabled")} { break }
+ delete_line %W
+ break
+ }
bind .cmd.text <Any-Key> {
+ if {([%W cget -state] == "disabled")} { break }
set saw_tab 0
%W insert end %A
%W see end
break
}
bind .cmd.text <Key-Return> {
+ if {([%W cget -state] == "disabled")} { break }
set saw_tab 0
%W insert end \n
interactive_cmd $command_line
# %W insert end $result
set command_line {}
# update_ptr
- %W insert end "(gdb) "
+ %W insert end "$gdb_prompt"
%W see end
break
}
append command_line [selection get]
break
}
+ bind .cmd.text <B2-Motion> break
+ bind .cmd.text <ButtonRelease-2> break
bind .cmd.text <Key-Tab> {
+ if {([%W cget -state] == "disabled")} { break }
set choices [gdb_cmd "complete $command_line"]
set choices [string trimright $choices \n]
set choices [split $choices \n]
if {[regexp ".* " $command_line prefix]} {
regsub -all $prefix $choices {} choices
}
- %W insert end "\n[join $choices { }]\n(gdb) $command_line"
+ %W insert end "\n[join $choices { }]\n$gdb_prompt$command_line"
%W see end
}
break
}
}
+# Trim one character off the command line. The argument is ignored.
+
proc delete_char {win} {
global command_line
set tmp [expr [string length $command_line] - 2]
set command_line [string range $command_line 0 $tmp]
}
+# FIXME: This should actually check that the first characters of the current
+# line match the gdb prompt, since the user can move the insertion point
+# anywhere. It should also check that the insertion point is in the last
+# line of the text widget.
+
proc delete_line {win} {
- global command_line
+ global command_line
+ global gdb_prompt
- $win delete {end linestart + 6 chars} end
- $win see insert
- set command_line {}
+ set tmp [string length $gdb_prompt]
+ $win delete "insert linestart + $tmp chars" "insert lineend"
+ $win see insert
+ set command_line {}
}
#
pack .c.m
bind .c.m <1> {destroy .c}
- # "suitable period" currently means "15 seconds".
- after 15000 {
+ bind .c <Leave> {destroy .c}
+ # "suitable period" currently means "30 seconds".
+ after 30000 {
if {[winfo exists .c]} then {
destroy .c
}
center_window .c
}
+# Begin support primarily for debugging the tcl/tk portion of gdbtk. You can
+# start gdbtk, and then issue the command "tk tclsh" and a window will pop up
+# giving you direct access to the tcl interpreter. With this, it is very easy
+# to examine the values of global variables, directly invoke routines that are
+# part of the gdbtk interface, replace existing proc's with new ones, etc.
+# This code was inspired from example 11-3 in Brent Welch's "Practical
+# Programming in Tcl and Tk"
+
+set tcl_prompt "tcl> "
+
+# Get the current command that user has typed, from cmdstart to end of text
+# widget. Evaluate it, insert result back into text widget, issue a new
+# prompt, update text widget and update command start mark.
+
+proc evaluate_tcl_command { twidget } {
+ global tcl_prompt
+
+ set command [$twidget get cmdstart end]
+ if [info complete $command] {
+ set err [catch {uplevel #0 $command} result]
+ $twidget insert insert \n$result\n
+ $twidget insert insert $tcl_prompt
+ $twidget see insert
+ $twidget mark set cmdstart insert
+ return
+ }
+}
+
+# Create the evaluation window and set up the keybindings to evaluate the
+# last single line entered by the user. FIXME: allow multiple lines?
+
+proc tclsh {} {
+ global tcl_prompt
+
+ # If another evaluation window already exists, just bring it to the front.
+ if {[winfo exists .eval]} {raise .eval ; return}
+
+ # Create top level frame with scrollbar and text widget.
+ toplevel .eval
+ wm title .eval "Tcl Evaluation"
+ wm iconname .eval "Tcl"
+ text .eval.text -width 80 -height 20 -setgrid true -cursor hand2 \
+ -yscrollcommand {.eval.scroll set}
+ scrollbar .eval.scroll -command {.eval.text yview}
+ pack .eval.scroll -side right -fill y
+ pack .eval.text -side left -fill both -expand true
+
+ # Insert the tcl_prompt and initialize the cmdstart mark
+ .eval.text insert insert $tcl_prompt
+ .eval.text mark set cmdstart insert
+ .eval.text mark gravity cmdstart left
+
+ # Make this window the current one for input.
+ focus .eval.text
+
+ # Keybindings that limit input and evaluate things
+ bind .eval.text <Return> { evaluate_tcl_command .eval.text ; break }
+ bind .eval.text <BackSpace> {
+ if [%W compare insert > cmdstart] {
+ %W delete {insert - 1 char} insert
+ } else {
+ bell
+ }
+ break
+ }
+ bind .eval.text <Any-Key> {
+ if [%W compare insert < cmdstart] {
+ %W mark set insert end
+ }
+ }
+ bind .eval.text <Control-u> {
+ %W delete cmdstart "insert lineend"
+ %W see insert
+ }
+ bindtags .eval.text {.eval.text Text all}
+}
+
+# This proc is executed just prior to falling into the Tk main event loop.
+proc gdbtk_tcl_preloop {} {
+ global gdb_prompt
+ .cmd.text insert end "$gdb_prompt"
+ .cmd.text see end
+ update
+}
+
# FIXME need to handle mono here. In Tk4 that is more complicated.
set highlight "-background red2 -borderwidth 2 -relief sunken"
projects / deliverable / binutils-gdb.git / blobdiff