1 # GDB GUI setup for GDB, the GNU debugger.
3 # Free Software Foundation, Inc.
5 # Written by Stu Grossman <grossman@cygnus.com> of Cygnus Support.
7 # This file is part of GDB.
9 # This program is free software; you can redistribute it and/or modify
10 # it under the terms of the GNU General Public License as published by
11 # the Free Software Foundation; either version 2 of the License, or
12 # (at your option) any later version.
14 # This program is distributed in the hope that it will be useful,
15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 # GNU General Public License for more details.
19 # You should have received a copy of the GNU General Public License
20 # along with this program; if not, write to the Free Software
21 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
24 set wins
($cfile) .src.
text
29 set current_output_win .cmd.
text
32 set breakpoint_file
(-1) {[garbage
]}
33 set disassemble_with_source nosource
34 set expr_update_list
(0) 0
36 #option add *Foreground Black
37 #option add *Background White
38 #option add *Font -*-*-medium-r-normal--18-*-*-*-m-*-*-1
39 tk colormodel . monochrome
41 proc echo
string {puts stdout
$string}
43 if [info exists env
(EDITOR
)] then
{
44 set editor
$env(EDITOR
)
51 # These functions are called by GDB (from C code) to do various things in
52 # TK-land. All start with the prefix `gdbtk_tcl_' to make them easy to find.
58 # gdbtk_tcl_fputs (text) - Output text to the command window
62 # GDB calls this to output TEXT to the GDB command window. The text is
63 # placed at the end of the text widget. Note that output may not occur,
64 # due to buffering. Use gdbtk_tcl_flush to cause an immediate update.
67 proc gdbtk_tcl_fputs
{arg
} {
68 global current_output_win
70 $current_output_win insert end
"$arg"
71 $current_output_win yview
-pickplace end
74 proc gdbtk_tcl_fputs_error
{arg
} {
75 .cmd.
text insert end
"$arg"
76 .cmd.
text yview
-pickplace end
82 # gdbtk_tcl_flush () - Flush output to the command window
86 # GDB calls this to force all buffered text to the GDB command window.
89 proc gdbtk_tcl_flush
{} {
90 global current_output_win
92 $current_output_win yview
-pickplace end
99 # gdbtk_tcl_query (message) - Create a yes/no query dialog box
103 # GDB calls this to create a yes/no dialog box containing MESSAGE. GDB
104 # is hung while the dialog box is active (ie: no commands will work),
105 # however windows can still be refreshed in case of damage or exposure.
108 proc gdbtk_tcl_query
{message} {
109 tk_dialog .query
"gdb : query" "$message" {} 1 "No" "Yes"
115 # gdbtk_start_variable_annotation (args ...) -
119 # Not yet implemented.
122 proc gdbtk_tcl_start_variable_annotation
{valaddr ref_type stor_cl cum_expr field type_cast
} {
123 echo
"gdbtk_tcl_start_variable_annotation $valaddr $ref_type $stor_cl $cum_expr $field $type_cast"
129 # gdbtk_end_variable_annotation (args ...) -
133 # Not yet implemented.
136 proc gdbtk_tcl_end_variable_annotation
{} {
137 echo gdbtk_tcl_end_variable_annotation
143 # gdbtk_tcl_breakpoint (action bpnum file line) - Notify the TK
144 # interface of changes to breakpoints.
148 # GDB calls this to notify TK of changes to breakpoints. ACTION is one
150 # create - Notify of breakpoint creation
151 # delete - Notify of breakpoint deletion
152 # enable - Notify of breakpoint enabling
153 # disable - Notify of breakpoint disabling
155 # All actions take the same set of arguments: BPNUM is the breakpoint
156 # number, FILE is the source file and LINE is the line number, and PC is
157 # the pc of the affected breakpoint.
160 proc gdbtk_tcl_breakpoint
{action bpnum
file line pc
} {
161 ${action
}_breakpoint
$bpnum $file $line $pc
164 proc asm_win_name
{funcname
} {
165 if {$funcname == "*None*"} {return .asm.
text}
167 regsub -all {\.
} $funcname _ temp
169 return .asm.func_
${temp
}
175 # create_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
179 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
180 # land of breakpoint creation. This consists of recording the file and
181 # line number in the breakpoint_file and breakpoint_line arrays. Also,
182 # if there is already a window associated with FILE, it is updated with
186 proc create_breakpoint
{bpnum
file line pc
} {
188 global breakpoint_file
189 global breakpoint_line
190 global pos_to_breakpoint
191 global pos_to_bpcount
195 # Record breakpoint locations
197 set breakpoint_file
($bpnum) $file
198 set breakpoint_line
($bpnum) $line
199 set pos_to_breakpoint
($file:$line) $bpnum
200 if ![info exists pos_to_bpcount
($file:$line)] {
201 set pos_to_bpcount
($file:$line) 0
203 incr pos_to_bpcount
($file:$line)
204 set pos_to_breakpoint
($pc) $bpnum
205 if ![info exists pos_to_bpcount
($pc)] {
206 set pos_to_bpcount
($pc) 0
208 incr pos_to_bpcount
($pc)
210 # If there's a window for this file, update it
212 if [info exists wins
($file)] {
213 insert_breakpoint_tag
$wins($file) $line
216 # If there's an assembly window, update that too
218 set win
[asm_win_name
$cfunc]
219 if [winfo exists
$win] {
220 insert_breakpoint_tag
$win [pc_to_line
$pclist($cfunc) $pc]
227 # delete_breakpoint (bpnum file line pc) - Delete breakpoint info from TK land
231 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
232 # land of breakpoint destruction. This consists of removing the file and
233 # line number from the breakpoint_file and breakpoint_line arrays. Also,
234 # if there is already a window associated with FILE, the tags are removed
238 proc delete_breakpoint
{bpnum
file line pc
} {
240 global breakpoint_file
241 global breakpoint_line
242 global pos_to_breakpoint
243 global pos_to_bpcount
246 # Save line number and file for later
248 set line
$breakpoint_line($bpnum)
250 set file $breakpoint_file($bpnum)
252 # Reset breakpoint annotation info
254 if {$pos_to_bpcount($file:$line) > 0} {
255 decr pos_to_bpcount
($file:$line)
257 if {$pos_to_bpcount($file:$line) == 0} {
258 catch "unset pos_to_breakpoint($file:$line)"
260 unset breakpoint_file
($bpnum)
261 unset breakpoint_line
($bpnum)
263 # If there's a window for this file, update it
265 if [info exists wins
($file)] {
266 delete_breakpoint_tag
$wins($file) $line
271 # If there's an assembly window, update that too
273 if {$pos_to_bpcount($pc) > 0} {
274 decr pos_to_bpcount
($pc)
276 if {$pos_to_bpcount($pc) == 0} {
277 catch "unset pos_to_breakpoint($pc)"
279 set win
[asm_win_name
$cfunc]
280 if [winfo exists
$win] {
281 delete_breakpoint_tag
$win [pc_to_line
$pclist($cfunc) $pc]
290 # enable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
294 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
295 # land of a breakpoint being enabled. This consists of unstippling the
296 # specified breakpoint indicator.
299 proc enable_breakpoint
{bpnum
file line pc
} {
303 if [info exists wins
($file)] {
304 $wins($file) tag configure
$line -fgstipple {}
307 # If there's an assembly window, update that too
309 set win
[asm_win_name
$cfunc]
310 if [winfo exists
$win] {
311 $win tag configure
[pc_to_line
$pclist($cfunc) $pc] -fgstipple {}
318 # disable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
322 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
323 # land of a breakpoint being disabled. This consists of stippling the
324 # specified breakpoint indicator.
327 proc disable_breakpoint
{bpnum
file line pc
} {
331 if [info exists wins
($file)] {
332 $wins($file) tag configure
$line -fgstipple gray50
335 # If there's an assembly window, update that too
337 set win
[asm_win_name
$cfunc]
338 if [winfo exists
$win] {
339 $win tag configure
[pc_to_line
$pclist($cfunc) $pc] -fgstipple gray50
346 # insert_breakpoint_tag (win line) - Insert a breakpoint tag in WIN.
350 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to insert a
351 # breakpoint tag into window WIN at line LINE.
354 proc insert_breakpoint_tag
{win line
} {
355 $win configure
-state normal
357 $win insert
$line.0 "B"
358 $win tag add
$line $line.0
359 $win tag add delete
$line.0 "$line.0 lineend"
360 $win tag add margin
$line.0 "$line.0 lineend"
362 $win configure
-state disabled
368 # delete_breakpoint_tag (win line) - Remove a breakpoint tag from WIN.
372 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to remove a
373 # breakpoint tag from window WIN at line LINE.
376 proc delete_breakpoint_tag
{win line
} {
377 $win configure
-state normal
379 if {[string range
$win 0 3] == ".src"} then
{
380 $win insert
$line.0 "\xa4"
382 $win insert
$line.0 " "
384 $win tag delete
$line
385 $win tag add delete
$line.0 "$line.0 lineend"
386 $win tag add margin
$line.0 "$line.0 lineend"
387 $win configure
-state disabled
390 proc gdbtk_tcl_busy
{} {
391 if [winfo exists .src
] {
392 catch {.src.start configure
-state disabled
}
393 catch {.src.stop configure
-state normal
}
394 catch {.src.step configure
-state disabled
}
395 catch {.src.next configure
-state disabled
}
396 catch {.src.
continue configure
-state disabled
}
397 catch {.src.finish configure
-state disabled
}
398 catch {.src.up configure
-state disabled
}
399 catch {.src.down configure
-state disabled
}
400 catch {.src.bottom configure
-state disabled
}
402 if [winfo exists .asm
] {
403 catch {.asm.stepi configure
-state disabled
}
404 catch {.asm.nexti configure
-state disabled
}
405 catch {.asm.
continue configure
-state disabled
}
406 catch {.asm.finish configure
-state disabled
}
407 catch {.asm.up configure
-state disabled
}
408 catch {.asm.down configure
-state disabled
}
409 catch {.asm.bottom configure
-state disabled
}
410 catch {.asm.
close configure
-state disabled
}
414 proc gdbtk_tcl_idle
{} {
415 if [winfo exists .src
] {
416 catch {.src.start configure
-state normal
}
417 catch {.src.stop configure
-state disabled
}
418 catch {.src.step configure
-state normal
}
419 catch {.src.next configure
-state normal
}
420 catch {.src.
continue configure
-state normal
}
421 catch {.src.finish configure
-state normal
}
422 catch {.src.up configure
-state normal
}
423 catch {.src.down configure
-state normal
}
424 catch {.src.bottom configure
-state normal
}
427 if [winfo exists .asm
] {
428 catch {.asm.stepi configure
-state normal
}
429 catch {.asm.nexti configure
-state normal
}
430 catch {.asm.
continue configure
-state normal
}
431 catch {.asm.finish configure
-state normal
}
432 catch {.asm.up configure
-state normal
}
433 catch {.asm.down configure
-state normal
}
434 catch {.asm.bottom configure
-state normal
}
435 catch {.asm.
close configure
-state normal
}
442 # decr (var val) - compliment to incr
447 proc decr
{var
{val
1}} {
449 set num
[expr $num - $val]
456 # pc_to_line (pclist pc) - convert PC to a line number.
460 # Convert PC to a line number from PCLIST. If exact line isn't found,
461 # we return the first line that starts before PC.
463 proc pc_to_line
{pclist pc
} {
464 set line
[lsearch -exact $pclist $pc]
466 if {$line >= 1} { return $line }
469 foreach linepc
[lrange $pclist 1 end
] {
470 if {$pc < $linepc} { decr line
; return $line }
473 return [expr $line - 1]
479 # file popup menu - Define the file popup menu.
483 # This menu just contains a bunch of buttons that do various things to
484 # the line under the cursor.
488 # Edit - Run the editor (specified by the environment variable EDITOR) on
489 # this file, at the current line.
490 # Breakpoint - Set a breakpoint at the current line. This just shoves
491 # a `break' command at GDB with the appropriate file and line
492 # number. Eventually, GDB calls us back (at gdbtk_tcl_breakpoint)
493 # to notify us of where the breakpoint needs to show up.
496 menu .file_popup
-cursor hand2
497 .file_popup add command
-label "Not yet set" -state disabled
498 .file_popup add separator
499 .file_popup add command
-label "Edit" -command {exec $editor +$selected_line $selected_file &}
500 .file_popup add command
-label "Set breakpoint" -command {gdb_cmd
"break $selected_file:$selected_line"}
505 # file popup menu - Define the file popup menu bindings.
509 # This defines the binding for the file popup menu. Currently, there is
510 # only one, which is activated when Button-1 is released. This causes
511 # the menu to be unposted, releases the grab for the menu, and then
512 # unhighlights the line under the cursor. After that, the selected menu
516 bind .file_popup
<Any-ButtonRelease-1
> {
519 # First, remove the menu, and release the pointer
522 grab release .file_popup
524 # Unhighlight the selected line
526 $selected_win tag delete breaktag
528 # Actually invoke the menubutton here!
536 # file_popup_menu (win x y xrel yrel) - Popup the file popup menu.
540 # This procedure is invoked as a result of a command binding in the
541 # listing window. It does several things:
542 # o - It highlights the line under the cursor.
543 # o - It pops up the file popup menu which is intended to do
544 # various things to the aforementioned line.
545 # o - Grabs the mouse for the file popup menu.
548 # Button 1 has been pressed in a listing window. Pop up a menu.
550 proc file_popup_menu
{win x y xrel yrel
} {
553 global file_to_debug_file
559 # Map TK window name back to file name.
561 set file $win_to_file($win)
563 set pos
[$win index
@$xrel,$yrel]
565 # Record selected file and line for menu button actions
567 set selected_file
$file_to_debug_file($file)
568 set selected_line
[lindex [split $pos .
] 0]
569 set selected_win
$win
571 # Highlight the selected line
573 eval $win tag config breaktag
$highlight
574 $win tag add breaktag
"$pos linestart" "$pos linestart + 1l"
576 # Post the menu near the pointer, (and grab it)
578 .file_popup entryconfigure
0 -label "$selected_file:$selected_line"
579 .file_popup post
[expr $x-[winfo width .file_popup
]/2] [expr $y-10]
586 # listing_window_button_1 (win x y xrel yrel) - Handle button 1 in listing window
590 # This procedure is invoked as a result of holding down button 1 in the
591 # listing window. The action taken depends upon where the button was
592 # pressed. If it was in the left margin (the breakpoint column), it
593 # sets or clears a breakpoint. In the main text area, it will pop up a
597 proc listing_window_button_1
{win x y xrel yrel
} {
600 global file_to_debug_file
605 global pos_to_breakpoint
607 # Map TK window name back to file name.
609 set file $win_to_file($win)
611 set pos
[split [$win index
@$xrel,$yrel] .
]
613 # Record selected file and line for menu button actions
615 set selected_file
$file_to_debug_file($file)
616 set selected_line
[lindex $pos 0]
617 set selected_col
[lindex $pos 1]
618 set selected_win
$win
620 # If we're in the margin, then toggle the breakpoint
622 if {$selected_col < 8} {
623 set pos_break
$selected_file:$selected_line
624 set pos
$file:$selected_line
625 set tmp pos_to_breakpoint
($pos)
626 if [info exists
$tmp] {
628 gdb_cmd
"delete $bpnum"
630 gdb_cmd
"break $pos_break"
635 # Post the menu near the pointer, (and grab it)
637 .file_popup entryconfigure
0 -label "$selected_file:$selected_line"
638 .file_popup post
[expr $x-[winfo width .file_popup
]/2] [expr $y-10]
645 # asm_window_button_1 (win x y xrel yrel) - Handle button 1 in asm window
649 # This procedure is invoked as a result of holding down button 1 in the
650 # assembly window. The action taken depends upon where the button was
651 # pressed. If it was in the left margin (the breakpoint column), it
652 # sets or clears a breakpoint. In the main text area, it will pop up a
656 proc asm_window_button_1
{win x y xrel yrel
} {
659 global file_to_debug_file
664 global pos_to_breakpoint
668 set pos
[split [$win index
@$xrel,$yrel] .
]
670 # Record selected file and line for menu button actions
672 set selected_line
[lindex $pos 0]
673 set selected_col
[lindex $pos 1]
674 set selected_win
$win
678 set pc
[lindex $pclist($cfunc) $selected_line]
680 # If we're in the margin, then toggle the breakpoint
682 if {$selected_col < 11} {
683 set tmp pos_to_breakpoint
($pc)
684 if [info exists
$tmp] {
686 gdb_cmd
"delete $bpnum"
693 # Post the menu near the pointer, (and grab it)
695 # .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
696 # .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
703 # do_nothing - Does absolutely nothing.
707 # This procedure does nothing. It is used as a placeholder to allow
708 # the disabling of bindings that would normally be inherited from the
709 # parent widget. I can't think of any other way to do this.
712 proc do_nothing
{} {}
717 # not_implemented_yet - warn that a feature is unavailable
721 # This procedure warns that something doesn't actually work yet.
724 proc not_implemented_yet
{message} {
725 tk_dialog .unimpl
"gdb : unimpl" \
726 "$message: not implemented in the interface yet" \
733 # create_expr_win - Create expression display window
737 # Create the expression display window.
742 proc add_expr
{expr} {
743 global expr_update_list
748 set e .
expr.e
${expr_num
}
752 checkbutton $e.
update -text " " -relief flat
\
753 -variable expr_update_list
($expr_num)
754 text $e.
expr -width 20 -height 1
755 $e.
expr insert
0.0 $expr
756 bind $e.
expr <1> "update_expr $expr_num"
757 text $e.val
-width 20 -height 1
759 update_expr
$expr_num
761 pack $e.
update -side left
-anchor nw
762 pack $e.
expr $e.val
-side left
-expand yes
-fill x
764 pack $e -side top
-fill x
-anchor w
767 set delete_expr_flag
0
771 proc delete_expr
{} {
772 global delete_expr_flag
774 if {$delete_expr_flag == 1} {
775 set delete_expr_flag
0
776 tk_butUp .
expr.delete
777 bind .
expr.delete
<Any-Leave
> {}
779 set delete_expr_flag
1
780 bind .
expr.delete
<Any-Leave
> do_nothing
781 tk_butDown .
expr.delete
785 proc update_expr
{expr_num
} {
786 global delete_expr_flag
787 global expr_update_list
789 set e .
expr.e
${expr_num
}
791 if {$delete_expr_flag == 1} {
792 set delete_expr_flag
0
794 tk_butUp .
expr.delete
795 tk_butLeave .
expr.delete
796 bind .
expr.delete
<Any-Leave
> {}
797 unset expr_update_list
($expr_num)
801 set expr [$e.
expr get
0.0 end
]
803 $e.val delete
0.0 end
804 if [catch "gdb_eval $expr" val
] {
807 $e.val insert
0.0 $val
811 proc update_exprs
{} {
812 global expr_update_list
814 foreach expr_num
[array names expr_update_list
] {
815 if $expr_update_list($expr_num) {
816 update_expr
$expr_num
821 proc create_expr_win
{} {
823 if [winfo exists .
expr] {raise .
expr ; return}
827 wm title .
expr Expression
828 wm iconname .
expr "Reg config"
830 frame .
expr.entryframe
832 entry .
expr.
entry -borderwidth 2 -relief sunken
833 bind .
expr <Enter
> {focus .
expr.
entry}
834 bind .
expr.
entry <Key-Return
> {add_expr
[.
expr.
entry get
]
835 .
expr.
entry delete
0 end
}
837 label .
expr.entrylab
-text "Expression: "
839 pack .
expr.entrylab
-in .
expr.entryframe
-side left
840 pack .
expr.
entry -in .
expr.entryframe
-side left
-fill x
-expand yes
844 button .
expr.delete
-text Delete
845 bind .
expr.delete
<1> delete_expr
847 button .
expr.
close -text Close
-command {destroy .
expr}
849 pack .
expr.delete
-side left
-fill x
-expand yes
-in .
expr.buts
850 pack .
expr.
close -side right
-fill x
-expand yes
-in .
expr.buts
852 pack .
expr.buts
-side bottom
-fill x
853 pack .
expr.entryframe
-side bottom
-fill x
857 label .
expr.updlab
-text Update
858 label .
expr.exprlab
-text Expression
859 label .
expr.vallab
-text Value
861 pack .
expr.updlab
-side left
-in .
expr.labels
862 pack .
expr.exprlab .
expr.vallab
-side left
-in .
expr.labels
-expand yes
-anchor w
864 pack .
expr.labels
-side top
-fill x
-anchor w
870 # display_expression (expression) - Display EXPRESSION in display window
874 # Display EXPRESSION and its value in the expression display window.
877 proc display_expression
{expression
} {
886 # create_file_win (filename) - Create a win for FILENAME.
890 # The new text widget.
894 # This procedure creates a text widget for FILENAME. It returns the
895 # newly created widget. First, a text widget is created, and given basic
896 # configuration info. Second, all the bindings are setup. Third, the
897 # file FILENAME is read into the text widget. Fourth, margins and line
901 proc create_file_win
{filename debug_file
} {
902 global breakpoint_file
903 global breakpoint_line
906 # Replace all the dirty characters in $filename with clean ones, and generate
907 # a unique name for the text widget.
909 regsub -all {\.
} $filename {} temp
910 set win .src.
text$temp
912 # Open the file, and read it into the text widget
914 if [catch "open $filename" fh
] {
915 # File can't be read. Put error message into .src.nofile window and return.
917 catch {destroy .src.nofile
}
918 text .src.nofile
-height 25 -width 88 -relief raised
\
919 -borderwidth 2 -yscrollcommand textscrollproc
\
920 -setgrid true
-cursor hand2
921 .src.nofile insert
0.0 $fh
922 .src.nofile configure
-state disabled
923 bind .src.nofile
<1> do_nothing
924 bind .src.nofile
<B1-Motion
> do_nothing
928 # Actually create and do basic configuration on the text widget.
930 text $win -height 25 -width 88 -relief raised
-borderwidth 2 \
931 -yscrollcommand textscrollproc
-setgrid true
-cursor hand2
933 # Setup all the bindings
935 bind $win <Enter
> {focus %W
}
936 # bind $win <1> {listing_window_button_1 %W %X %Y %x %y}
937 bind $win <1> do_nothing
938 bind $win <B1-Motion
> do_nothing
940 bind $win n
{catch {gdb_cmd next
} ; update_ptr
}
941 bind $win s
{catch {gdb_cmd step
} ; update_ptr
}
942 bind $win c
{catch {gdb_cmd
continue} ; update_ptr
}
943 bind $win f
{catch {gdb_cmd finish
} ; update_ptr
}
944 bind $win u
{catch {gdb_cmd up
} ; update_ptr
}
945 bind $win d
{catch {gdb_cmd down
} ; update_ptr
}
948 $win insert
0.0 [read $fh]
951 # Add margins (for annotations) and a line number to each line (if requested)
953 set numlines
[$win index end
]
954 set numlines
[lindex [split $numlines .
] 0]
956 for {set i
1} {$i <= $numlines} {incr i
} {
957 $win insert
$i.0 [format " %4d " $i]
958 $win tag add
source $i.8 "$i.0 lineend"
961 for {set i
1} {$i <= $numlines} {incr i
} {
963 $win tag add
source $i.8 "$i.0 lineend"
969 foreach i
[gdb_sourcelines
$debug_file] {
971 $win insert
$i.0 "\xa4"
972 $win tag add margin
$i.0 $i.8
975 # $win tag bind margin <1> {listing_window_button_1 %W %X %Y %x %y}
976 $win tag
bind source <1> {
977 %W mark
set anchor
"@%x,%y wordstart"
978 set last
[%W index
"@%x,%y wordend"]
979 %W tag remove sel
0.0 anchor
980 %W tag remove sel
$last end
981 %W tag add sel anchor
$last
983 # $win tag bind source <Double-Button-1> {
984 # %W mark set anchor "@%x,%y wordstart"
985 # set last [%W index "@%x,%y wordend"]
986 # %W tag remove sel 0.0 anchor
987 # %W tag remove sel $last end
988 # %W tag add sel anchor $last
989 # echo "Selected [selection get]"
991 $win tag
bind source <B1-Motion
> {
992 %W tag remove sel
0.0 anchor
993 %W tag remove sel
$last end
994 %W tag add sel anchor
@%x
,%y
996 $win tag
bind sel
<1> do_nothing
997 $win tag
bind sel
<Double-Button-1
> {display_expression
[selection get
]}
1001 # Scan though the breakpoint data base and install any destined for this file
1003 foreach bpnum
[array names breakpoint_file
] {
1004 if {$breakpoint_file($bpnum) == $filename} {
1005 insert_breakpoint_tag
$win $breakpoint_line($bpnum)
1009 # Disable the text widget to prevent user modifications
1011 $win configure
-state disabled
1018 # create_asm_win (funcname pc) - Create an assembly win for FUNCNAME.
1022 # The new text widget.
1026 # This procedure creates a text widget for FUNCNAME. It returns the
1027 # newly created widget. First, a text widget is created, and given basic
1028 # configuration info. Second, all the bindings are setup. Third, the
1029 # function FUNCNAME is read into the text widget.
1032 proc create_asm_win
{funcname pc
} {
1033 global breakpoint_file
1034 global breakpoint_line
1035 global current_output_win
1037 global disassemble_with_source
1039 # Replace all the dirty characters in $filename with clean ones, and generate
1040 # a unique name for the text widget.
1042 set win
[asm_win_name
$funcname]
1044 # Actually create and do basic configuration on the text widget.
1046 text $win -height 25 -width 80 -relief raised
-borderwidth 2 \
1047 -setgrid true
-cursor hand2
-yscrollcommand asmscrollproc
1049 # Setup all the bindings
1051 bind $win <Enter
> {focus %W
}
1052 bind $win <1> {asm_window_button_1
%W
%X
%Y
%x
%y
}
1053 bind $win <B1-Motion
> do_nothing
1054 bind $win n
{catch {gdb_cmd nexti
} ; update_ptr
}
1055 bind $win s
{catch {gdb_cmd stepi
} ; update_ptr
}
1056 bind $win c
{catch {gdb_cmd
continue} ; update_ptr
}
1057 bind $win f
{catch {gdb_cmd finish
} ; update_ptr
}
1058 bind $win u
{catch {gdb_cmd up
} ; update_ptr
}
1059 bind $win d
{catch {gdb_cmd down
} ; update_ptr
}
1061 # Disassemble the code, and read it into the new text widget
1063 set temp
$current_output_win
1064 set current_output_win
$win
1065 catch "gdb_disassemble $disassemble_with_source $pc"
1066 set current_output_win
$temp
1068 set numlines
[$win index end
]
1069 set numlines
[lindex [split $numlines .
] 0]
1072 # Delete the first and last lines, cuz these contain useless info
1074 # $win delete 1.0 2.0
1075 # $win delete {end - 1 lines} end
1078 # Add margins (for annotations) and note the PC for each line
1080 catch "unset pclist($funcname)"
1081 lappend pclist
($funcname) Unused
1082 for {set i
1} {$i <= $numlines} {incr i
} {
1083 scan [$win get
$i.0 "$i.0 lineend"] "%s " pc
1084 lappend pclist
($funcname) $pc
1085 $win insert
$i.0 " "
1088 # Scan though the breakpoint data base and install any destined for this file
1090 # foreach bpnum [array names breakpoint_file] {
1091 # if {$breakpoint_file($bpnum) == $filename} {
1092 # insert_breakpoint_tag $win $breakpoint_line($bpnum)
1096 # Disable the text widget to prevent user modifications
1098 $win configure
-state disabled
1105 # asmscrollproc (WINHEIGHT SCREENHEIGHT SCREENTOP SCREENBOT) - Update the
1106 # asm window scrollbar.
1110 # This procedure is called to update the assembler window's scrollbar.
1113 proc asmscrollproc
{args
} {
1114 global asm_screen_height asm_screen_top asm_screen_bot
1116 eval ".asm.scroll set $args"
1117 set asm_screen_height
[lindex $args 1]
1118 set asm_screen_top
[lindex $args 2]
1119 set asm_screen_bot
[lindex $args 3]
1125 # update_listing (linespec) - Update the listing window according to
1130 # This procedure is called from various places to update the listing
1131 # window based on LINESPEC. It is usually invoked with the result of
1134 # It will move the cursor, and scroll the text widget if necessary.
1135 # Also, it will switch to another text widget if necessary, and update
1136 # the label widget too.
1138 # LINESPEC is a list of the form:
1140 # { DEBUG_FILE FUNCNAME FILENAME LINE }, where:
1142 # DEBUG_FILE - is the abbreviated form of the file name. This is usually
1143 # the file name string given to the cc command. This is
1144 # primarily needed for breakpoint commands, and when an
1145 # abbreviated for of the filename is desired.
1146 # FUNCNAME - is the name of the function.
1147 # FILENAME - is the fully qualified (absolute) file name. It is usually
1148 # the same as $PWD/$DEBUG_FILE, where PWD is the working dir
1149 # at the time the cc command was given. This is used to
1150 # actually locate the file to be displayed.
1151 # LINE - The line number to be displayed.
1153 # Usually, this procedure will just move the cursor one line down to the
1154 # next line to be executed. However, if the cursor moves out of range
1155 # or into another file, it will scroll the text widget so that the line
1156 # of interest is in the middle of the viewable portion of the widget.
1159 proc update_listing
{linespec
} {
1161 global screen_height
1165 global current_label
1167 global file_to_debug_file
1170 # Rip the linespec apart
1172 set line
[lindex $linespec 3]
1173 set filename [lindex $linespec 2]
1174 set funcname
[lindex $linespec 1]
1175 set debug_file
[lindex $linespec 0]
1177 # Sometimes there's no source file for this location
1179 if {$filename == ""} {set filename Blank
}
1181 # If we want to switch files, we need to unpack the current text widget, and
1182 # stick in the new one.
1184 if {$filename != $cfile} then
{
1185 pack forget
$wins($cfile)
1188 # Create a text widget for this file if necessary
1190 if ![info exists wins
($cfile)] then
{
1191 set wins
($cfile) [create_file_win
$cfile $debug_file]
1192 if {$wins($cfile) != ".src.nofile"} {
1193 set win_to_file
($wins($cfile)) $cfile
1194 set file_to_debug_file
($cfile) $debug_file
1195 set pointers
($cfile) 1.1
1199 # Pack the text widget into the listing widget, and scroll to the right place
1201 pack $wins($cfile) -side left
-expand yes
-in .src.
info \
1202 -fill both
-after .src.scroll
1204 # Make the scrollbar point at the new text widget
1206 .src.scroll configure
-command "$wins($cfile) yview"
1208 $wins($cfile) yview
[expr $line - $screen_height / 2]
1211 # Update the label widget in case the filename or function name has changed
1213 if {$current_label != "$filename.$funcname"} then
{
1214 set tail
[expr [string last
/ $filename] + 1]
1215 set .src.
label "[string range $filename $tail end] : ${funcname}()"
1216 # .src.label configure -text "[string range $filename $tail end] : ${funcname}()"
1217 set current_label
$filename.
$funcname
1220 # Update the pointer, scrolling the text widget if necessary to keep the
1221 # pointer in an acceptable part of the screen.
1223 if [info exists pointers
($cfile)] then
{
1224 $wins($cfile) configure
-state normal
1225 set pointer_pos
$pointers($cfile)
1226 $wins($cfile) configure
-state normal
1227 $wins($cfile) delete
$pointer_pos "$pointer_pos + 2 char"
1228 $wins($cfile) insert
$pointer_pos " "
1230 set pointer_pos
[$wins($cfile) index
$line.1]
1231 set pointers
($cfile) $pointer_pos
1233 $wins($cfile) delete
$pointer_pos "$pointer_pos + 2 char"
1234 $wins($cfile) insert
$pointer_pos "->"
1236 if {$line < $screen_top + 1
1237 ||
$line > $screen_bot} then
{
1238 $wins($cfile) yview
[expr $line - $screen_height / 2]
1241 $wins($cfile) configure
-state disabled
1248 # create_asm_window - Open up the assembly window.
1252 # Create an assembly window if it doesn't exist.
1255 proc create_asm_window
{} {
1258 if [winfo exists .asm
] {raise .asm
; return}
1261 set win
[asm_win_name
$cfunc]
1263 build_framework .asm Assembly
"*NIL*"
1265 # First, delete all the old menu entries
1267 .asm.menubar.view.
menu delete
0 last
1269 .asm.
text configure
-yscrollcommand asmscrollproc
1274 button .asm.stepi
-width 6 -text Stepi
\
1275 -command {catch {gdb_cmd stepi
} ; update_ptr
}
1276 button .asm.nexti
-width 6 -text Nexti
\
1277 -command {catch {gdb_cmd nexti
} ; update_ptr
}
1278 button .asm.
continue -width 6 -text Cont
\
1279 -command {catch {gdb_cmd
continue} ; update_ptr
}
1280 button .asm.finish
-width 6 -text Finish
\
1281 -command {catch {gdb_cmd finish
} ; update_ptr
}
1282 button .asm.up
-width 6 -text Up
-command {catch {gdb_cmd up
} ; update_ptr
}
1283 button .asm.down
-width 6 -text Down
\
1284 -command {catch {gdb_cmd down
} ; update_ptr
}
1285 button .asm.bottom
-width 6 -text Bottom
\
1286 -command {catch {gdb_cmd
{frame 0}} ; update_ptr
}
1288 pack .asm.stepi .asm.
continue .asm.up .asm.bottom
-side left
-padx 3 -pady 5 -in .asm.row1
1289 pack .asm.nexti .asm.finish .asm.down
-side left
-padx 3 -pady 5 -in .asm.row2
1291 pack .asm.row2 .asm.row1
-side bottom
-anchor w
-before .asm.
info
1295 update_assembly
[gdb_loc
]
1297 # We do this update_assembly to get the proper value of disassemble-from-exec.
1299 # exec file menu item
1300 .asm.menubar.view.
menu add
radiobutton -label "Exec file" \
1301 -variable disassemble-from-exec
-value 1
1302 # target memory menu item
1303 .asm.menubar.view.
menu add
radiobutton -label "Target memory" \
1304 -variable disassemble-from-exec
-value 0
1306 # Disassemble with source
1307 .asm.menubar.view.
menu add
checkbutton -label "Source" \
1308 -variable disassemble_with_source
-onvalue source \
1309 -offvalue nosource
-command {
1310 foreach asm
[info command .asm.func_
*] {
1314 update_assembly
[gdb_loc
]
1318 proc reg_config_menu
{} {
1319 catch {destroy .reg.config
}
1320 toplevel .reg.config
1321 wm geometry .reg.config
+300+300
1322 wm title .reg.config
"Register configuration"
1323 wm iconname .reg.config
"Reg config"
1324 set regnames
[gdb_regnames
]
1325 set num_regs
[llength $regnames]
1327 frame .reg.config.buts
1329 button .reg.config.done
-text " Done " -command "
1330 recompute_reg_display_list $num_regs
1332 update_registers all
1333 destroy .reg.config "
1335 button .reg.config.
update -text Update
-command "
1336 recompute_reg_display_list $num_regs
1338 update_registers all "
1340 pack .reg.config.buts
-side bottom
-fill x
1342 pack .reg.config.done
-side left
-fill x
-expand yes
-in .reg.config.buts
1343 pack .reg.config.
update -side right
-fill x
-expand yes
-in .reg.config.buts
1345 # Since there can be lots of registers, we build the window with no more than
1346 # 32 rows, and as many columns as needed.
1348 # First, figure out how many columns we need and create that many column frame
1351 set ncols
[expr ($num_regs + 31) / 32]
1353 for {set col
0} {$col < $ncols} {incr col
} {
1354 frame .reg.config.col
$col
1355 pack .reg.config.col
$col -side left
-anchor n
1358 # Now, create the checkbutton widgets and pack them in the appropriate columns
1362 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1363 set regname
[lindex $regnames $regnum]
1364 checkbutton .reg.config.col
$col.
$row -text $regname -pady 0 \
1365 -variable regena
($regnum) -relief flat
-anchor w
-bd 1
1367 pack .reg.config.col
$col.
$row -side top
-fill both
1380 # create_registers_window - Open up the register display window.
1384 # Create the register display window, with automatic updates.
1387 proc create_registers_window
{} {
1390 if [winfo exists .reg
] {raise .reg
; return}
1392 # Create an initial register display list consisting of all registers
1394 if ![info exists reg_format
] {
1395 global reg_display_list
1396 global changed_reg_list
1400 set num_regs
[llength [gdb_regnames
]]
1401 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1402 set regena
($regnum) 1
1404 recompute_reg_display_list
$num_regs
1405 set changed_reg_list
$reg_display_list
1408 build_framework .reg Registers
1410 # First, delete all the old menu entries
1412 .reg.menubar.view.
menu delete
0 last
1415 .reg.menubar.view.
menu add
radiobutton -label Hex
\
1416 -command {set reg_format x
; update_registers all
}
1419 .reg.menubar.view.
menu add
radiobutton -label Decimal
\
1420 -command {set reg_format d
; update_registers all
}
1423 .reg.menubar.view.
menu add
radiobutton -label Octal
\
1424 -command {set reg_format o
; update_registers all
}
1427 .reg.menubar.view.
menu add
radiobutton -label Natural
\
1428 -command {set reg_format
{} ; update_registers all
}
1431 .reg.menubar.view.
menu add separator
1433 .reg.menubar.view.
menu add command
-label Config
-command {
1438 # Install the reg names
1441 update_registers all
1444 # Convert regena into a list of the enabled $regnums
1446 proc recompute_reg_display_list
{num_regs
} {
1447 global reg_display_list
1451 catch {unset reg_display_list
}
1454 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1456 if {[set regena
($regnum)] != 0} {
1457 lappend reg_display_list
$regnum
1458 set regmap
($regnum) $line
1464 # Fill out the register window with the names of the regs specified in
1467 proc populate_reg_window
{} {
1468 global max_regname_width
1469 global reg_display_list
1471 .reg.
text configure
-state normal
1473 .reg.
text delete
0.0 end
1475 set regnames
[eval gdb_regnames
$reg_display_list]
1477 # Figure out the longest register name
1479 set max_regname_width
0
1481 foreach reg
$regnames {
1482 set len
[string length
$reg]
1483 if {$len > $max_regname_width} {set max_regname_width
$len}
1486 set width
[expr $max_regname_width + 15]
1488 set height
[llength $regnames]
1490 if {$height > 60} {set height
60}
1492 .reg.
text configure
-height $height -width $width
1494 foreach reg
$regnames {
1495 .reg.
text insert end
[format "%-*s \n" $max_regname_width ${reg
}]
1499 .reg.
text configure
-state disabled
1505 # update_registers - Update the registers window.
1509 # This procedure updates the registers window.
1512 proc update_registers
{which
} {
1513 global max_regname_width
1515 global reg_display_list
1516 global changed_reg_list
1520 set margin
[expr $max_regname_width + 1]
1522 set winwidth
[lindex [$win configure
-width] 4]
1523 set valwidth
[expr $winwidth - $margin]
1525 $win configure
-state normal
1527 if {$which == "all"} {
1529 foreach regnum
$reg_display_list {
1530 set regval
[gdb_fetch_registers
$reg_format $regnum]
1531 set regval
[format "%-*s" $valwidth $regval]
1532 $win delete
$lineindex.
$margin "$lineindex.0 lineend"
1533 $win insert
$lineindex.
$margin $regval
1536 $win configure
-state disabled
1540 # Unhighlight the old values
1542 foreach regnum
$changed_reg_list {
1543 $win tag delete
$win.
$regnum
1546 # Now, highlight the changed values of the interesting registers
1548 set changed_reg_list
[eval gdb_changed_register_list
$reg_display_list]
1551 foreach regnum
$changed_reg_list {
1552 set regval
[gdb_fetch_registers
$reg_format $regnum]
1553 set regval
[format "%-*s" $valwidth $regval]
1555 set lineindex
$regmap($regnum)
1556 $win delete
$lineindex.
$margin "$lineindex.0 lineend"
1557 $win insert
$lineindex.
$margin $regval
1558 $win tag add
$win.
$regnum $lineindex.0 "$lineindex.0 lineend"
1559 eval $win tag configure
$win.
$regnum $highlight
1562 $win configure
-state disabled
1568 # update_assembly - Update the assembly window.
1572 # This procedure updates the assembly window.
1575 proc update_assembly
{linespec
} {
1577 global screen_height
1581 global current_label
1583 global file_to_debug_file
1584 global current_asm_label
1586 global asm_screen_height asm_screen_top asm_screen_bot
1589 # Rip the linespec apart
1591 set pc
[lindex $linespec 4]
1592 set line
[lindex $linespec 3]
1593 set filename [lindex $linespec 2]
1594 set funcname
[lindex $linespec 1]
1595 set debug_file
[lindex $linespec 0]
1597 set win
[asm_win_name
$cfunc]
1599 # Sometimes there's no source file for this location
1601 if {$filename == ""} {set filename Blank
}
1603 # If we want to switch funcs, we need to unpack the current text widget, and
1604 # stick in the new one.
1606 if {$funcname != $cfunc } {
1610 set win
[asm_win_name
$cfunc]
1612 # Create a text widget for this func if necessary
1614 if {![winfo exists
$win]} {
1615 create_asm_win
$cfunc $pc
1616 set asm_pointers
($cfunc) 1.1
1617 set current_asm_label NIL
1620 # Pack the text widget, and scroll to the right place
1623 pack $win -side left
-expand yes
-fill both
\
1625 .asm.scroll configure
-command "$win yview"
1626 set line
[pc_to_line
$pclist($cfunc) $pc]
1628 $win yview
[expr $line - $asm_screen_height / 2]
1631 # Update the label widget in case the filename or function name has changed
1633 if {$current_asm_label != "$pc $funcname"} then
{
1634 set .asm.
label "$pc $funcname"
1635 set current_asm_label
"$pc $funcname"
1638 # Update the pointer, scrolling the text widget if necessary to keep the
1639 # pointer in an acceptable part of the screen.
1641 if [info exists asm_pointers
($cfunc)] then
{
1642 $win configure
-state normal
1643 set pointer_pos
$asm_pointers($cfunc)
1644 $win configure
-state normal
1645 $win delete
$pointer_pos "$pointer_pos + 2 char"
1646 $win insert
$pointer_pos " "
1648 # Map the PC back to a line in the window
1650 set line
[pc_to_line
$pclist($cfunc) $pc]
1653 echo
"Can't find PC $pc"
1657 set pointer_pos
[$win index
$line.1]
1658 set asm_pointers
($cfunc) $pointer_pos
1660 $win delete
$pointer_pos "$pointer_pos + 2 char"
1661 $win insert
$pointer_pos "->"
1663 if {$line < $asm_screen_top + 1
1664 ||
$line > $asm_screen_bot} then
{
1665 $win yview
[expr $line - $asm_screen_height / 2]
1668 $win configure
-state disabled
1675 # update_ptr - Update the listing window.
1679 # This routine will update the listing window using the result of
1683 proc update_ptr
{} {
1684 update_listing
[gdb_loc
]
1685 if [winfo exists .asm
] {
1686 update_assembly
[gdb_loc
]
1688 if [winfo exists .reg
] {
1689 update_registers changed
1691 if [winfo exists .
expr] {
1696 # Make toplevel window disappear
1700 proc files_command
{} {
1701 toplevel .files_window
1703 wm minsize .files_window
1 1
1704 # wm overrideredirect .files_window true
1705 listbox .files_window.
list -geometry 30x20
-setgrid true
\
1706 -yscrollcommand {.files_window.scroll
set} -relief raised
\
1708 scrollbar .files_window.scroll
-orient vertical
\
1709 -command {.files_window.
list yview
}
1710 button .files_window.
close -text Close
-command {destroy .files_window
}
1711 tk_listboxSingleSelect .files_window.
list
1713 # Get the file list from GDB, sort it, and format it as one entry per line.
1715 set filelist
[join [lsort [gdb_listfiles
]] "\n"]
1717 # Now, remove duplicates (by using uniq)
1719 set fh
[open "| uniq > /tmp/gdbtk.[pid]" w
]
1722 set fh
[open /tmp
/gdbtk.
[pid]]
1723 set filelist
[split [read $fh] "\n"]
1724 set filelist
[lrange $filelist 0 [expr [llength $filelist] - 2]]
1726 exec rm
/tmp
/gdbtk.
[pid]
1728 # Insert the file list into the widget
1730 eval .files_window.
list insert
0 $filelist
1732 pack .files_window.
close -side bottom
-fill x
-expand no
-anchor s
1733 pack .files_window.scroll
-side right
-fill both
1734 pack .files_window.
list -side left
-fill both
-expand yes
1735 bind .files_window.
list <Any-ButtonRelease-1
> {
1736 set file [%W get
[%W curselection
]]
1737 gdb_cmd
"list $file:1,0"
1738 update_listing
[gdb_loc
$file:1]
1739 destroy .files_window
}
1742 button .files
-text Files
-command files_command
1744 proc apply_filespec
{label default command
} {
1745 set filename [FSBox
$label $default]
1746 if {$filename != ""} {
1747 if [catch {gdb_cmd
"$command $filename"} retval
] {
1748 tk_dialog .filespec_error
"gdb : $label error" \
1749 "Error in command \"$command $filename\"" {} 0 Dismiss
1756 # Setup command window
1758 proc build_framework
{win
{title GDBtk
} {label {}}} {
1762 wm title
${win
} $title
1763 wm minsize
${win
} 1 1
1765 frame ${win
}.menubar
1767 menubutton ${win
}.menubar.
file -padx 12 -text File
\
1768 -menu ${win
}.menubar.
file.
menu -underline 0
1770 menu ${win
}.menubar.
file.
menu
1771 ${win
}.menubar.
file.
menu add command
-label File...
\
1772 -command {apply_filespec File a.out
file}
1773 ${win
}.menubar.
file.
menu add command
-label Target...
\
1774 -command { not_implemented_yet
"target" }
1775 ${win
}.menubar.
file.
menu add command
-label Edit
\
1776 -command {exec $editor +[expr ($screen_top + $screen_bot)/2] $cfile &}
1777 ${win
}.menubar.
file.
menu add separator
1778 ${win
}.menubar.
file.
menu add command
-label "Exec File..." \
1779 -command {apply_filespec
{Exec File
} a.out exec-file
}
1780 ${win
}.menubar.
file.
menu add command
-label "Symbol File..." \
1781 -command {apply_filespec
{Symbol File
} a.out symbol-file
}
1782 ${win
}.menubar.
file.
menu add command
-label "Add Symbol File..." \
1783 -command { not_implemented_yet
"menu item, add symbol file" }
1784 ${win
}.menubar.
file.
menu add command
-label "Core File..." \
1785 -command {apply_filespec
{Core File
} core core-file
}
1787 ${win
}.menubar.
file.
menu add separator
1788 ${win
}.menubar.
file.
menu add command
-label Close
\
1789 -command "destroy ${win}"
1790 ${win
}.menubar.
file.
menu add separator
1791 ${win
}.menubar.
file.
menu add command
-label Quit
\
1792 -command { catch { gdb_cmd quit
} }
1794 menubutton ${win
}.menubar.commands
-padx 12 -text Commands
\
1795 -menu ${win
}.menubar.commands.
menu -underline 0
1797 menu ${win
}.menubar.commands.
menu
1798 ${win
}.menubar.commands.
menu add command
-label Run
\
1799 -command { catch {gdb_cmd run
} ; update_ptr
}
1800 ${win
}.menubar.commands.
menu add command
-label Step
\
1801 -command { catch { gdb_cmd step
} ; update_ptr
}
1802 ${win
}.menubar.commands.
menu add command
-label Next
\
1803 -command { catch { gdb_cmd next
} ; update_ptr
}
1804 ${win
}.menubar.commands.
menu add command
-label Continue
\
1805 -command { catch { gdb_cmd
continue } ; update_ptr
}
1806 ${win
}.menubar.commands.
menu add separator
1807 ${win
}.menubar.commands.
menu add command
-label Stepi
\
1808 -command { catch { gdb_cmd stepi
} ; update_ptr
}
1809 ${win
}.menubar.commands.
menu add command
-label Nexti
\
1810 -command { catch { gdb_cmd nexti
} ; update_ptr
}
1812 menubutton ${win
}.menubar.view
-padx 12 -text Options
\
1813 -menu ${win
}.menubar.view.
menu -underline 0
1815 menu ${win
}.menubar.view.
menu
1816 ${win
}.menubar.view.
menu add command
-label Hex
\
1818 ${win
}.menubar.view.
menu add command
-label Decimal
\
1819 -command {echo Decimal
}
1820 ${win
}.menubar.view.
menu add command
-label Octal
\
1821 -command {echo Octal
}
1823 menubutton ${win
}.menubar.window
-padx 12 -text Window
\
1824 -menu ${win
}.menubar.window.
menu -underline 0
1826 menu ${win
}.menubar.window.
menu
1827 ${win
}.menubar.window.
menu add command
-label Command
\
1828 -command create_command_window
1829 ${win
}.menubar.window.
menu add separator
1830 ${win
}.menubar.window.
menu add command
-label Source
\
1831 -command {create_source_window
; update_ptr
}
1832 ${win
}.menubar.window.
menu add command
-label Assembly
\
1833 -command {create_asm_window
; update_ptr
}
1834 ${win
}.menubar.window.
menu add separator
1835 ${win
}.menubar.window.
menu add command
-label Registers
\
1836 -command {create_registers_window
; update_ptr
}
1837 ${win
}.menubar.window.
menu add command
-label Expressions
\
1838 -command {create_expr_win
; update_ptr
}
1840 # ${win}.menubar.window.menu add separator
1841 # ${win}.menubar.window.menu add command -label Files \
1842 # -command { not_implemented_yet "files window" }
1844 menubutton ${win
}.menubar.help
-padx 12 -text Help
\
1845 -menu ${win
}.menubar.help.
menu -underline 0
1847 menu ${win
}.menubar.help.
menu
1848 ${win
}.menubar.help.
menu add command
-label "with GDBtk" \
1849 -command {echo
"with GDBtk"}
1850 ${win
}.menubar.help.
menu add command
-label "with this window" \
1851 -command {echo
"with this window"}
1852 ${win
}.menubar.help.
menu add command
-label "Report bug" \
1853 -command {exec send-pr
}
1855 tk_menuBar
${win
}.menubar
\
1856 ${win
}.menubar.
file \
1857 ${win
}.menubar.view
\
1858 ${win
}.menubar.window
\
1860 pack ${win
}.menubar.
file \
1861 ${win
}.menubar.view
\
1862 ${win
}.menubar.window
-side left
1863 pack ${win
}.menubar.help
-side right
1866 text ${win
}.
text -height 25 -width 80 -relief raised
-borderwidth 2 \
1867 -setgrid true
-cursor hand2
-yscrollcommand "${win}.scroll set"
1869 set ${win
}.
label $label
1870 label ${win
}.
label -textvariable ${win
}.
label -borderwidth 2 -relief raised
1872 scrollbar ${win
}.scroll
-orient vertical
-command "${win}.text yview"
1874 pack ${win
}.
label -side bottom
-fill x
-in ${win
}.
info
1875 pack ${win
}.scroll
-side right
-fill y
-in ${win
}.
info
1876 pack ${win
}.
text -side left
-expand yes
-fill both
-in ${win
}.
info
1878 pack ${win
}.menubar
-side top
-fill x
1879 pack ${win
}.
info -side top
-fill both
-expand yes
1882 proc create_source_window
{} {
1886 if [winfo exists .src
] {raise .src
; return}
1888 build_framework .src Source
"*No file*"
1890 # First, delete all the old view menu entries
1892 .src.menubar.view.
menu delete
0 last
1894 # Source file selection
1895 .src.menubar.view.
menu add command
-label "Select source file" \
1896 -command files_command
1898 # Line numbers enable/disable menu item
1899 .src.menubar.view.
menu add
checkbutton -variable line_numbers
\
1900 -label "Line numbers" -onvalue 1 -offvalue 0 -command {
1901 foreach source [array names wins
] {
1902 if {$source == "Blank"} continue
1903 destroy $wins($source)
1907 update_listing
[gdb_loc
]
1913 button .src.start
-width 6 -text Start
-command \
1914 {catch {gdb_cmd
{break main
}}
1915 catch {gdb_cmd
{enable delete
$bpnum}}
1918 button .src.stop
-width 6 -text Stop
-fg red
-activeforeground red
\
1919 -state disabled
-command gdb_stop
1920 button .src.step
-width 6 -text Step
\
1921 -command {catch {gdb_cmd step
} ; update_ptr
}
1922 button .src.next
-width 6 -text Next
\
1923 -command {catch {gdb_cmd next
} ; update_ptr
}
1924 button .src.
continue -width 6 -text Cont
\
1925 -command {catch {gdb_cmd
continue} ; update_ptr
}
1926 button .src.finish
-width 6 -text Finish
\
1927 -command {catch {gdb_cmd finish
} ; update_ptr
}
1928 button .src.up
-width 6 -text Up
\
1929 -command {catch {gdb_cmd up
} ; update_ptr
}
1930 button .src.down
-width 6 -text Down
\
1931 -command {catch {gdb_cmd down
} ; update_ptr
}
1932 button .src.bottom
-width 6 -text Bottom
\
1933 -command {catch {gdb_cmd
{frame 0}} ; update_ptr
}
1935 pack .src.start .src.step .src.
continue .src.up .src.bottom
\
1936 -side left
-padx 3 -pady 5 -in .src.row1
1937 pack .src.stop .src.next .src.finish .src.down
-side left
-padx 3 \
1938 -pady 5 -in .src.row2
1940 pack .src.row2 .src.row1
-side bottom
-anchor w
-before .src.
info
1942 $wins($cfile) insert
0.0 " This page intentionally left blank."
1943 $wins($cfile) configure
-width 88 -state disabled
\
1944 -yscrollcommand textscrollproc
1946 proc textscrollproc
{args
} {global screen_height screen_top screen_bot
1947 eval ".src.scroll set $args"
1948 set screen_height
[lindex $args 1]
1949 set screen_top
[lindex $args 2]
1950 set screen_bot
[lindex $args 3]}
1953 proc create_command_window
{} {
1956 if [winfo exists .cmd
] {raise .cmd
; return}
1958 build_framework .cmd Command
"* Command Buffer *"
1962 gdb_cmd
{set language c
}
1963 gdb_cmd
{set height
0}
1964 gdb_cmd
{set width
0}
1966 bind .cmd.
text <Enter
> {focus %W
}
1967 bind .cmd.
text <Delete
> {delete_char
%W
}
1968 bind .cmd.
text <BackSpace
> {delete_char
%W
}
1969 bind .cmd.
text <Control-u
> {delete_line
%W
}
1970 bind .cmd.
text <Any-Key
> {
1974 %W yview
-pickplace end
1975 append command_line
%A
1977 bind .cmd.
text <Key-Return
> {
1981 %W yview
-pickplace end
1982 catch "gdb_cmd [list $command_line]"
1985 %W insert end
"(gdb) "
1986 %W yview
-pickplace end
1988 bind .cmd.
text <Button-2
> {
1991 %W insert end
[selection get
]
1992 %W yview
-pickplace end
1993 append command_line
[selection get
]
1995 proc delete_char
{win
} {
1998 tk_textBackspace
$win
1999 $win yview
-pickplace insert
2000 set tmp
[expr [string length
$command_line] - 2]
2001 set command_line
[string range
$command_line 0 $tmp]
2003 proc delete_line
{win
} {
2006 $win delete
{end linestart
+ 6 chars
} end
2007 $win yview
-pickplace insert
2014 # simple file selector.
2016 # Mario Jorge Silva msilva@cs.Berkeley.EDU
2017 # University of California Berkeley Ph: +1(510)642-8248
2018 # Computer Science Division, 571 Evans Hall Fax: +1(510)642-5775
2022 # Copyright 1993 Regents of the University of California
2023 # Permission to use, copy, modify, and distribute this
2024 # software and its documentation for any purpose and without
2025 # fee is hereby granted, provided that this copyright
2026 # notice appears in all copies. The University of California
2027 # makes no representations about the suitability of this
2028 # software for any purpose. It is provided "as is" without
2029 # express or implied warranty.
2033 # names starting with "fileselect" are reserved by this module
2034 # no other names used.
2035 # Hack - FSBox is defined instead of fileselect for backwards compatibility
2038 # this is the proc that creates the file selector box
2039 # purpose - comment string
2040 # defaultName - initial value for name
2041 # cmd - command to eval upon OK
2042 # errorHandler - command to eval upon Cancel
2043 # If neither cmd or errorHandler are specified, the return value
2044 # of the FSBox procedure is the selected file name.
2046 proc FSBox
{{purpose
"Select file:"} {defaultName
""} {cmd
""} {errorHandler
2050 if [Exwin_Toplevel
$w "Select File" FileSelect
] {
2051 # path independent names for the widgets
2053 set fileselect
(list) $w.
file.sframe.
list
2054 set fileselect
(scroll
) $w.
file.sframe.scroll
2055 set fileselect
(direntry
) $w.
file.f1.direntry
2056 set fileselect
(entry) $w.
file.f2.
entry
2057 set fileselect
(ok
) $w.but.ok
2058 set fileselect
(cancel
) $w.but.cancel
2059 set fileselect
(msg
) $w.
label
2061 set fileselect
(result
) "" ;# value to return if no callback procedures
2064 Widget_Label
$w label {top fillx pady
10 padx
20} -anchor w
-width 24
2065 Widget_Frame
$w file Dialog
{left expand fill
} -bd 10
2067 Widget_Frame
$w.
file f1 Exmh
{top fillx
}
2068 Widget_Label
$w.
file.f1
label {left
} -text "Dir"
2069 Widget_Entry
$w.
file.f1 direntry
{right fillx expand
} -width 30
2071 Widget_Frame
$w.
file sframe
2073 scrollbar $w.
file.sframe.yscroll
-relief sunken
\
2074 -command [list $w.
file.sframe.
list yview
]
2075 listbox $w.
file.sframe.
list -relief sunken
\
2076 -yscroll [list $w.
file.sframe.yscroll
set] -setgrid 1
2077 pack append $w.
file.sframe
\
2078 $w.
file.sframe.yscroll
{right filly
} \
2079 $w.
file.sframe.
list {left expand fill
}
2081 Widget_Frame
$w.
file f2 Exmh
{top fillx
}
2082 Widget_Label
$w.
file.f2
label {left
} -text Name
2083 Widget_Entry
$w.
file.f2
entry {right fillx expand
}
2086 $w.but.quit configure
-text Cancel
\
2087 -command [list fileselect.cancel.cmd
$w]
2089 Widget_AddBut
$w.but ok OK
\
2090 [list fileselect.ok.cmd
$w $cmd $errorHandler] {left padx
1}
2092 Widget_AddBut
$w.but
list List
\
2093 [list fileselect.
list.cmd
$w] {left padx
1}
2094 Widget_CheckBut
$w.but listall
"List all" fileselect
(pattern
)
2095 $w.but.listall configure
-onvalue "{*,.*}" -offvalue "*" \
2096 -command {fileselect.
list.cmd
$fileselect(direntry
)}
2097 $w.but.listall deselect
2099 # Set up bindings for the browser.
2100 foreach ww
[list $w $fileselect(entry)] {
2101 bind $ww <Return
> [list $fileselect(ok
) invoke
]
2102 bind $ww <Control-c
> [list $fileselect(cancel
) invoke
]
2104 bind $fileselect(direntry
) <Return
> [list fileselect.
list.cmd
%W
]
2105 bind $fileselect(direntry
) <Tab
> [list fileselect.tab.dircmd
]
2106 bind $fileselect(entry) <Tab
> [list fileselect.tab.filecmd
]
2108 tk_listboxSingleSelect
$fileselect(list)
2111 bind $fileselect(list) <Button-1
> {
2112 # puts stderr "button 1 release"
2113 %W select from
[%W nearest
%y
]
2114 $fileselect(entry) delete
0 end
2115 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2118 bind $fileselect(list) <Key
> {
2119 %W select from
[%W nearest
%y
]
2120 $fileselect(entry) delete
0 end
2121 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2124 bind $fileselect(list) <Double-ButtonPress-1
> {
2125 # puts stderr "double button 1"
2126 %W select from
[%W nearest
%y
]
2127 $fileselect(entry) delete
0 end
2128 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2129 $fileselect(ok
) invoke
2132 bind $fileselect(list) <Return
> {
2133 %W select from
[%W nearest
%y
]
2134 $fileselect(entry) delete
0 end
2135 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2136 $fileselect(ok
) invoke
2139 set fileselect
(text) $purpose
2140 $fileselect(msg
) configure
-text $purpose
2141 $fileselect(entry) delete
0 end
2142 $fileselect(entry) insert
0 [file tail
$defaultName]
2144 if {[info exists fileselect
(lastDir
)] && ![string length
$defaultName]} {
2145 set dir
$fileselect(lastDir
)
2147 set dir
[file dirname
$defaultName]
2149 set fileselect
(pwd) [pwd]
2151 $fileselect(direntry
) delete
0 end
2152 $fileselect(direntry
) insert
0 [pwd]/
2154 $fileselect(list) delete
0 end
2155 $fileselect(list) insert
0 "Big directory:"
2156 $fileselect(list) insert
1 $dir
2157 $fileselect(list) insert
2 "Press Return for Listing"
2159 fileselect.
list.cmd
$fileselect(direntry
) startup
2161 # set kbd focus to entry widget
2163 # Exwin_ToplevelFocus $w $fileselect(entry)
2165 # Wait for button hits if no callbacks are defined
2167 if {"$cmd" == "" && "$errorHandler" == ""} {
2168 # wait for the box to be destroyed
2171 tkwait variable fileselect
(result
)
2174 set path
$fileselect(result
)
2175 set fileselect
(lastDir
) [pwd]
2176 fileselect.
cd $fileselect(pwd)
2177 return [string trimright
[string trim
$path] /]
2179 fileselect.
cd $fileselect(pwd)
2183 proc fileselect.
cd { dir
} {
2185 if [catch {cd $dir} err
] {
2190 # auxiliary button procedures
2192 proc fileselect.yck
{ {tag
{}} } {
2194 $fileselect(msg
) configure
-text "Yck! $tag"
2196 proc fileselect.ok
{} {
2198 $fileselect(msg
) configure
-text $fileselect(text)
2201 proc fileselect.cancel.cmd
{w
} {
2203 set fileselect
(result
) {}
2207 proc fileselect.
list.cmd
{w
{state normal
}} {
2209 set seldir
[$fileselect(direntry
) get
]
2210 if {[catch {glob $seldir} dir
]} {
2211 fileselect.yck
"glob failed"
2214 if {[llength $dir] > 1} {
2215 set dir
[file dirname
$seldir]
2216 set pat
[file tail
$seldir]
2218 set pat
$fileselect(pattern
)
2222 if [file isdirectory
$dir] {
2223 fileselect.getfiles
$dir $pat $state
2224 focus $fileselect(entry)
2226 fileselect.yck
"not a dir"
2230 proc fileselect.ok.cmd
{w cmd errorHandler
} {
2232 set selname
[$fileselect(entry) get
]
2233 set seldir
[$fileselect(direntry
) get
]
2235 if [string match
/* $selname] {
2236 set selected
$selname
2238 if [string match ~
* $selname] {
2239 set selected
$selname
2241 set selected
$seldir/$selname
2245 # some nasty file names may cause "file isdirectory" to return an error
2246 if [catch {file isdirectory
$selected} isdir
] {
2247 fileselect.yck
"isdirectory failed"
2250 if [catch {glob $selected} globlist
] {
2251 if ![file isdirectory
[file dirname
$selected]] {
2252 fileselect.yck
"bad pathname"
2255 set globlist
$selected
2260 if {[llength $globlist] > 1} {
2261 set dir
[file dirname
$selected]
2262 set pat
[file tail
$selected]
2263 fileselect.getfiles
$dir $pat
2266 set selected
$globlist
2268 if [file isdirectory
$selected] {
2269 fileselect.getfiles
$selected $fileselect(pattern
)
2270 $fileselect(entry) delete
0 end
2277 set fileselect
(result
) $selected
2282 proc fileselect.getfiles
{ dir
{pat
*} {state normal
} } {
2284 $fileselect(msg
) configure
-text Listing...
2287 set currentDir
[pwd]
2289 if [catch {set files
[lsort [glob -nocomplain $pat]]} err
] {
2290 $fileselect(msg
) configure
-text $err
2291 $fileselect(list) delete
0 end
2297 # Normal case - show current directory
2298 $fileselect(direntry
) delete
0 end
2299 $fileselect(direntry
) insert
0 [pwd]/
2302 # Directory already OK (tab related)
2305 # Changing directory (tab related)
2306 fileselect.
cd $currentDir
2309 # Avoid listing huge directories upon startup.
2310 $fileselect(direntry
) delete
0 end
2311 $fileselect(direntry
) insert
0 [pwd]/
2312 if {[llength $files] > 32} {
2319 # build a reordered list of the files: directories are displayed first
2320 # and marked with a trailing "/"
2321 if [string compare
$dir /] {
2322 fileselect.putfiles
$files [expr {($pat == "*") ?
1 : 0}]
2324 fileselect.putfiles
$files
2329 proc fileselect.putfiles
{files
{dotdot
0} } {
2332 $fileselect(list) delete
0 end
2334 $fileselect(list) insert end
"../"
2337 if {[file isdirectory
$i]} {
2338 $fileselect(list) insert end
$i/
2340 $fileselect(list) insert end
$i
2345 proc FileExistsDialog
{ name
} {
2348 set fileExists
(ok
) 0
2350 message $w.msg
-aspect 1000
2351 pack $w.msg
-side top
-fill both
-padx 20 -pady 20
2352 $w.but.quit config
-text Cancel
-command {FileExistsCancel
}
2353 button $w.but.ok
-text OK
-command {FileExistsOK
}
2354 pack $w.but.ok
-side left
2355 bind $w.msg
<Return
> {FileExistsOK
}
2357 $w.msg config
-text "Warning: file exists
2359 OK to overwrite it?"
2361 set fileExists
(focus) [focus]
2364 tkwait variable fileExists
(ok
)
2367 return $fileExists(ok
)
2369 proc FileExistsCancel
{} {
2371 set fileExists
(ok
) 0
2373 proc FileExistsOK
{} {
2375 set fileExists
(ok
) 1
2378 proc fileselect.getfiledir
{ dir
{basedir
[pwd]} } {
2381 set path
[$fileselect(direntry
) get
]
2385 if {[string index
$path 0] == "~"} {
2389 set path
[$fileselect(entry) get
]
2391 if [catch {set listFile
[glob -nocomplain $path*]}] {
2394 foreach el
$listFile {
2396 if [file isdirectory
$el] {
2397 lappend returnList
[file tail
$el]
2399 } elseif
![file isdirectory
$el] {
2400 lappend returnList
[file tail
$el]
2407 proc fileselect.gethead
{ list } {
2410 for {set i
0} {[string length
[lindex $list 0]] > $i}\
2411 {incr i
; set returnHead
$returnHead$thisChar} {
2412 set thisChar
[string index
[lindex $list 0] $i]
2414 if {[string length
$el] < $i} {
2417 if {$thisChar != [string index
$el $i]} {
2425 proc fileselect.expand.tilde
{ } {
2428 set entry [$fileselect(direntry
) get
]
2429 set dir
[string range
$entry 1 [string length
$entry]]
2437 ## look in /etc/passwd
2438 if [file exists
/etc
/passwd
] {
2439 if [catch {set users
[exec cat
/etc
/passwd | sed s
/:.
*//]} err
] {
2440 puts "Error\#1 $err"
2443 set list [split $users "\n"]
2445 if {[lsearch -exact $list "+"] != -1} {
2446 if [catch {set users
[exec ypcat passwd | sed s
/:.
*//]} err
] {
2447 puts "Error\#2 $err"
2450 set list [concat $list [split $users "\n"]]
2452 $fileselect(list) delete
0 end
2454 if [string match
$dir* $el] {
2455 lappend listmatch
$el
2456 $fileselect(list) insert end
$el
2459 set addings
[fileselect.gethead
$listmatch]
2460 if {$addings == ""} {
2463 $fileselect(direntry
) delete
0 end
2464 if {[llength $listmatch] == 1} {
2465 $fileselect(direntry
) insert
0 [file dirname ~
$addings/]
2466 fileselect.getfiles
[$fileselect(direntry
) get
]
2468 $fileselect(direntry
) insert
0 ~
$addings
2472 proc fileselect.tab.dircmd
{ } {
2475 set dir
[$fileselect(direntry
) get
]
2477 $fileselect(direntry
) delete
0 end
2478 $fileselect(direntry
) insert
0 [pwd]
2479 if [string compare
[pwd] "/"] {
2480 $fileselect(direntry
) insert end
/
2484 if [catch {set tmp
[file isdirectory
[file dirname
$dir]]}] {
2485 if {[string index
$dir 0] == "~"} {
2486 fileselect.expand.tilde
2493 set dirFile
[fileselect.getfiledir
1 $dir]
2494 if ![llength $dirFile] {
2497 if {[llength $dirFile] == 1} {
2498 $fileselect(direntry
) delete
0 end
2499 $fileselect(direntry
) insert
0 [file dirname
$dir]
2500 if [string compare
[file dirname
$dir] /] {
2501 $fileselect(direntry
) insert end
/[lindex $dirFile 0]/
2503 $fileselect(direntry
) insert end
[lindex $dirFile 0]/
2505 fileselect.getfiles
[$fileselect(direntry
) get
] \
2506 "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
2509 set headFile
[fileselect.gethead
$dirFile]
2510 $fileselect(direntry
) delete
0 end
2511 $fileselect(direntry
) insert
0 [file dirname
$dir]
2512 if [string compare
[file dirname
$dir] /] {
2513 $fileselect(direntry
) insert end
/$headFile
2515 $fileselect(direntry
) insert end
$headFile
2517 if {$headFile == "" && [file isdirectory
$dir]} {
2518 fileselect.getfiles
$dir\
2519 "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
2521 fileselect.getfiles
[file dirname
$dir]\
2522 "[file tail [$fileselect(direntry) get]]*" newdir
2526 proc fileselect.tab.filecmd
{ } {
2529 set dir
[$fileselect(direntry
) get
]
2533 if {![file isdirectory
$dir]} {
2534 error "dir $dir doesn't exist"
2536 set listFile
[fileselect.getfiledir
0 $dir]
2538 if ![llength $listFile] {
2541 if {[llength $listFile] == 1} {
2542 $fileselect(entry) delete
0 end
2543 $fileselect(entry) insert
0 [lindex $listFile 0]
2546 set headFile
[fileselect.gethead
$listFile]
2547 $fileselect(entry) delete
0 end
2548 $fileselect(entry) insert
0 $headFile
2549 fileselect.getfiles
$dir "[$fileselect(entry) get]$fileselect(pattern)" opt
2552 proc Exwin_Toplevel
{ path name
{class Dialog
} {dismiss yes
}} {
2554 if [catch {wm state
$path} state
] {
2555 set t
[Widget_Toplevel
$path $name $class]
2556 if ![info exists exwin
(toplevels
)] {
2557 set exwin
(toplevels
) [option get . exwinPaths
{}]
2559 set ix
[lsearch $exwin(toplevels
) $t]
2561 lappend exwin
(toplevels
) $t
2563 if {$dismiss == "yes"} {
2564 set f
[Widget_Frame
$t but Menubar
{top fill
}]
2565 Widget_AddBut
$f quit
"Dismiss" [list Exwin_Dismiss
$path]
2569 if {$state != "normal"} {
2571 wm geometry
$path $exwin(geometry
,$path)
2572 # Exmh_Debug Exwin_Toplevel $path $exwin(geometry,$path)
2582 proc Exwin_Dismiss
{ path
{geo ok
} } {
2586 set exwin
(geometry
,$path) [wm geometry
$path]
2589 set exwin
(geometry
,$path) [string trimleft
[wm geometry
$path] 0123456789x
]
2592 catch {unset exwin
(geometry
,$path)}
2598 proc Widget_Toplevel
{ path name
{class Dialog
} {x
{}} {y
{}} } {
2599 set self
[toplevel $path -class $class]
2600 set usergeo
[option get
$path position Position
]
2601 if {$usergeo != {}} {
2602 if [catch {wm geometry
$self $usergeo} err
] {
2603 # Exmh_Debug Widget_Toplevel $self $usergeo => $err
2606 if {($x != {}) && ($y != {})} {
2607 # Exmh_Debug Event position $self +$x+$y
2608 wm geometry
$self +$x+$y
2611 wm title
$self $name
2616 proc Widget_Frame
{par child
{class GDB
} {where
{top expand fill
}} args
} {
2620 set self
$par.
$child
2622 eval {frame $self -class $class} $args
2623 pack append $par $self $where
2627 proc Widget_AddBut
{par but txt cmd
{where
{right padx
1}} } {
2628 # Create a Packed button. Return the button pathname
2629 set cmd2
[list button $par.
$but -text $txt -command $cmd]
2630 if [catch $cmd2 t
] {
2631 puts stderr
"Widget_AddBut (warning) $t"
2632 eval $cmd2 {-font fixed
}
2634 pack append $par $par.
$but $where
2637 proc Widget_CheckBut
{par but txt var
{where
{right padx
1}} } {
2638 # Create a check button. Return the button pathname
2639 set cmd
[list checkbutton $par.
$but -text $txt -variable $var]
2641 puts stderr
"Widget_CheckBut (warning) $t"
2642 eval $cmd {-font fixed
}
2644 pack append $par $par.
$but $where
2648 proc Widget_Label
{ frame {name
label} {where
{left fill
}} args
} {
2649 set cmd
[list label $frame.
$name ]
2650 if [catch [concat $cmd $args] t
] {
2651 puts stderr
"Widget_Label (warning) $t"
2652 eval $cmd $args {-font fixed
}
2654 pack append $frame $frame.
$name $where
2657 proc Widget_Entry
{ frame {name
entry} {where
{left fill
}} args
} {
2658 set cmd
[list entry $frame.
$name ]
2659 if [catch [concat $cmd $args] t
] {
2660 puts stderr
"Widget_Entry (warning) $t"
2661 eval $cmd $args {-font fixed
}
2663 pack append $frame $frame.
$name $where
2667 # End of fileselect.tcl.
2669 # Setup the initial windows
2671 create_source_window
2673 if {[tk colormodel .src.
text] == "color"} {
2674 set highlight
"-background red2 -borderwidth 2 -relief sunk"
2676 set fg
[lindex [.src.
text config
-foreground] 4]
2677 set bg
[lindex [.src.
text config
-background] 4]
2678 set highlight
"-foreground $bg -background $fg -borderwidth 0"
2681 create_command_window
2683 # Create a copyright window
2686 wm geometry .c
+300+300
2687 wm overrideredirect .c true
2690 set temp
$current_output_win
2691 set current_output_win .t
2692 gdb_cmd
"show version"
2693 set current_output_win
$temp
2695 message .c.m
-text [.t get
0.0 end
] -aspect 500 -relief raised
2698 bind .c.m
<Leave
> {destroy .c
}
2700 if [file exists ~
/.gdbtkinit
] {