# GDB GUI setup for GDB, the GNU debugger.
-# Copyright 1994, 1995
+# Copyright 1994, 1995, 1996
# Free Software Foundation, Inc.
# Written by Stu Grossman <grossman@cygnus.com> of Cygnus Support.
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
-# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
set cfile Blank
set wins($cfile) .src.text
set current_label {}
-set screen_height 0
-set screen_top 0
-set screen_bot 0
-set current_output_win .cmd.text
set cfunc NIL
set line_numbers 1
set breakpoint_file(-1) {[garbage]}
set disassemble_with_source nosource
+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
#option add *Font -*-*-medium-r-normal--18-*-*-*-m-*-*-1
-tk colormodel . monochrome
proc echo string {puts stdout $string}
-if [info exists env(EDITOR)] then {
- set editor $env(EDITOR)
- } else {
- set editor emacs
+# Assign elements from LIST to variables named in ARGS. FIXME replace
+# with TclX version someday.
+proc lassign {list args} {
+ set len [expr {[llength $args] - 1}]
+ while {$len >= 0} {
+ upvar [lindex $args $len] local
+ set local [lindex $list $len]
+ decr len
+ }
+}
+
+#
+# Local procedure:
+#
+# decr (var val) - compliment to incr
+#
+# Description:
+#
+#
+proc decr {var {val 1}} {
+ upvar $var num
+ set num [expr {$num - $val}]
+ return $num
+}
+
+#
+# Center a window on the screen.
+#
+proc center_window {toplevel} {
+ # Withdraw and update, to ensure geometry computations are finished.
+ wm withdraw $toplevel
+ update idletasks
+
+ set x [expr {[winfo screenwidth $toplevel] / 2
+ - [winfo reqwidth $toplevel] / 2
+ - [winfo vrootx $toplevel]}]
+ set y [expr {[winfo screenheight $toplevel] / 2
+ - [winfo reqheight $toplevel] / 2
+ - [winfo vrooty $toplevel]}]
+ wm geometry $toplevel +${x}+${y}
+ wm deiconify $toplevel
+}
+
+#
+# Rearrange the bindtags so the widget comes after the class. I was
+# always for Ousterhout putting the class bindings first, but no...
+#
+proc bind_widget_after_class {widget} {
+ set class [winfo class $widget]
+ set newList {}
+ foreach tag [bindtags $widget] {
+ if {$tag == $widget} {
+ # Nothing.
+ } {
+ lappend newList $tag
+ if {$tag == $class} {
+ lappend newList $widget
+ }
+ }
+ }
+ 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 {
+ set editor emacs
}
# GDB callbacks
#
proc gdbtk_tcl_fputs {arg} {
- global current_output_win
-
- $current_output_win insert end "$arg"
- $current_output_win yview -pickplace end
+ .cmd.text insert end "$arg"
+ .cmd.text see end
}
proc gdbtk_tcl_fputs_error {arg} {
- .cmd.text insert end "$arg"
- .cmd.text yview -pickplace end
+ .cmd.text insert end "$arg"
+ .cmd.text see end
}
#
#
proc gdbtk_tcl_flush {} {
- global current_output_win
-
- $current_output_win yview -pickplace end
- update idletasks
+ .cmd.text see end
+ update idletasks
}
#
#
proc gdbtk_tcl_query {message} {
- tk_dialog .query "gdb : query" "$message" {} 1 "No" "Yes"
- }
+ # FIXME We really want a Help button here. But Tk's brain-damaged
+ # modal dialogs won't really allow it. Should have async dialog
+ # here.
+ set result [tk_dialog .query "gdb : query" "$message" questhead 0 Yes No]
+ return [expr {!$result}]
+}
#
# GDB Callback:
# Not yet implemented.
#
-proc gdbtk_tcl_start_variable_annotation {valaddr ref_type stor_cl cum_expr field type_cast} {
- echo "gdbtk_tcl_start_variable_annotation $valaddr $ref_type $stor_cl $cum_expr $field $type_cast"
+proc gdbtk_tcl_start_variable_annotation {valaddr ref_type stor_cl
+ cum_expr field type_cast} {
+ echo "gdbtk_tcl_start_variable_annotation $valaddr $ref_type $stor_cl $cum_expr $field $type_cast"
}
#
# of:
# create - Notify of breakpoint creation
# delete - Notify of breakpoint deletion
-# enable - Notify of breakpoint enabling
-# disable - Notify of breakpoint disabling
-#
-# All actions take the same set of arguments: BPNUM is the breakpoint
-# number, FILE is the source file and LINE is the line number, and PC is
-# the pc of the affected breakpoint.
+# modify - Notify of breakpoint modification
#
-proc gdbtk_tcl_breakpoint {action bpnum file line pc} {
+# file line pc type enabled disposition silent ignore_count commands cond_string thread hit_count
+
+proc gdbtk_tcl_breakpoint {action bpnum} {
+ set bpinfo [gdb_get_breakpoint_info $bpnum]
+ set file [lindex $bpinfo 0]
+ set line [lindex $bpinfo 1]
+ set pc [lindex $bpinfo 2]
+ set enable [lindex $bpinfo 4]
+
+ if {$action == "modify"} {
+ if {$enable == "1"} {
+ set action enable
+ } else {
+ set action disable
+ }
+ }
+
${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
+
+ if {[winfo exists .breakpoints]} {raise .breakpoints ; return}
+
+ build_framework .breakpoints "Breakpoints" ""
+
+# First, delete all the old view menu entries
+
+ .breakpoints.menubar.view.menu delete 0 last
+
+# Get rid of label
+
+ destroy .breakpoints.label
+
+# Replace text with a canvas and fix the scrollbars
+
+ destroy .breakpoints.text
+ scrollbar .breakpoints.scrollx -orient horizontal \
+ -command {.breakpoints.c xview} -relief sunken
+ canvas .breakpoints.c -relief sunken -bd 2 \
+ -cursor hand2 \
+ -yscrollcommand {.breakpoints.scroll set} \
+ -xscrollcommand {.breakpoints.scrollx set}
+ .breakpoints.scroll configure -command {.breakpoints.c yview}
+
+ pack .breakpoints.scrollx -side bottom -fill x -in .breakpoints.info
+ pack .breakpoints.c -side left -expand yes -fill both \
+ -in .breakpoints.info
+
+ set bpframe_lasty 0
+
+# Create a frame for each breakpoint
+
+ foreach bpnum [gdb_get_breakpoint_list] {
+ add_breakpoint_frame $bpnum
+ }
+}
+
+# Create a frame for bpnum in the .breakpoints canvas
+
+proc add_breakpoint_frame {bpnum} {
+ global bpframe_lasty
+ global enabled
+ global disposition
+
+ if {![winfo exists .breakpoints]} return
+
+ set bpinfo [gdb_get_breakpoint_info $bpnum]
+
+ lassign $bpinfo file line pc type enabled($bpnum) disposition($bpnum) \
+ silent ignore_count commands cond thread hit_count
+
+ set f .breakpoints.c.$bpnum
+
+ if {![winfo exists $f]} {
+ frame $f -relief sunken -bd 2
+
+ label $f.id -text "#$bpnum $file:$line ($pc)" \
+ -relief flat -bd 2 -anchor w
+ frame $f.hit_count
+ label $f.hit_count.label -text "Hit count:" -relief flat \
+ -bd 2 -anchor w -width 11
+ label $f.hit_count.val -text $hit_count -relief flat \
+ -bd 2 -anchor w
+ checkbutton $f.hit_count.enabled -text Enabled \
+ -variable enabled($bpnum) -anchor w -relief flat
+
+ pack $f.hit_count.label $f.hit_count.val -side left
+ pack $f.hit_count.enabled -side right
+
+ frame $f.thread
+ label $f.thread.label -text "Thread: " -relief flat -bd 2 \
+ -width 11 -anchor w
+ entry $f.thread.entry -bd 2 -relief sunken -width 10
+ $f.thread.entry insert end $thread
+ pack $f.thread.label -side left
+ pack $f.thread.entry -side left -fill x
+
+ frame $f.cond
+ label $f.cond.label -text "Condition: " -relief flat -bd 2 \
+ -width 11 -anchor w
+ entry $f.cond.entry -bd 2 -relief sunken
+ $f.cond.entry insert end $cond
+ pack $f.cond.label -side left
+ pack $f.cond.entry -side left -fill x -expand yes
+
+ frame $f.ignore_count
+ label $f.ignore_count.label -text "Ignore count: " \
+ -relief flat -bd 2 -width 11 -anchor w
+ entry $f.ignore_count.entry -bd 2 -relief sunken -width 10
+ $f.ignore_count.entry insert end $ignore_count
+ pack $f.ignore_count.label -side left
+ pack $f.ignore_count.entry -side left -fill x
+
+ frame $f.disps
+
+ label $f.disps.label -text "Disposition: " -relief flat -bd 2 \
+ -anchor w -width 11
+
+ radiobutton $f.disps.delete -text Delete \
+ -variable disposition($bpnum) -anchor w -relief flat \
+ -command "gdb_cmd \"delete break $bpnum\"" \
+ -value delete
+
+ radiobutton $f.disps.disable -text Disable \
+ -variable disposition($bpnum) -anchor w -relief flat \
+ -command "gdb_cmd \"disable break $bpnum\"" \
+ -value disable
+
+ radiobutton $f.disps.donttouch -text "Leave alone" \
+ -variable disposition($bpnum) -anchor w -relief flat \
+ -command "gdb_cmd \"enable break $bpnum\"" \
+ -value donttouch
+
+ pack $f.disps.label $f.disps.delete $f.disps.disable \
+ $f.disps.donttouch -side left -anchor w
+ text $f.commands -relief sunken -bd 2 -setgrid true \
+ -cursor hand2 -height 3 -width 30
+
+ foreach line $commands {
+ $f.commands insert end "${line}\n"
+ }
+
+ pack $f.id -side top -anchor nw -fill x
+ pack $f.hit_count $f.cond $f.thread $f.ignore_count $f.disps \
+ $f.commands -side top -fill x -anchor nw
+ }
+
+ set tag [.breakpoints.c create window 0 $bpframe_lasty -window $f -anchor nw]
+ update
+ set bbox [.breakpoints.c bbox $tag]
+
+ set bpframe_lasty [lindex $bbox 3]
+
+ .breakpoints.c configure -width [lindex $bbox 2]
+}
+
+# Delete a breakpoint frame
+
+proc delete_breakpoint_frame {bpnum} {
+ global bpframe_lasty
+
+ if {![winfo exists .breakpoints]} return
+
+# First, clear the canvas
+
+ .breakpoints.c delete all
+
+# Now, repopulate it with all but the doomed breakpoint
+
+ set bpframe_lasty 0
+ foreach bp [gdb_get_breakpoint_list] {
+ if {$bp != $bpnum} {
+ add_breakpoint_frame $bp
+ }
+ }
+}
+
proc asm_win_name {funcname} {
if {$funcname == "*None*"} {return .asm.text}
set breakpoint_file($bpnum) $file
set breakpoint_line($bpnum) $line
set pos_to_breakpoint($file:$line) $bpnum
- if ![info exists pos_to_bpcount($file:$line)] {
+ if {![info exists pos_to_bpcount($file:$line)]} {
set pos_to_bpcount($file:$line) 0
}
incr pos_to_bpcount($file:$line)
set pos_to_breakpoint($pc) $bpnum
- if ![info exists pos_to_bpcount($pc)] {
+ if {![info exists pos_to_bpcount($pc)]} {
set pos_to_bpcount($pc) 0
}
incr pos_to_bpcount($pc)
# If there's a window for this file, update it
- if [info exists wins($file)] {
+ if {[info exists wins($file)]} {
insert_breakpoint_tag $wins($file) $line
}
# If there's an assembly window, update that too
set win [asm_win_name $cfunc]
- if [winfo exists $win] {
+ if {[winfo exists $win]} {
insert_breakpoint_tag $win [pc_to_line $pclist($cfunc) $pc]
}
+
+# Update the breakpoints window
+
+ add_breakpoint_frame $bpnum
}
#
# If there's a window for this file, update it
- if [info exists wins($file)] {
+ if {[info exists wins($file)]} {
delete_breakpoint_tag $wins($file) $line
}
}
catch "unset pos_to_breakpoint($pc)"
set win [asm_win_name $cfunc]
- if [winfo exists $win] {
+ if {[winfo exists $win]} {
delete_breakpoint_tag $win [pc_to_line $pclist($cfunc) $pc]
}
}
}
+
+ delete_breakpoint_frame $bpnum
}
#
proc enable_breakpoint {bpnum file line pc} {
global wins
global cfunc pclist
+ global enabled
- if [info exists wins($file)] {
+ if {[info exists wins($file)]} {
$wins($file) tag configure $line -fgstipple {}
}
# If there's an assembly window, update that too
set win [asm_win_name $cfunc]
- if [winfo exists $win] {
+ if {[winfo exists $win]} {
$win tag configure [pc_to_line $pclist($cfunc) $pc] -fgstipple {}
}
+
+# If there's a breakpoint window, update that too
+
+ if {[winfo exists .breakpoints]} {
+ set enabled($bpnum) 1
+ }
}
#
proc disable_breakpoint {bpnum file line pc} {
global wins
global cfunc pclist
+ global enabled
- if [info exists wins($file)] {
+ if {[info exists wins($file)]} {
$wins($file) tag configure $line -fgstipple gray50
}
# If there's an assembly window, update that too
set win [asm_win_name $cfunc]
- if [winfo exists $win] {
+ if {[winfo exists $win]} {
$win tag configure [pc_to_line $pclist($cfunc) $pc] -fgstipple gray50
}
+
+# If there's a breakpoint window, update that too
+
+ if {[winfo exists .breakpoints]} {
+ set enabled($bpnum) 0
+ }
}
#
$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 .src] {
- catch {.src.start configure -state disabled}
- catch {.src.stop configure -state normal}
- catch {.src.step configure -state disabled}
- catch {.src.next configure -state disabled}
- catch {.src.continue configure -state disabled}
- catch {.src.finish configure -state disabled}
- catch {.src.up configure -state disabled}
- catch {.src.down configure -state disabled}
- catch {.src.bottom configure -state disabled}
- }
- if [winfo exists .asm] {
- catch {.asm.stepi configure -state disabled}
- catch {.asm.nexti configure -state disabled}
- catch {.asm.continue configure -state disabled}
- catch {.asm.finish configure -state disabled}
- catch {.asm.up configure -state disabled}
- catch {.asm.down configure -state disabled}
- catch {.asm.bottom configure -state disabled}
- catch {.asm.close configure -state disabled}
+ if {[winfo exists .cmd]} {
+ .cmd.text configure -state disabled
+ }
+ if {[winfo exists .src]} {
+ .src.start configure -state disabled
+ .src.stop configure -state normal
+ .src.step configure -state disabled
+ .src.next configure -state disabled
+ .src.continue configure -state disabled
+ .src.finish configure -state disabled
+ .src.up configure -state disabled
+ .src.down configure -state disabled
+ .src.bottom configure -state disabled
+ }
+ if {[winfo exists .asm]} {
+ .asm.stepi configure -state disabled
+ .asm.nexti configure -state disabled
+ .asm.continue configure -state disabled
+ .asm.finish configure -state disabled
+ .asm.up configure -state disabled
+ .asm.down configure -state disabled
+ .asm.bottom configure -state disabled
}
+ return
}
proc gdbtk_tcl_idle {} {
- if [winfo exists .src] {
- catch {.src.start configure -state normal}
- catch {.src.stop configure -state disabled}
- catch {.src.step configure -state normal}
- catch {.src.next configure -state normal}
- catch {.src.continue configure -state normal}
- catch {.src.finish configure -state normal}
- catch {.src.up configure -state normal}
- catch {.src.down configure -state normal}
- catch {.src.bottom configure -state normal}
- }
-
- if [winfo exists .asm] {
- catch {.asm.stepi configure -state normal}
- catch {.asm.nexti configure -state normal}
- catch {.asm.continue configure -state normal}
- catch {.asm.finish configure -state normal}
- catch {.asm.up configure -state normal}
- catch {.asm.down configure -state normal}
- catch {.asm.bottom configure -state normal}
- catch {.asm.close configure -state normal}
+ if {[winfo exists .cmd]} {
+ .cmd.text configure -state normal
+ }
+ if {[winfo exists .src]} {
+ .src.start configure -state normal
+ .src.stop configure -state disabled
+ .src.step configure -state normal
+ .src.next configure -state normal
+ .src.continue configure -state normal
+ .src.finish configure -state normal
+ .src.up configure -state normal
+ .src.down configure -state normal
+ .src.bottom configure -state normal
+ }
+ if {[winfo exists .asm]} {
+ .asm.stepi configure -state normal
+ .asm.nexti configure -state normal
+ .asm.continue configure -state normal
+ .asm.finish configure -state normal
+ .asm.up configure -state normal
+ .asm.down configure -state normal
+ .asm.bottom configure -state normal
}
-}
-
-#
-# Local procedure:
-#
-# decr (var val) - compliment to incr
-#
-# Description:
-#
-#
-proc decr {var {val 1}} {
- upvar $var num
- set num [expr $num - $val]
- return $num
+ return
}
#
if {$pc < $linepc} { decr line ; return $line }
incr line
}
- return [expr $line - 1]
+ return [expr {$line - 1}]
}
#
# to notify us of where the breakpoint needs to show up.
#
-menu .file_popup -cursor hand2
+menu .file_popup -cursor hand2 -tearoff 0
.file_popup add command -label "Not yet set" -state disabled
.file_popup add separator
-.file_popup add command -label "Edit" -command {exec $editor +$selected_line $selected_file &}
-.file_popup add command -label "Set breakpoint" -command {gdb_cmd "break $selected_file:$selected_line"}
+.file_popup add command -label "Edit" \
+ -command {exec $editor +$selected_line $selected_file &}
+.file_popup add command -label "Set breakpoint" \
+ -command {gdb_cmd "break $selected_file:$selected_line"}
+
+# Use this procedure to get the GDB core to execute the string `cmd'. This is
+# a wrapper around gdb_cmd, which will catch errors, and send output to the
+# command window. It will also cause all of the other windows to be updated.
+
+proc interactive_cmd {cmd} {
+ catch {gdb_cmd "$cmd"} result
+ .cmd.text insert end $result
+ .cmd.text see end
+ update_ptr
+}
#
# Bindings:
#
# Description:
#
-# This defines the binding for the file popup menu. Currently, there is
-# only one, which is activated when Button-1 is released. This causes
-# the menu to be unposted, releases the grab for the menu, and then
-# unhighlights the line under the cursor. After that, the selected menu
-# item is invoked.
+# This defines the binding for the file popup menu. It simply
+# unhighlights the line under the cursor.
#
bind .file_popup <Any-ButtonRelease-1> {
- global selected_win
-
-# First, remove the menu, and release the pointer
-
- .file_popup unpost
- grab release .file_popup
-
-# Unhighlight the selected line
-
- $selected_win tag delete breaktag
-
-# Actually invoke the menubutton here!
-
- tk_invokeMenu %W
+ global selected_win
+ # Unhighlight the selected line
+ $selected_win tag delete breaktag
}
#
# 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"
- .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
- grab .file_popup
+
+ 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"
- .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
- grab .file_popup
}
#
if {$selected_col < 11} {
set tmp pos_to_breakpoint($pc)
- if [info exists $tmp] {
+ if {[info exists $tmp]} {
set bpnum [set $tmp]
gdb_cmd "delete $bpnum"
} else {
proc not_implemented_yet {message} {
tk_dialog .unimpl "gdb : unimpl" \
"$message: not implemented in the interface yet" \
- {} 1 "OK"
+ warning 0 "OK"
}
##
# Local procedure:
#
-# create_expr_win - Create expression display window
+# create_expr_window - Create expression display window
#
# Description:
#
# Create the expression display window.
#
-set expr_num 0
+# Set delete_expr_num, and set -state of Delete button.
+proc expr_update_button {num} {
+ global delete_expr_num
+ set delete_expr_num $num
+ if {$num > 0} then {
+ set state normal
+ } else {
+ set state disabled
+ }
+ .expr.buts.delete configure -state $state
+}
proc add_expr {expr} {
- global expr_update_list
- global expr_num
+ global expr_update_list
+ global expr_num
- incr expr_num
+ incr expr_num
- set e .expr.e${expr_num}
+ set e .expr.exprs
+ set f e$expr_num
- frame $e
+ checkbutton $e.updates.$f -text "" -relief flat \
+ -variable expr_update_list($expr_num)
+ text $e.expressions.$f -width 20 -height 1
+ $e.expressions.$f insert 0.0 $expr
+ bind $e.expressions.$f <1> "update_expr $expr_num"
+ text $e.values.$f -width 20 -height 1
- checkbutton $e.update -text " " -relief flat \
- -variable expr_update_list($expr_num)
- text $e.expr -width 20 -height 1
- $e.expr insert 0.0 $expr
- bind $e.expr <1> "update_expr $expr_num"
- text $e.val -width 20 -height 1
+ # Set up some bindings.
+ foreach frame {updates expressions values} {
+ bind $e.$frame.$f <FocusIn> "expr_update_button $expr_num"
+ bind $e.$frame.$f <FocusOut> "expr_update_button 0"
+ }
- update_expr $expr_num
+ update_expr $expr_num
- pack $e.update -side left -anchor nw
- pack $e.expr $e.val -side left -expand yes -fill x
-
- pack $e -side top -fill x -anchor w
+ pack $e.updates.$f -side top
+ pack $e.expressions.$f -side top -expand yes -fill x
+ pack $e.values.$f -side top -expand yes -fill x
}
-set delete_expr_flag 0
-
-# This is a krock!!!
-
proc delete_expr {} {
- global delete_expr_flag
+ global delete_expr_num
+ global expr_update_list
- if {$delete_expr_flag == 1} {
- set delete_expr_flag 0
- tk_butUp .expr.delete
- bind .expr.delete <Any-Leave> {}
- } else {
- set delete_expr_flag 1
- bind .expr.delete <Any-Leave> do_nothing
- tk_butDown .expr.delete
- }
+ 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
+ unset expr_update_list($delete_expr_num)
+ }
}
proc update_expr {expr_num} {
- global delete_expr_flag
- global expr_update_list
+ global expr_update_list
- set e .expr.e${expr_num}
+ set e .expr.exprs
+ set f e${expr_num}
- if {$delete_expr_flag == 1} {
- set delete_expr_flag 0
- destroy $e
- tk_butUp .expr.delete
- tk_butLeave .expr.delete
- bind .expr.delete <Any-Leave> {}
- unset expr_update_list($expr_num)
- return
- }
-
- set expr [$e.expr get 0.0 end]
-
- $e.val delete 0.0 end
- if [catch "gdb_eval $expr" val] {
-
- } else {
- $e.val insert 0.0 $val
- }
+ set expr [$e.expressions.$f get 0.0 end]
+ $e.values.$f delete 0.0 end
+ if {! [catch {gdb_eval $expr} val]} {
+ $e.values.$f insert 0.0 $val
+ } {
+ # FIXME consider flashing widget here.
+ }
}
proc update_exprs {} {
global expr_update_list
foreach expr_num [array names expr_update_list] {
- if $expr_update_list($expr_num) {
+ if {$expr_update_list($expr_num)} {
update_expr $expr_num
}
}
}
-proc create_expr_win {} {
-
- if [winfo exists .expr] {raise .expr ; return}
+proc create_expr_window {} {
+ global expr_num
+ global delete_expr_num
+ global expr_update_list
- toplevel .expr
- wm minsize .expr 1 1
- wm title .expr Expression
- wm iconname .expr "Reg config"
+ if {[winfo exists .expr]} {raise .expr ; return}
- frame .expr.entryframe
+ # 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
- entry .expr.entry -borderwidth 2 -relief sunken
- bind .expr <Enter> {focus .expr.entry}
- bind .expr.entry <Key-Return> {add_expr [.expr.entry get]
- .expr.entry delete 0 end }
+ toplevel .expr
+ wm title .expr "GDB Expressions"
+ wm iconname .expr "Expressions"
- label .expr.entrylab -text "Expression: "
+ frame .expr.entryframe -borderwidth 2 -relief raised
+ label .expr.entryframe.entrylab -text "Expression: "
+ entry .expr.entryframe.entry -borderwidth 2 -relief sunken
+ bind .expr.entryframe.entry <Return> {
+ add_expr [.expr.entryframe.entry get]
+ .expr.entryframe.entry delete 0 end
+ }
- pack .expr.entrylab -in .expr.entryframe -side left
- pack .expr.entry -in .expr.entryframe -side left -fill x -expand yes
+ pack .expr.entryframe.entrylab -side left
+ pack .expr.entryframe.entry -side left -fill x -expand yes
- frame .expr.buts
+ frame .expr.buts -borderwidth 2 -relief raised
- button .expr.delete -text Delete
- bind .expr.delete <1> delete_expr
+ button .expr.buts.delete -text Delete -command delete_expr \
+ -state disabled
- button .expr.close -text Close -command {destroy .expr}
+ button .expr.buts.close -text Close -command {destroy .expr}
+ button .expr.buts.help -text Help -state disabled
- pack .expr.delete -side left -fill x -expand yes -in .expr.buts
- pack .expr.close -side right -fill x -expand yes -in .expr.buts
+ pack .expr.buts.delete -side left
+ pack .expr.buts.help .expr.buts.close -side right
pack .expr.buts -side bottom -fill x
pack .expr.entryframe -side bottom -fill x
- frame .expr.labels
+ frame .expr.exprs -borderwidth 2 -relief raised
+
+ # Use three subframes so columns will line up. Easier than
+ # dealing with BLT for a table geometry manager. Someday Tk
+ # will have one, use it then. FIXME this messes up keyboard
+ # traversal.
+ frame .expr.exprs.updates -borderwidth 0 -relief flat
+ frame .expr.exprs.expressions -borderwidth 0 -relief flat
+ frame .expr.exprs.values -borderwidth 0 -relief flat
- label .expr.updlab -text Update
- label .expr.exprlab -text Expression
- label .expr.vallab -text Value
+ label .expr.exprs.updates.label -text Update
+ pack .expr.exprs.updates.label -side top -anchor w
+ label .expr.exprs.expressions.label -text Expression
+ pack .expr.exprs.expressions.label -side top -anchor w
+ label .expr.exprs.values.label -text Value
+ pack .expr.exprs.values.label -side top -anchor w
- pack .expr.updlab -side left -in .expr.labels
- pack .expr.exprlab .expr.vallab -side left -in .expr.labels -expand yes -anchor w
+ pack .expr.exprs.updates -side left
+ pack .expr.exprs.values .expr.exprs.expressions \
+ -side right -expand 1 -fill x
- pack .expr.labels -side top -fill x -anchor w
+ pack .expr.exprs -side top -fill both -expand 1 -anchor w
}
#
#
proc display_expression {expression} {
- create_expr_win
+ create_expr_window
add_expr $expression
}
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.
# Open the file, and read it into the text widget
- if [catch "open $filename" fh] {
+ if {[catch "open $filename" fh]} {
# File can't be read. Put error message into .src.nofile window and return.
catch {destroy .src.nofile}
- text .src.nofile -height 25 -width 88 -relief raised \
- -borderwidth 2 -yscrollcommand textscrollproc \
+ text .src.nofile -height 25 -width 88 -relief sunken \
+ -borderwidth 2 -yscrollcommand ".src.scroll set" \
-setgrid true -cursor hand2
.src.nofile insert 0.0 $fh
.src.nofile configure -state disabled
# Actually create and do basic configuration on the text widget.
- text $win -height 25 -width 88 -relief raised -borderwidth 2 \
- -yscrollcommand textscrollproc -setgrid true -cursor hand2
+ text $win -height 25 -width 88 -relief sunken -borderwidth 2 \
+ -yscrollcommand ".src.scroll set" -setgrid true -cursor hand2
# Setup all the bindings
bind $win <Enter> {focus %W}
-# bind $win <1> {listing_window_button_1 %W %X %Y %x %y}
bind $win <1> do_nothing
bind $win <B1-Motion> do_nothing
- bind $win n {catch {gdb_cmd next} ; update_ptr}
- bind $win s {catch {gdb_cmd step} ; update_ptr}
- bind $win c {catch {gdb_cmd continue} ; update_ptr}
- bind $win f {catch {gdb_cmd finish} ; update_ptr}
- bind $win u {catch {gdb_cmd up} ; update_ptr}
- bind $win d {catch {gdb_cmd down} ; update_ptr}
+ bind $win <Key-Alt_R> do_nothing
+ bind $win <Key-Alt_L> do_nothing
+ bind $win <Key-Prior> "$win yview {@0,0 - 10 lines}"
+ bind $win <Key-Next> "$win yview {@0,0 + 10 lines}"
+ bind $win <Key-Up> "$win yview {@0,0 - 1 lines}"
+ bind $win <Key-Down> "$win yview {@0,0 + 1 lines}"
+ bind $win <Key-Home> {update_listing [gdb_loc]}
+ bind $win <Key-End> "$win see end"
+
+ bind $win n {interactive_cmd next}
+ bind $win s {interactive_cmd step}
+ bind $win c {interactive_cmd continue}
+ bind $win f {interactive_cmd finish}
+ 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]
set numlines [$win index end]
set numlines [lindex [split $numlines .] 0]
- if $line_numbers {
+ if {$line_numbers} {
for {set i 1} {$i <= $numlines} {incr i} {
$win insert $i.0 [format " %4d " $i]
$win tag add source $i.8 "$i.0 lineend"
$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
proc create_asm_win {funcname pc} {
global breakpoint_file
global breakpoint_line
- global current_output_win
global pclist
global disassemble_with_source
# Actually create and do basic configuration on the text widget.
- text $win -height 25 -width 80 -relief raised -borderwidth 2 \
- -setgrid true -cursor hand2 -yscrollcommand asmscrollproc
+ text $win -height 25 -width 80 -relief sunken -borderwidth 2 \
+ -setgrid true -cursor hand2 -yscrollcommand ".asm.scroll set"
# 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 n {catch {gdb_cmd nexti} ; update_ptr}
- bind $win s {catch {gdb_cmd stepi} ; update_ptr}
- bind $win c {catch {gdb_cmd continue} ; update_ptr}
- bind $win f {catch {gdb_cmd finish} ; update_ptr}
- bind $win u {catch {gdb_cmd up} ; update_ptr}
- bind $win d {catch {gdb_cmd down} ; update_ptr}
+ 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
+
+ bind $win n {interactive_cmd nexti}
+ bind $win s {interactive_cmd stepi}
+ bind $win c {interactive_cmd continue}
+ bind $win f {interactive_cmd finish}
+ bind $win u {interactive_cmd up}
+ bind $win d {interactive_cmd down}
# Disassemble the code, and read it into the new text widget
- set temp $current_output_win
- set current_output_win $win
- catch "gdb_disassemble $disassemble_with_source $pc"
- set current_output_win $temp
+ $win insert end [gdb_disassemble $disassemble_with_source $pc]
set numlines [$win index end]
set numlines [lindex [split $numlines .] 0]
return $win
}
-#
-# Local procedure:
-#
-# asmscrollproc (WINHEIGHT SCREENHEIGHT SCREENTOP SCREENBOT) - Update the
-# asm window scrollbar.
-#
-# Description:
-#
-# This procedure is called to update the assembler window's scrollbar.
-#
-
-proc asmscrollproc {args} {
- global asm_screen_height asm_screen_top asm_screen_bot
-
- eval ".asm.scroll set $args"
- set asm_screen_height [lindex $args 1]
- set asm_screen_top [lindex $args 2]
- set asm_screen_bot [lindex $args 3]
-}
-
#
# Local procedure:
#
proc update_listing {linespec} {
global pointers
- global screen_height
- global screen_top
- global screen_bot
global wins cfile
global current_label
global win_to_file
# Rip the linespec apart
- set line [lindex $linespec 3]
- set filename [lindex $linespec 2]
- set funcname [lindex $linespec 1]
- set debug_file [lindex $linespec 0]
+ lassign $linespec debug_file funcname filename line
# Sometimes there's no source file for this location
# Create a text widget for this file if necessary
- if ![info exists wins($cfile)] then {
+ if {![info exists wins($cfile)]} then {
set wins($cfile) [create_file_win $cfile $debug_file]
if {$wins($cfile) != ".src.nofile"} {
set win_to_file($wins($cfile)) $cfile
.src.scroll configure -command "$wins($cfile) yview"
- $wins($cfile) yview [expr $line - $screen_height / 2]
+ # $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
# Update the pointer, scrolling the text widget if necessary to keep the
# pointer in an acceptable part of the screen.
- if [info exists pointers($cfile)] then {
+ if {[info exists pointers($cfile)]} then {
$wins($cfile) configure -state normal
set pointer_pos $pointers($cfile)
$wins($cfile) configure -state normal
$wins($cfile) delete $pointer_pos "$pointer_pos + 2 char"
$wins($cfile) insert $pointer_pos "->"
-
- if {$line < $screen_top + 1
- || $line > $screen_bot} then {
- $wins($cfile) yview [expr $line - $screen_height / 2]
- }
-
+ ensure_line_visible $wins($cfile) $line
$wins($cfile) configure -state disabled
}
}
proc create_asm_window {} {
global cfunc
- if [winfo exists .asm] {raise .asm ; return}
+ if {[winfo exists .asm]} {raise .asm ; return}
set cfunc *None*
set win [asm_win_name $cfunc]
.asm.menubar.view.menu delete 0 last
- .asm.text configure -yscrollcommand asmscrollproc
+ .asm.text configure -yscrollcommand ".asm.scroll set"
frame .asm.row1
frame .asm.row2
button .asm.stepi -width 6 -text Stepi \
- -command {catch {gdb_cmd stepi} ; update_ptr}
+ -command {interactive_cmd stepi}
button .asm.nexti -width 6 -text Nexti \
- -command {catch {gdb_cmd nexti} ; update_ptr}
+ -command {interactive_cmd nexti}
button .asm.continue -width 6 -text Cont \
- -command {catch {gdb_cmd continue} ; update_ptr}
+ -command {interactive_cmd continue}
button .asm.finish -width 6 -text Finish \
- -command {catch {gdb_cmd finish} ; update_ptr}
- button .asm.up -width 6 -text Up -command {catch {gdb_cmd up} ; update_ptr}
+ -command {interactive_cmd finish}
+ button .asm.up -width 6 -text Up -command {interactive_cmd up}
button .asm.down -width 6 -text Down \
- -command {catch {gdb_cmd down} ; update_ptr}
+ -command {interactive_cmd down}
button .asm.bottom -width 6 -text Bottom \
- -command {catch {gdb_cmd {frame 0}} ; update_ptr}
+ -command {interactive_cmd {frame 0}}
pack .asm.stepi .asm.continue .asm.up .asm.bottom -side left -padx 3 -pady 5 -in .asm.row1
pack .asm.nexti .asm.finish .asm.down -side left -padx 3 -pady 5 -in .asm.row2
#
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}
- .reg.menubar.view.menu delete 0 last
+ # 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}
-# Hex menu item
- .reg.menubar.view.menu add radiobutton -label Hex \
- -command {set reg_format x ; update_registers all}
+ # 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}
-# Decimal menu item
- .reg.menubar.view.menu add radiobutton -label Decimal \
- -command {set reg_format d ; 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}
-# Octal menu item
- .reg.menubar.view.menu add radiobutton -label Octal \
- -command {set reg_format o ; 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}
-# Natural menu item
- .reg.menubar.view.menu add radiobutton -label Natural \
- -command {set reg_format {} ; 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}
-# 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
+ destroy .reg.label
-# Install the reg names
+ # Install the reg names
- populate_reg_window
- update_registers all
+ 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
+
+ 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
+ }
+
+ 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
+ }
+
+ 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
}
#
proc update_assembly {linespec} {
global asm_pointers
- global screen_height
- global screen_top
- global screen_bot
global wins cfunc
global current_label
global win_to_file
global file_to_debug_file
global current_asm_label
global pclist
- global asm_screen_height asm_screen_top asm_screen_bot
global .asm.label
# Rip the linespec apart
- set pc [lindex $linespec 4]
- set line [lindex $linespec 3]
- set filename [lindex $linespec 2]
- set funcname [lindex $linespec 1]
- set debug_file [lindex $linespec 0]
+ lassign $linespec debug_file funcname filename line pc
set win [asm_win_name $cfunc]
-after .asm.scroll
.asm.scroll configure -command "$win yview"
set line [pc_to_line $pclist($cfunc) $pc]
+ ensure_line_visible $win $line
update
- $win yview [expr $line - $asm_screen_height / 2]
}
# Update the label widget in case the filename or function name has changed
# Update the pointer, scrolling the text widget if necessary to keep the
# pointer in an acceptable part of the screen.
- if [info exists asm_pointers($cfunc)] then {
+ if {[info exists asm_pointers($cfunc)]} then {
$win configure -state normal
set pointer_pos $asm_pointers($cfunc)
$win configure -state normal
$win delete $pointer_pos "$pointer_pos + 2 char"
$win insert $pointer_pos "->"
-
- if {$line < $asm_screen_top + 1
- || $line > $asm_screen_bot} then {
- $win yview [expr $line - $asm_screen_height / 2]
- }
-
+ ensure_line_visible $win $line
$win configure -state disabled
}
}
proc update_ptr {} {
update_listing [gdb_loc]
- if [winfo exists .asm] {
+ if {[winfo exists .asm]} {
update_assembly [gdb_loc]
}
- if [winfo exists .reg] {
+ if {[winfo exists .reg]} {
update_registers changed
}
- if [winfo exists .expr] {
+ if {[winfo exists .expr]} {
update_exprs
}
+ if {[winfo exists .autocmd]} {
+ update_autocmd
+ }
}
# Make toplevel window disappear
wm withdraw .
proc files_command {} {
- toplevel .files_window
-
- wm minsize .files_window 1 1
-# wm overrideredirect .files_window true
- listbox .files_window.list -geometry 30x20 -setgrid true \
- -yscrollcommand {.files_window.scroll set} -relief raised \
- -borderwidth 2
- scrollbar .files_window.scroll -orient vertical \
- -command {.files_window.list yview}
- button .files_window.close -text Close -command {destroy .files_window}
- tk_listboxSingleSelect .files_window.list
-
-# Get the file list from GDB, sort it, and format it as one entry per line.
-
- set filelist [join [lsort [gdb_listfiles]] "\n"]
-
-# Now, remove duplicates (by using uniq)
-
- set fh [open "| uniq > /tmp/gdbtk.[pid]" w]
- puts $fh $filelist
- close $fh
- set fh [open /tmp/gdbtk.[pid]]
- set filelist [split [read $fh] "\n"]
- set filelist [lrange $filelist 0 [expr [llength $filelist] - 2]]
- close $fh
- exec rm /tmp/gdbtk.[pid]
-
-# Insert the file list into the widget
-
- eval .files_window.list insert 0 $filelist
-
- 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> {
- set file [%W get [%W curselection]]
- gdb_cmd "list $file:1,0"
- update_listing [gdb_loc $file:1]
- destroy .files_window}
+ toplevel .files_window
+
+ wm minsize .files_window 1 1
+ # wm overrideredirect .files_window 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 \
+ -command {.files_window.list yview} -relief sunken
+ 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 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 <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 apply_filespec {label default command} {
set filename [FSBox $label $default]
if {$filename != ""} {
- if [catch {gdb_cmd "$command $filename"} retval] {
+ if {[catch {gdb_cmd "$command $filename"} retval]} {
tk_dialog .filespec_error "gdb : $label error" \
- "Error in command \"$command $filename\"" {} 0 Dismiss
+ "Error in command \"$command $filename\"" error \
+ 0 Dismiss
return
}
update_ptr
}
}
-# Setup command window
+# Run editor.
+proc run_editor {editor file} {
+ # FIXME should use index of line in middle of window, not line at
+ # top.
+ global wins
+ set lineNo [lindex [split [$wins($file) index @0,0] .] 0]
+ exec $editor +$lineNo $file
+}
+# Setup command window
proc build_framework {win {title GDBtk} {label {}}} {
global ${win}.label
${win}.menubar.file.menu add command -label Target... \
-command { not_implemented_yet "target" }
${win}.menubar.file.menu add command -label Edit \
- -command {exec $editor +[expr ($screen_top + $screen_bot)/2] $cfile &}
+ -command {run_editor $editor $cfile}
${win}.menubar.file.menu add separator
${win}.menubar.file.menu add command -label "Exec File..." \
-command {apply_filespec {Exec File} a.out exec-file}
-command "destroy ${win}"
${win}.menubar.file.menu add separator
${win}.menubar.file.menu add command -label Quit \
- -command { catch { gdb_cmd quit } }
+ -command {interactive_cmd quit}
menubutton ${win}.menubar.commands -padx 12 -text Commands \
-menu ${win}.menubar.commands.menu -underline 0
menu ${win}.menubar.commands.menu
${win}.menubar.commands.menu add command -label Run \
- -command { catch {gdb_cmd run } ; update_ptr }
+ -command {interactive_cmd run}
${win}.menubar.commands.menu add command -label Step \
- -command { catch { gdb_cmd step } ; update_ptr }
+ -command {interactive_cmd step}
${win}.menubar.commands.menu add command -label Next \
- -command { catch { gdb_cmd next } ; update_ptr }
+ -command {interactive_cmd next}
${win}.menubar.commands.menu add command -label Continue \
- -command { catch { gdb_cmd continue } ; update_ptr }
+ -command {interactive_cmd continue}
${win}.menubar.commands.menu add separator
${win}.menubar.commands.menu add command -label Stepi \
- -command { catch { gdb_cmd stepi } ; update_ptr }
+ -command {interactive_cmd stepi}
${win}.menubar.commands.menu add command -label Nexti \
- -command { catch { gdb_cmd nexti } ; update_ptr }
+ -command {interactive_cmd nexti}
menubutton ${win}.menubar.view -padx 12 -text Options \
-menu ${win}.menubar.view.menu -underline 0
-command create_command_window
${win}.menubar.window.menu add separator
${win}.menubar.window.menu add command -label Source \
- -command {create_source_window ; update_ptr}
+ -command create_source_window
${win}.menubar.window.menu add command -label Assembly \
- -command {create_asm_window ; update_ptr}
+ -command create_asm_window
${win}.menubar.window.menu add separator
${win}.menubar.window.menu add command -label Registers \
- -command {create_registers_window ; update_ptr}
+ -command create_registers_window
${win}.menubar.window.menu add command -label Expressions \
- -command {create_expr_win ; update_ptr}
+ -command create_expr_window
+ ${win}.menubar.window.menu add command -label "Auto Command" \
+ -command create_autocmd_window
+ ${win}.menubar.window.menu add command -label Breakpoints \
+ -command create_breakpoints_window
# ${win}.menubar.window.menu add separator
# ${win}.menubar.window.menu add command -label Files \
${win}.menubar.help.menu add command -label "Report bug" \
-command {exec send-pr}
- tk_menuBar ${win}.menubar \
- ${win}.menubar.file \
- ${win}.menubar.view \
- ${win}.menubar.window \
- ${win}.menubar.help
pack ${win}.menubar.file \
${win}.menubar.view \
${win}.menubar.window -side left
pack ${win}.menubar.help -side right
frame ${win}.info
- text ${win}.text -height 25 -width 80 -relief raised -borderwidth 2 \
+ text ${win}.text -height 25 -width 80 -relief sunken -borderwidth 2 \
-setgrid true -cursor hand2 -yscrollcommand "${win}.scroll set"
set ${win}.label $label
- label ${win}.label -textvariable ${win}.label -borderwidth 2 -relief raised
+ label ${win}.label -textvariable ${win}.label -borderwidth 2 -relief sunken
- scrollbar ${win}.scroll -orient vertical -command "${win}.text yview"
+ scrollbar ${win}.scroll -orient vertical -command "${win}.text yview" \
+ -relief sunken
+
+ bind $win <Key-Alt_R> do_nothing
+ bind $win <Key-Alt_L> do_nothing
pack ${win}.label -side bottom -fill x -in ${win}.info
pack ${win}.scroll -side right -fill y -in ${win}.info
global wins
global cfile
- if [winfo exists .src] {raise .src ; return}
+ if {[winfo exists .src]} {raise .src ; return}
build_framework .src Source "*No file*"
frame .src.row2
button .src.start -width 6 -text Start -command \
- {catch {gdb_cmd {break main}}
- catch {gdb_cmd {enable delete $bpnum}}
- catch {gdb_cmd run}
- update_ptr }
+ {interactive_cmd {break main}
+ interactive_cmd {enable delete $bpnum}
+ interactive_cmd run }
button .src.stop -width 6 -text Stop -fg red -activeforeground red \
-state disabled -command gdb_stop
button .src.step -width 6 -text Step \
- -command {catch {gdb_cmd step} ; update_ptr}
+ -command {interactive_cmd step}
button .src.next -width 6 -text Next \
- -command {catch {gdb_cmd next} ; update_ptr}
+ -command {interactive_cmd next}
button .src.continue -width 6 -text Cont \
- -command {catch {gdb_cmd continue} ; update_ptr}
+ -command {interactive_cmd continue}
button .src.finish -width 6 -text Finish \
- -command {catch {gdb_cmd finish} ; update_ptr}
+ -command {interactive_cmd finish}
button .src.up -width 6 -text Up \
- -command {catch {gdb_cmd up} ; update_ptr}
+ -command {interactive_cmd up}
button .src.down -width 6 -text Down \
- -command {catch {gdb_cmd down} ; update_ptr}
+ -command {interactive_cmd down}
button .src.bottom -width 6 -text Bottom \
- -command {catch {gdb_cmd {frame 0}} ; update_ptr}
+ -command {interactive_cmd {frame 0}}
pack .src.start .src.step .src.continue .src.up .src.bottom \
-side left -padx 3 -pady 5 -in .src.row1
$wins($cfile) insert 0.0 " This page intentionally left blank."
$wins($cfile) configure -width 88 -state disabled \
- -yscrollcommand textscrollproc
+ -yscrollcommand ".src.scroll set"
+}
+
+proc update_autocmd {} {
+ global .autocmd.label
+ global accumulate_output
+
+ catch {gdb_cmd "${.autocmd.label}"} result
+ if {!$accumulate_output} { .autocmd.text delete 0.0 end }
+ .autocmd.text insert end $result
+ .autocmd.text see end
+}
+
+proc create_autocmd_window {} {
+ global .autocmd.label
+
+ if {[winfo exists .autocmd]} {raise .autocmd ; return}
+
+ build_framework .autocmd "Auto Command" ""
+
+ # First, delete all the old view menu entries
+
+ .autocmd.menubar.view.menu delete 0 last
+
+ # Accumulate output option
- proc textscrollproc {args} {global screen_height screen_top screen_bot
- eval ".src.scroll set $args"
- set screen_height [lindex $args 1]
- set screen_top [lindex $args 2]
- set screen_bot [lindex $args 3]}
+ .autocmd.menubar.view.menu add checkbutton \
+ -variable accumulate_output \
+ -label "Accumulate output" -onvalue 1 -offvalue 0
+
+ # Now, create entry widget with label
+
+ frame .autocmd.entryframe
+
+ entry .autocmd.entry -borderwidth 2 -relief sunken
+ bind .autocmd.entry <Key-Return> {
+ set .autocmd.label [.autocmd.entry get]
+ .autocmd.entry delete 0 end
+ }
+
+ label .autocmd.entrylab -text "Command: "
+
+ pack .autocmd.entrylab -in .autocmd.entryframe -side left
+ pack .autocmd.entry -in .autocmd.entryframe -side left -fill x -expand yes
+
+ pack .autocmd.entryframe -side bottom -fill x -before .autocmd.info
+}
+
+# Return the longest common prefix in SLIST. Can be empty string.
+
+proc find_lcp slist {
+# Handle trivial cases where list is empty or length 1
+ if {[llength $slist] <= 1} {return [lindex $slist 0]}
+
+ set prefix [lindex $slist 0]
+ set prefixlast [expr [string length $prefix] - 1]
+
+ foreach str [lrange $slist 1 end] {
+ set test_str [string range $str 0 $prefixlast]
+ while {[string compare $test_str $prefix] != 0} {
+ decr prefixlast
+ set prefix [string range $prefix 0 $prefixlast]
+ set test_str [string range $str 0 $prefixlast]
+ }
+ if {$prefixlast < 0} break
+ }
+ return $prefix
+}
+
+# Look through COMPLETIONS to generate the suffix needed to do command
+# completion on CMD.
+
+proc find_completion {cmd completions} {
+# Get longest common prefix
+ set lcp [find_lcp $completions]
+ set cmd_len [string length $cmd]
+# Return suffix beyond end of cmd
+ return [string range $lcp $cmd_len end]
}
proc create_command_window {} {
global command_line
+ global saw_tab
+ global gdb_prompt
- if [winfo exists .cmd] {raise .cmd ; return}
+ set saw_tab 0
+ if {[winfo exists .cmd]} {raise .cmd ; return}
build_framework .cmd Command "* Command Buffer *"
+ # Put focus on command area.
+ focus .cmd.text
+
set command_line {}
gdb_cmd {set language c}
gdb_cmd {set height 0}
gdb_cmd {set width 0}
- bind .cmd.text <Enter> {focus %W}
- bind .cmd.text <Delete> {delete_char %W}
- bind .cmd.text <BackSpace> {delete_char %W}
- bind .cmd.text <Control-u> {delete_line %W}
- bind .cmd.text <Any-Key> {
- global command_line
+ bind .cmd.text <Control-c> gdb_stop
- %W insert end %A
- %W yview -pickplace end
- append command_line %A
- }
+ # 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> {
+ 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
+ append command_line %A
+ break
+ }
bind .cmd.text <Key-Return> {
- global command_line
-
- %W insert end \n
- %W yview -pickplace end
- catch "gdb_cmd [list $command_line]"
- set command_line {}
- update_ptr
- %W insert end "(gdb) "
- %W yview -pickplace end
- }
+ if {([%W cget -state] == "disabled")} { break }
+ set saw_tab 0
+ %W insert end \n
+ interactive_cmd $command_line
+
+ # %W see end
+ # catch "gdb_cmd [list $command_line]" result
+ # %W insert end $result
+ set command_line {}
+ # update_ptr
+ %W insert end "$gdb_prompt"
+ %W see end
+ break
+ }
bind .cmd.text <Button-2> {
- global command_line
+ %W insert end [selection get]
+ %W see end
+ 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]
+
+ # Just do completion if this is the first tab
+ if {!$saw_tab} {
+ set saw_tab 1
+ set completion [find_completion $command_line $choices]
+ append command_line $completion
+ # Here is where the completion is actually done. If there
+ # is one match, complete the command and print a space.
+ # If two or more matches, complete the command and beep.
+ # If no match, just beep.
+ switch [llength $choices] {
+ 0 {}
+ 1 {
+ %W insert end "$completion "
+ append command_line " "
+ return
+ }
- %W insert end [selection get]
- %W yview -pickplace end
- append command_line [selection get]
+ default {
+ %W insert end $completion
+ }
+ }
+ bell
+ %W see end
+ } else {
+ # User hit another consecutive tab. List the choices.
+ # Note that at this point, choices may contain commands
+ # with spaces. We have to lop off everything before (and
+ # including) the last space so that the completion list
+ # only shows the possibilities for the last token.
+ set choices [lsort $choices]
+ if {[regexp ".* " $command_line prefix]} {
+ regsub -all $prefix $choices {} choices
+ }
+ %W insert end "\n[join $choices { }]\n$gdb_prompt$command_line"
+ %W see end
+ }
+ break
}
- proc delete_char {win} {
- global command_line
+}
- tk_textBackspace $win
- $win yview -pickplace insert
- set tmp [expr [string length $command_line] - 2]
- set command_line [string range $command_line 0 $tmp]
- }
- proc delete_line {win} {
- global command_line
+# Trim one character off the command line. The argument is ignored.
- $win delete {end linestart + 6 chars} end
- $win yview -pickplace insert
- set command_line {}
- }
+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 gdb_prompt
+
+ set tmp [string length $gdb_prompt]
+ $win delete "insert linestart + $tmp chars" "insert lineend"
+ $win see insert
+ set command_line {}
}
#
""}} {
global fileselect
set w .fileSelect
- if [Exwin_Toplevel $w "Select File" FileSelect] {
+ if {[Exwin_Toplevel $w "Select File" FileSelect]} {
# path independent names for the widgets
set fileselect(list) $w.file.sframe.list
bind $fileselect(direntry) <Return> [list fileselect.list.cmd %W]
bind $fileselect(direntry) <Tab> [list fileselect.tab.dircmd]
bind $fileselect(entry) <Tab> [list fileselect.tab.filecmd]
-
- tk_listboxSingleSelect $fileselect(list)
-
-
+
+ $fileselect(list) configure -selectmode single
+
bind $fileselect(list) <Button-1> {
# puts stderr "button 1 release"
- %W select from [%W nearest %y]
$fileselect(entry) delete 0 end
$fileselect(entry) insert 0 [%W get [%W nearest %y]]
}
bind $fileselect(list) <Key> {
- %W select from [%W nearest %y]
$fileselect(entry) delete 0 end
$fileselect(entry) insert 0 [%W get [%W nearest %y]]
}
bind $fileselect(list) <Double-ButtonPress-1> {
# puts stderr "double button 1"
- %W select from [%W nearest %y]
$fileselect(entry) delete 0 end
$fileselect(entry) insert 0 [%W get [%W nearest %y]]
$fileselect(ok) invoke
}
bind $fileselect(list) <Return> {
- %W select from [%W nearest %y]
$fileselect(entry) delete 0 end
$fileselect(entry) insert 0 [%W get [%W nearest %y]]
$fileselect(ok) invoke
proc fileselect.cd { dir } {
global fileselect
- if [catch {cd $dir} err] {
+ if {[catch {cd $dir} err]} {
fileselect.yck $dir
cd
}
global fileselect
$fileselect(msg) configure -text "Yck! $tag"
}
+
proc fileselect.ok {} {
global fileselect
$fileselect(msg) configure -text $fileselect(text)
}
fileselect.ok
update idletasks
- if [file isdirectory $dir] {
+ if {[file isdirectory $dir]} {
fileselect.getfiles $dir $pat $state
focus $fileselect(entry)
} else {
set selname [$fileselect(entry) get]
set seldir [$fileselect(direntry) get]
- if [string match /* $selname] {
+ if {[string match /* $selname]} {
set selected $selname
} else {
- if [string match ~* $selname] {
+ if {[string match ~* $selname]} {
set selected $selname
} else {
set selected $seldir/$selname
}
# some nasty file names may cause "file isdirectory" to return an error
- if [catch {file isdirectory $selected} isdir] {
+ if {[catch {file isdirectory $selected} isdir]} {
fileselect.yck "isdirectory failed"
return
}
- if [catch {glob $selected} globlist] {
- if ![file isdirectory [file dirname $selected]] {
+ if {[catch {glob $selected} globlist]} {
+ if {![file isdirectory [file dirname $selected]]} {
fileselect.yck "bad pathname"
return
}
} else {
set selected $globlist
}
- if [file isdirectory $selected] {
+ if {[file isdirectory $selected]} {
fileselect.getfiles $selected $fileselect(pattern)
$fileselect(entry) delete 0 end
return
set currentDir [pwd]
fileselect.cd $dir
- if [catch {set files [lsort [glob -nocomplain $pat]]} err] {
+ if {[catch {set files [lsort [glob -nocomplain $pat]]} err]} {
$fileselect(msg) configure -text $err
$fileselect(list) delete 0 end
update idletasks
# build a reordered list of the files: directories are displayed first
# and marked with a trailing "/"
- if [string compare $dir /] {
+ if {[string compare $dir /]} {
fileselect.putfiles $files [expr {($pat == "*") ? 1 : 0}]
} else {
fileselect.putfiles $files
destroy $w
return $fileExists(ok)
}
+
proc FileExistsCancel {} {
global fileExists
set fileExists(ok) 0
}
+
proc FileExistsOK {} {
global fileExists
set fileExists(ok) 1
} else {
set path [$fileselect(entry) get]
}
- if [catch {set listFile [glob -nocomplain $path*]}] {
+ if {[catch {set listFile [glob -nocomplain $path*]}]} {
return $returnList
}
foreach el $listFile {
if {$dir != 0} {
- if [file isdirectory $el] {
+ if {[file isdirectory $el]} {
lappend returnList [file tail $el]
}
- } elseif ![file isdirectory $el] {
+ } elseif {![file isdirectory $el]} {
lappend returnList [file tail $el]
}
}
}
return $returnHead
}
-
+
+# FIXME this function is a crock. Can write tilde expanding function
+# in terms of glob and quote_glob; do so.
proc fileselect.expand.tilde { } {
global fileselect
set listmatch {}
## look in /etc/passwd
- if [file exists /etc/passwd] {
- if [catch {set users [exec cat /etc/passwd | sed s/:.*//]} err] {
+ if {[file exists /etc/passwd]} {
+ if {[catch {set users [exec cat /etc/passwd | sed s/:.*//]} err]} {
puts "Error\#1 $err"
return
}
set list [split $users "\n"]
}
if {[lsearch -exact $list "+"] != -1} {
- if [catch {set users [exec ypcat passwd | sed s/:.*//]} err] {
+ if {[catch {set users [exec ypcat passwd | sed s/:.*//]} err]} {
puts "Error\#2 $err"
return
}
}
$fileselect(list) delete 0 end
foreach el $list {
- if [string match $dir* $el] {
+ if {[string match $dir* $el]} {
lappend listmatch $el
$fileselect(list) insert end $el
}
if {$dir == ""} {
$fileselect(direntry) delete 0 end
$fileselect(direntry) insert 0 [pwd]
- if [string compare [pwd] "/"] {
+ if {[string compare [pwd] "/"]} {
$fileselect(direntry) insert end /
}
return
}
- if [catch {set tmp [file isdirectory [file dirname $dir]]}] {
+ if {[catch {set tmp [file isdirectory [file dirname $dir]]}]} {
if {[string index $dir 0] == "~"} {
fileselect.expand.tilde
}
return
}
set dirFile [fileselect.getfiledir 1 $dir]
- if ![llength $dirFile] {
+ if {![llength $dirFile]} {
return
}
if {[llength $dirFile] == 1} {
$fileselect(direntry) delete 0 end
$fileselect(direntry) insert 0 [file dirname $dir]
- if [string compare [file dirname $dir] /] {
+ if {[string compare [file dirname $dir] /]} {
$fileselect(direntry) insert end /[lindex $dirFile 0]/
} else {
$fileselect(direntry) insert end [lindex $dirFile 0]/
set headFile [fileselect.gethead $dirFile]
$fileselect(direntry) delete 0 end
$fileselect(direntry) insert 0 [file dirname $dir]
- if [string compare [file dirname $dir] /] {
+ if {[string compare [file dirname $dir] /]} {
$fileselect(direntry) insert end /$headFile
} else {
$fileselect(direntry) insert end $headFile
}
set listFile [fileselect.getfiledir 0 $dir]
puts $listFile
- if ![llength $listFile] {
+ if {![llength $listFile]} {
return
}
if {[llength $listFile] == 1} {
proc Exwin_Toplevel { path name {class Dialog} {dismiss yes}} {
global exwin
- if [catch {wm state $path} state] {
+ if {[catch {wm state $path} state]} {
set t [Widget_Toplevel $path $name $class]
- if ![info exists exwin(toplevels)] {
+ if {![info exists exwin(toplevels)]} {
set exwin(toplevels) [option get . exwinPaths {}]
}
set ix [lsearch $exwin(toplevels) $t]
set self [toplevel $path -class $class]
set usergeo [option get $path position Position]
if {$usergeo != {}} {
- if [catch {wm geometry $self $usergeo} err] {
+ if {[catch {wm geometry $self $usergeo} err]} {
# Exmh_Debug Widget_Toplevel $self $usergeo => $err
}
} else {
proc Widget_AddBut {par but txt cmd {where {right padx 1}} } {
# Create a Packed button. Return the button pathname
set cmd2 [list button $par.$but -text $txt -command $cmd]
- if [catch $cmd2 t] {
+ if {[catch $cmd2 t]} {
puts stderr "Widget_AddBut (warning) $t"
eval $cmd2 {-font fixed}
}
pack append $par $par.$but $where
return $par.$but
}
+
proc Widget_CheckBut {par but txt var {where {right padx 1}} } {
# Create a check button. Return the button pathname
set cmd [list checkbutton $par.$but -text $txt -variable $var]
- if [catch $cmd t] {
+ if {[catch $cmd t]} {
puts stderr "Widget_CheckBut (warning) $t"
eval $cmd {-font fixed}
}
proc Widget_Label { frame {name label} {where {left fill}} args} {
set cmd [list label $frame.$name ]
- if [catch [concat $cmd $args] t] {
+ if {[catch [concat $cmd $args] t]} {
puts stderr "Widget_Label (warning) $t"
eval $cmd $args {-font fixed}
}
pack append $frame $frame.$name $where
return $frame.$name
}
+
proc Widget_Entry { frame {name entry} {where {left fill}} args} {
set cmd [list entry $frame.$name ]
- if [catch [concat $cmd $args] t] {
+ if {[catch [concat $cmd $args] t]} {
puts stderr "Widget_Entry (warning) $t"
eval $cmd $args {-font fixed}
}
# End of fileselect.tcl.
-# Setup the initial windows
+#
+# Create a copyright window and center it on the screen. Arrange for
+# it to disappear when the user clicks it, or after a suitable period
+# of time.
+#
+proc create_copyright_window {} {
+ toplevel .c
+ message .c.m -text [gdb_cmd {show version}] -aspect 500 -relief raised
+ pack .c.m
-create_source_window
+ bind .c.m <1> {destroy .c}
+ bind .c <Leave> {destroy .c}
+ # "suitable period" currently means "30 seconds".
+ after 30000 {
+ if {[winfo exists .c]} then {
+ destroy .c
+ }
+ }
-if {[tk colormodel .src.text] == "color"} {
- set highlight "-background red2 -borderwidth 2 -relief sunk"
-} else {
- set fg [lindex [.src.text config -foreground] 4]
- set bg [lindex [.src.text config -background] 4]
- set highlight "-foreground $bg -background $fg -borderwidth 0"
+ wm transient .c .
+ center_window .c
}
-create_command_window
+# 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.
-# Create a copyright window
+proc evaluate_tcl_command { twidget } {
+ global tcl_prompt
-toplevel .c
-wm geometry .c +300+300
-wm overrideredirect .c true
+ 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
+ }
+}
-text .t
-set temp $current_output_win
-set current_output_win .t
-gdb_cmd "show version"
-set current_output_win $temp
+# Create the evaluation window and set up the keybindings to evaluate the
+# last single line entered by the user. FIXME: allow multiple lines?
-message .c.m -text [.t get 0.0 end] -aspect 500 -relief raised
-destroy .t
-pack .c.m
-bind .c.m <Leave> {destroy .c}
+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}
+}
-if [file exists ~/.gdbtkinit] {
- source ~/.gdbtkinit
+# 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"
+
+# Setup the initial windows
+create_source_window
+create_command_window
+
+# Make this last so user actually sees it.
+create_copyright_window
+# Refresh.
update
+
+if {[file exists ~/.gdbtkinit]} {
+ source ~/.gdbtkinit
+}
projects / deliverable / binutils-gdb.git / blobdiff