diff options
author | Stu Grossman <grossman@cygnus> | 1994-07-28 22:07:02 +0000 |
---|---|---|
committer | Stu Grossman <grossman@cygnus> | 1994-07-28 22:07:02 +0000 |
commit | 754e5da26e5fb9374d6768188944fbca8d49d37c (patch) | |
tree | b875074ed1ccedc6d761f8dab2eb4b47091bc0f4 /gdb/gdbtk.tcl | |
parent | b98612f1fd9f751389044d28cfa5e66fbf2f1a7f (diff) | |
download | gdb-754e5da26e5fb9374d6768188944fbca8d49d37c.zip gdb-754e5da26e5fb9374d6768188944fbca8d49d37c.tar.gz gdb-754e5da26e5fb9374d6768188944fbca8d49d37c.tar.bz2 |
* 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.
Diffstat (limited to 'gdb/gdbtk.tcl')
-rw-r--r-- | gdb/gdbtk.tcl | 399 |
1 files changed, 399 insertions, 0 deletions
diff --git a/gdb/gdbtk.tcl b/gdb/gdbtk.tcl new file mode 100644 index 0000000..425041e --- /dev/null +++ b/gdb/gdbtk.tcl @@ -0,0 +1,399 @@ +# 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 + |