old-cross-binutils/gdb/gdbtk.tcl
Stu Grossman 754e5da26e * Makefile.in (INSTALLED_LIBS, CLIBS, DEPFILES): Add support for
--enable-xxx configure option by adding ENABLE_{CLIBS DEPFILES}
	where appropriate.

	* General hackery to support alternate user-interface.
	* breakpoint.c (mention, delete_breakpoint, enable_breakpoint,
	disable_breakpoint):  Call hooks for alternate user-interface.
	* defs.h:  Add declarations for alternate user-interface hooks.
	* main.c (main):  Add --nw (and --nowindows) options to disable
	the GUI.
	* (near call to command_loop):  Call command_loop_hook if set.
	* (fputs_unfiltered):  Call fputs_unfiltered_hook if set.
	* stack.c:  Call print_frame_info_listing_hook if set.
	* top.c (gdb_init):  Initialize targets.c and utils.c prior to
	other files to make sure that calls to error and warning will
	work.  Call init_ui_hook after everything else.
	* utils.c (query):  Call query_hook if set.
	* (gdb_flush):  Call flush_hook if set.
	* Change _initialize_utils to initialize_utils cuz we don't use
	automatic initialization of utils.c anymore.

	* Support for TK GUI.
	* Makefile.in:  Add rule for gdbtk.o.
	* configure.in:  Add support for --enable-gdbtk.
	* gdbtk.c:  New file.  Contains support routines for TK interface.
	* gdbtk.tcl:  New file.  Implements GUI policy.

	* remote.c:  Get rid of #ifdef DONT_USE_REMOTE.  It's no longer
	necessary.
1994-07-28 22:07:02 +00:00

399 lines
11 KiB
Tcl

# GDB GUI setup
set cfile Blank
set wins($cfile) .text
set current_label {}
set screen_height 0
set screen_top 0
set screen_bot 0
proc test {} {
update_listing {termcap.c foo /etc/termcap 200}
}
proc echo string {puts stdout $string}
proc gdbtk_tcl_fputs {arg} {
.command.text insert end "$arg"
.command.text yview -pickplace end
}
proc gdbtk_tcl_flush {} {update idletasks}
proc gdbtk_tcl_query {message} {
tk_dialog .query "gdb : query" "$message" {} 1 "No" "Yes"
}
if [info exists env(EDITOR)] then {
set editor $env(EDITOR)
} else {
set editor emacs
}
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_end_variable_annotation {} {
echo gdbtk_tcl_end_variable_annotation
}
proc insert_breakpoint_tag {win line} {
$win configure -state normal
$win delete $line.0
$win insert $line.0 "B"
$win tag add $line $line.0
$win tag bind $line <1> {
# echo "tag %W %X %Y %x"
# echo "tag names [$wins($cfile) tag names]"
}
$win configure -state disabled
}
proc delete_breakpoint_tag {win line} {
$win configure -state normal
$win delete $line.0
$win insert $line.0 " "
$win tag delete $line
$win configure -state disabled
}
# Callback from GDB to notify us of breakpoint creation.
proc create_breakpoint {bpnum file line} {
global wins
global breakpoint_file
global breakpoint_line
# Record breakpoint locations
set breakpoint_file($bpnum) $file
set breakpoint_line($bpnum) $line
# If there isn't a window for this file, don't try to update it
if [info exists wins($file)] {
insert_breakpoint_tag $wins($file) $line
}
}
proc delete_breakpoint {bpnum file line} {
global wins
global breakpoint_file
global breakpoint_line
# Save line number for later
set line $breakpoint_line($bpnum)
# Reset breakpoint annotation info
unset breakpoint_file($bpnum)
unset breakpoint_line($bpnum)
# If there isn't a window for this file, don't try to update it
if [info exists wins($file)] {
delete_breakpoint_tag $wins($file) $line
}
}
# This is a callback from C code to notify us of breakpoint changes. ACTION
# can be one of create, delete, enable, or disable.
proc gdbtk_tcl_breakpoint {action bpnum file line} {
${action}_breakpoint $bpnum $file $line
}
# Create the popup listing window menu
menu .breakpoint -cursor hand2
.breakpoint add command -label Break
.breakpoint add separator
.breakpoint add command -label "Edit" -command {exec $editor +$selected_line $selected_file &}
.breakpoint add command -label "Set breakpoint" -command {gdb_cmd "break $selected_file:$selected_line"}
#.breakpoint add command -label "Clear breakpoint" -command {echo "Clear"}
#.breakpoint add command -label "Enable breakpoint" -command {echo "Enable"}
#.breakpoint add command -label "Disable breakpoint" -command {echo "Disable"}
# Come here when button is released in the popup menu
bind .breakpoint <Any-ButtonRelease-1> {
global selected_win
# First, remove the menu, and release the pointer
.breakpoint unpost
grab release .breakpoint
# Unhighlight the selected line
$selected_win tag delete breaktag
# echo "after deleting $selected_win [$selected_win tag names]"
# echo "grab [grab current]"
# Actually invoke the menubutton here!
tk_invokeMenu %W
# destroy .breakpoint
grab release $selected_win
}
# Button 1 has been pressed in a listing window. Pop up a menu.
proc breakpoint_menu {win x y xrel yrel} {
global wins
global win_to_file
global file_to_debug_file
global highlight
global selected_line
global selected_file
global selected_win
grab $win
# echo "bpm grab current [grab current]"
# Map TK window name back to file name.
set file $win_to_file($win)
set pos [$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_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)
.breakpoint post [expr $x-[winfo width .breakpoint]/2] [expr $y-10]
grab .breakpoint
# echo "after grab [grab current]"
}
proc do_nothing {} {}
proc create_file_win {filename} {
global breakpoint_file
global breakpoint_line
regsub -all {\.|/} $filename {} temp
set win .text$temp
text $win -height 25 -width 80 -relief raised -borderwidth 2 -yscrollcommand textscrollproc -setgrid true -cursor hand2
bind $win <Enter> {focus %W}
# bind $win <1> {breakpoint_menu %W %X %Y %x %y}
bind $win <B1-Motion> do_nothing
bind $win n {gdb_cmd next ; update_ptr}
bind $win s {gdb_cmd step ; update_ptr}
bind $win c {gdb_cmd continue ; update_ptr}
bind $win f {gdb_cmd finish ; update_ptr}
bind $win u {gdb_cmd up ; update_ptr}
bind $win d {gdb_cmd down ; update_ptr}
set fh [open $filename]
$win delete 0.0 end
$win insert 0.0 [read $fh]
close $fh
set numlines [$win index end]
set numlines [lindex [split $numlines .] 0]
for {set i 1} {$i <= $numlines} {incr i} {
$win insert $i.0 [format " %4d " $i]
}
$win tag add wholebuf 0.0 end
$win tag bind wholebuf <1> {breakpoint_menu %W %X %Y %x %y}
foreach bpnum [array names breakpoint_file] {
if {$breakpoint_file($bpnum) == $filename} {
insert_breakpoint_tag $win $breakpoint_line($bpnum)
}
}
$win configure -state disabled
return $win
}
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
global file_to_debug_file
set line [lindex $linespec 3]
set filename [lindex $linespec 2]
set funcname [lindex $linespec 1]
set debug_file [lindex $linespec 0]
if {$filename == ""} {set filename Blank}
if {$filename != $cfile} then {
pack forget $wins($cfile)
set cfile $filename
if ![info exists wins($cfile)] then {
set wins($cfile) [create_file_win $cfile]
set win_to_file($wins($cfile)) $cfile
set file_to_debug_file($cfile) $debug_file
set pointers($cfile) 1.1
}
pack $wins($cfile) -side left -expand yes -in .listing -fill both -after .label
$wins($cfile) yview [expr $line - $screen_height / 2]
}
if {$current_label != "$filename.$funcname"} then {
set tail [expr [string last / $filename] + 1]
.label configure -text "[string range $filename $tail end] : ${funcname}()"
set current_label $filename.$funcname
}
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
$wins($cfile) insert $pointer_pos " "
set pointer_pos [$wins($cfile) index $line.1]
set pointers($cfile) $pointer_pos
$wins($cfile) delete $pointer_pos
$wins($cfile) insert $pointer_pos "\xbb"
if {$line < $screen_top + 1
|| $line > $screen_bot} then {
$wins($cfile) yview [expr $line - $screen_height / 2]
}
$wins($cfile) configure -state disabled
}
}
proc update_ptr {} {update_listing [gdb_loc]}
# Setup listing window
frame .listing
wm minsize . 1 1
label .label -text "*No file*" -borderwidth 2 -relief raised
text $wins($cfile) -height 25 -width 80 -relief raised -borderwidth 2 -yscrollcommand textscrollproc -setgrid true -cursor hand2
scrollbar .scroll -orient vertical -command {$wins($cfile) yview}
if {[tk colormodel .text] == "color"} {
set highlight "-background red2 -borderwidth 2 -relief sunk"
} else {
set fg [lindex [.text config -foreground] 4]
set bg [lindex [.text config -background] 4]
set highlight "-foreground $bg -background $fg -borderwidth 0"
}
proc textscrollproc {args} {global screen_height screen_top screen_bot
eval ".scroll set $args"
set screen_height [lindex $args 1]
set screen_top [lindex $args 2]
set screen_bot [lindex $args 3]}
$wins($cfile) insert 0.0 " This page intentionally left blank."
$wins($cfile) configure -state disabled
pack .label -side bottom -fill x -in .listing
pack $wins($cfile) -side left -expand yes -in .listing -fill both
pack .scroll -side left -fill y -in .listing
button .start -text Start -command \
{gdb_cmd {break main}
gdb_cmd {enable delete $bpnum}
gdb_cmd run
update_ptr }
button .step -text Step -command {gdb_cmd step ; update_ptr}
button .next -text Next -command {gdb_cmd next ; update_ptr}
button .continue -text Continue -command {gdb_cmd continue ; update_ptr}
button .finish -text Finish -command {gdb_cmd finish ; update_ptr}
#button .test -text Test -command {echo [info var]}
button .exit -text Exit -command {gdb_cmd quit}
button .up -text Up -command {gdb_cmd up ; update_ptr}
button .down -text Down -command {gdb_cmd down ; update_ptr}
button .bottom -text "Bottom" -command {gdb_cmd {frame 0} ; update_ptr}
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
button .files_window.close -text Close -command {destroy .files_window}
tk_listboxSingleSelect .files_window.list
eval .files_window.list insert 0 [lsort [gdb_listfiles]]
pack .files_window.list -side top -fill both -expand yes
pack .files_window.close -side bottom -fill x -expand no -anchor s
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}
}
button .files -text Files -command files_command
pack .listing -side bottom -fill both -expand yes
#pack .test -side bottom -fill x
pack .start .step .next .continue .finish .up .down .bottom .files .exit -side left
toplevel .command
# Setup command window
label .command.label -text "* Command Buffer *" -borderwidth 2 -relief raised
text .command.text -height 25 -width 80 -relief raised -borderwidth 2 -setgrid true -cursor hand2
pack .command.label -side top -fill x
pack .command.text -side top -expand yes -fill both
set command_line {}
gdb_cmd {set language c}
gdb_cmd {set height 0}
gdb_cmd {set width 0}
bind .command.text <Any-Key> {
global command_line
%W insert end %A
%W yview -pickplace end
append command_line %A
}
bind .command.text <Key-Return> {
global command_line
%W insert end \n
%W yview -pickplace end
gdb_cmd $command_line
set command_line {}
update_ptr
%W insert end "(gdb) "
%W yview -pickplace end
}
bind .command.text <Enter> {focus %W}
bind .command.text <Delete> {delete_char %W}
bind .command.text <BackSpace> {delete_char %W}
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]
}
wm minsize .command 1 1