4 set wins
($cfile) .src.
text
9 set current_output_win .cmd.
text
12 set breakpoint_file
(-1) {[garbage
]}
14 #option add *Foreground Black
15 #option add *Background White
16 #option add *Font -*-*-medium-r-normal--18-*-*-*-m-*-*-1
17 tk colormodel . monochrome
19 proc echo
string {puts stdout
$string}
21 if [info exists env
(EDITOR
)] then
{
22 set editor
$env(EDITOR
)
29 # These functions are called by GDB (from C code) to do various things in
30 # TK-land. All start with the prefix `gdbtk_tcl_' to make them easy to find.
36 # gdbtk_tcl_fputs (text) - Output text to the command window
40 # GDB calls this to output TEXT to the GDB command window. The text is
41 # placed at the end of the text widget. Note that output may not occur,
42 # due to buffering. Use gdbtk_tcl_flush to cause an immediate update.
45 proc gdbtk_tcl_fputs
{arg
} {
46 global current_output_win
48 $current_output_win insert end
"$arg"
49 $current_output_win yview
-pickplace end
52 proc gdbtk_tcl_fputs_error
{arg
} {
53 .cmd.
text insert end
"$arg"
54 .cmd.
text yview
-pickplace end
60 # gdbtk_tcl_flush () - Flush output to the command window
64 # GDB calls this to force all buffered text to the GDB command window.
67 proc gdbtk_tcl_flush
{} {
68 global current_output_win
70 $current_output_win yview
-pickplace end
77 # gdbtk_tcl_query (message) - Create a yes/no query dialog box
81 # GDB calls this to create a yes/no dialog box containing MESSAGE. GDB
82 # is hung while the dialog box is active (ie: no commands will work),
83 # however windows can still be refreshed in case of damage or exposure.
86 proc gdbtk_tcl_query
{message} {
87 tk_dialog .query
"gdb : query" "$message" {} 1 "No" "Yes"
93 # gdbtk_start_variable_annotation (args ...) -
97 # Not yet implemented.
100 proc gdbtk_tcl_start_variable_annotation
{valaddr ref_type stor_cl cum_expr field type_cast
} {
101 echo
"gdbtk_tcl_start_variable_annotation $valaddr $ref_type $stor_cl $cum_expr $field $type_cast"
107 # gdbtk_end_variable_annotation (args ...) -
111 # Not yet implemented.
114 proc gdbtk_tcl_end_variable_annotation
{} {
115 echo gdbtk_tcl_end_variable_annotation
121 # gdbtk_tcl_breakpoint (action bpnum file line) - Notify the TK
122 # interface of changes to breakpoints.
126 # GDB calls this to notify TK of changes to breakpoints. ACTION is one
128 # create - Notify of breakpoint creation
129 # delete - Notify of breakpoint deletion
130 # enable - Notify of breakpoint enabling
131 # disable - Notify of breakpoint disabling
133 # All actions take the same set of arguments: BPNUM is the breakpoint
134 # number, FILE is the source file and LINE is the line number, and PC is
135 # the pc of the affected breakpoint.
138 proc gdbtk_tcl_breakpoint
{action bpnum
file line pc
} {
139 ${action
}_breakpoint
$bpnum $file $line $pc
142 proc asm_win_name
{funcname
} {
143 if {$funcname == "*None*"} {return .asm.
text}
145 regsub -all {\.
} $funcname _ temp
147 return .asm.func_
${temp
}
153 # create_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
157 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
158 # land of breakpoint creation. This consists of recording the file and
159 # line number in the breakpoint_file and breakpoint_line arrays. Also,
160 # if there is already a window associated with FILE, it is updated with
164 proc create_breakpoint
{bpnum
file line pc
} {
166 global breakpoint_file
167 global breakpoint_line
168 global pos_to_breakpoint
169 global pos_to_bpcount
173 # Record breakpoint locations
175 set breakpoint_file
($bpnum) $file
176 set breakpoint_line
($bpnum) $line
177 set pos_to_breakpoint
($file:$line) $bpnum
178 if ![info exists pos_to_bpcount
($file:$line)] {
179 set pos_to_bpcount
($file:$line) 0
181 incr pos_to_bpcount
($file:$line)
182 set pos_to_breakpoint
($pc) $bpnum
183 if ![info exists pos_to_bpcount
($pc)] {
184 set pos_to_bpcount
($pc) 0
186 incr pos_to_bpcount
($pc)
188 # If there's a window for this file, update it
190 if [info exists wins
($file)] {
191 insert_breakpoint_tag
$wins($file) $line
194 # If there's an assembly window, update that too
196 set win
[asm_win_name
$cfunc]
197 if [winfo exists
$win] {
198 insert_breakpoint_tag
$win [pc_to_line
$pclist($cfunc) $pc]
205 # delete_breakpoint (bpnum file line pc) - Delete breakpoint info from TK land
209 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
210 # land of breakpoint destruction. This consists of removing the file and
211 # line number from the breakpoint_file and breakpoint_line arrays. Also,
212 # if there is already a window associated with FILE, the tags are removed
216 proc delete_breakpoint
{bpnum
file line pc
} {
218 global breakpoint_file
219 global breakpoint_line
220 global pos_to_breakpoint
221 global pos_to_bpcount
224 # Save line number and file for later
226 set line
$breakpoint_line($bpnum)
228 set file $breakpoint_file($bpnum)
230 # Reset breakpoint annotation info
232 if {$pos_to_bpcount($file:$line) > 0} {
233 decr pos_to_bpcount
($file:$line)
235 if {$pos_to_bpcount($file:$line) == 0} {
236 catch "unset pos_to_breakpoint($file:$line)"
238 unset breakpoint_file
($bpnum)
239 unset breakpoint_line
($bpnum)
241 # If there's a window for this file, update it
243 if [info exists wins
($file)] {
244 delete_breakpoint_tag
$wins($file) $line
249 # If there's an assembly window, update that too
251 if {$pos_to_bpcount($pc) > 0} {
252 decr pos_to_bpcount
($pc)
254 if {$pos_to_bpcount($pc) == 0} {
255 catch "unset pos_to_breakpoint($pc)"
257 set win
[asm_win_name
$cfunc]
258 if [winfo exists
$win] {
259 delete_breakpoint_tag
$win [pc_to_line
$pclist($cfunc) $pc]
268 # enable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
272 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
273 # land of a breakpoint being enabled. This consists of unstippling the
274 # specified breakpoint indicator.
277 proc enable_breakpoint
{bpnum
file line pc
} {
281 if [info exists wins
($file)] {
282 $wins($file) tag configure
$line -fgstipple {}
285 # If there's an assembly window, update that too
287 set win
[asm_win_name
$cfunc]
288 if [winfo exists
$win] {
289 $win tag configure
[pc_to_line
$pclist($cfunc) $pc] -fgstipple {}
296 # disable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
300 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
301 # land of a breakpoint being disabled. This consists of stippling the
302 # specified breakpoint indicator.
305 proc disable_breakpoint
{bpnum
file line pc
} {
309 if [info exists wins
($file)] {
310 $wins($file) tag configure
$line -fgstipple gray50
313 # If there's an assembly window, update that too
315 set win
[asm_win_name
$cfunc]
316 if [winfo exists
$win] {
317 $win tag configure
[pc_to_line
$pclist($cfunc) $pc] -fgstipple gray50
324 # insert_breakpoint_tag (win line) - Insert a breakpoint tag in WIN.
328 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to insert a
329 # breakpoint tag into window WIN at line LINE.
332 proc insert_breakpoint_tag
{win line
} {
333 $win configure
-state normal
335 $win insert
$line.0 "B"
336 $win tag add
$line $line.0
337 $win tag add delete
$line.0 "$line.0 lineend"
338 $win tag add margin
$line.0 "$line.0 lineend"
340 $win configure
-state disabled
346 # delete_breakpoint_tag (win line) - Remove a breakpoint tag from WIN.
350 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to remove a
351 # breakpoint tag from window WIN at line LINE.
354 proc delete_breakpoint_tag
{win line
} {
355 $win configure
-state normal
357 if {[string range
$win 0 3] == ".src"} then
{
358 $win insert
$line.0 "\xa4"
360 $win insert
$line.0 " "
362 $win tag delete
$line
363 $win tag add delete
$line.0 "$line.0 lineend"
364 $win tag add margin
$line.0 "$line.0 lineend"
365 $win configure
-state disabled
368 proc gdbtk_tcl_busy
{} {
369 if [winfo exists .src
] {
370 catch {.src.start configure
-state disabled
}
371 catch {.src.stop configure
-state normal
}
372 catch {.src.step configure
-state disabled
}
373 catch {.src.next configure
-state disabled
}
374 catch {.src.
continue configure
-state disabled
}
375 catch {.src.finish configure
-state disabled
}
376 catch {.src.up configure
-state disabled
}
377 catch {.src.down configure
-state disabled
}
378 catch {.src.bottom configure
-state disabled
}
380 if [winfo exists .asm
] {
381 catch {.asm.stepi configure
-state disabled
}
382 catch {.asm.nexti configure
-state disabled
}
383 catch {.asm.
continue configure
-state disabled
}
384 catch {.asm.finish configure
-state disabled
}
385 catch {.asm.up configure
-state disabled
}
386 catch {.asm.down configure
-state disabled
}
387 catch {.asm.bottom configure
-state disabled
}
388 catch {.asm.
close configure
-state disabled
}
392 proc gdbtk_tcl_idle
{} {
393 if [winfo exists .src
] {
394 catch {.src.start configure
-state normal
}
395 catch {.src.stop configure
-state disabled
}
396 catch {.src.step configure
-state normal
}
397 catch {.src.next configure
-state normal
}
398 catch {.src.
continue configure
-state normal
}
399 catch {.src.finish configure
-state normal
}
400 catch {.src.up configure
-state normal
}
401 catch {.src.down configure
-state normal
}
402 catch {.src.bottom configure
-state normal
}
405 if [winfo exists .asm
] {
406 catch {.asm.stepi configure
-state normal
}
407 catch {.asm.nexti configure
-state normal
}
408 catch {.asm.
continue configure
-state normal
}
409 catch {.asm.finish configure
-state normal
}
410 catch {.asm.up configure
-state normal
}
411 catch {.asm.down configure
-state normal
}
412 catch {.asm.bottom configure
-state normal
}
413 catch {.asm.
close configure
-state normal
}
420 # decr (var val) - compliment to incr
425 proc decr
{var
{val
1}} {
427 set num
[expr $num - $val]
434 # pc_to_line (pclist pc) - convert PC to a line number.
438 # Convert PC to a line number from PCLIST. If exact line isn't found,
439 # we return the first line that starts before PC.
441 proc pc_to_line
{pclist pc
} {
442 set line
[lsearch -exact $pclist $pc]
444 if {$line >= 1} { return $line }
447 foreach linepc
[lrange $pclist 1 end
] {
448 if {$pc < $linepc} { decr line
; return $line }
451 return [expr $line - 1]
457 # file popup menu - Define the file popup menu.
461 # This menu just contains a bunch of buttons that do various things to
462 # the line under the cursor.
466 # Edit - Run the editor (specified by the environment variable EDITOR) on
467 # this file, at the current line.
468 # Breakpoint - Set a breakpoint at the current line. This just shoves
469 # a `break' command at GDB with the appropriate file and line
470 # number. Eventually, GDB calls us back (at gdbtk_tcl_breakpoint)
471 # to notify us of where the breakpoint needs to show up.
474 menu .file_popup
-cursor hand2
475 .file_popup add command
-label "Not yet set" -state disabled
476 .file_popup add separator
477 .file_popup add command
-label "Edit" -command {exec $editor +$selected_line $selected_file &}
478 .file_popup add command
-label "Set breakpoint" -command {gdb_cmd
"break $selected_file:$selected_line"}
483 # file popup menu - Define the file popup menu bindings.
487 # This defines the binding for the file popup menu. Currently, there is
488 # only one, which is activated when Button-1 is released. This causes
489 # the menu to be unposted, releases the grab for the menu, and then
490 # unhighlights the line under the cursor. After that, the selected menu
494 bind .file_popup
<Any-ButtonRelease-1
> {
497 # First, remove the menu, and release the pointer
500 grab release .file_popup
502 # Unhighlight the selected line
504 $selected_win tag delete breaktag
506 # Actually invoke the menubutton here!
514 # file_popup_menu (win x y xrel yrel) - Popup the file popup menu.
518 # This procedure is invoked as a result of a command binding in the
519 # listing window. It does several things:
520 # o - It highlights the line under the cursor.
521 # o - It pops up the file popup menu which is intended to do
522 # various things to the aforementioned line.
523 # o - Grabs the mouse for the file popup menu.
526 # Button 1 has been pressed in a listing window. Pop up a menu.
528 proc file_popup_menu
{win x y xrel yrel
} {
531 global file_to_debug_file
537 # Map TK window name back to file name.
539 set file $win_to_file($win)
541 set pos
[$win index
@$xrel,$yrel]
543 # Record selected file and line for menu button actions
545 set selected_file
$file_to_debug_file($file)
546 set selected_line
[lindex [split $pos .
] 0]
547 set selected_win
$win
549 # Highlight the selected line
551 eval $win tag config breaktag
$highlight
552 $win tag add breaktag
"$pos linestart" "$pos linestart + 1l"
554 # Post the menu near the pointer, (and grab it)
556 .file_popup entryconfigure
0 -label "$selected_file:$selected_line"
557 .file_popup post
[expr $x-[winfo width .file_popup
]/2] [expr $y-10]
564 # listing_window_button_1 (win x y xrel yrel) - Handle button 1 in listing window
568 # This procedure is invoked as a result of holding down button 1 in the
569 # listing window. The action taken depends upon where the button was
570 # pressed. If it was in the left margin (the breakpoint column), it
571 # sets or clears a breakpoint. In the main text area, it will pop up a
575 proc listing_window_button_1
{win x y xrel yrel
} {
578 global file_to_debug_file
583 global pos_to_breakpoint
585 # Map TK window name back to file name.
587 set file $win_to_file($win)
589 set pos
[split [$win index
@$xrel,$yrel] .
]
591 # Record selected file and line for menu button actions
593 set selected_file
$file_to_debug_file($file)
594 set selected_line
[lindex $pos 0]
595 set selected_col
[lindex $pos 1]
596 set selected_win
$win
598 # If we're in the margin, then toggle the breakpoint
600 if {$selected_col < 8} {
601 set pos_break
$selected_file:$selected_line
602 set pos
$file:$selected_line
603 set tmp pos_to_breakpoint
($pos)
604 if [info exists
$tmp] {
606 gdb_cmd
"delete $bpnum"
608 gdb_cmd
"break $pos_break"
613 # Post the menu near the pointer, (and grab it)
615 .file_popup entryconfigure
0 -label "$selected_file:$selected_line"
616 .file_popup post
[expr $x-[winfo width .file_popup
]/2] [expr $y-10]
623 # asm_window_button_1 (win x y xrel yrel) - Handle button 1 in asm window
627 # This procedure is invoked as a result of holding down button 1 in the
628 # assembly window. The action taken depends upon where the button was
629 # pressed. If it was in the left margin (the breakpoint column), it
630 # sets or clears a breakpoint. In the main text area, it will pop up a
634 proc asm_window_button_1
{win x y xrel yrel
} {
637 global file_to_debug_file
642 global pos_to_breakpoint
646 set pos
[split [$win index
@$xrel,$yrel] .
]
648 # Record selected file and line for menu button actions
650 set selected_line
[lindex $pos 0]
651 set selected_col
[lindex $pos 1]
652 set selected_win
$win
656 set pc
[lindex $pclist($cfunc) $selected_line]
658 # If we're in the margin, then toggle the breakpoint
660 if {$selected_col < 11} {
661 set tmp pos_to_breakpoint
($pc)
662 if [info exists
$tmp] {
664 gdb_cmd
"delete $bpnum"
671 # Post the menu near the pointer, (and grab it)
673 # .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
674 # .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
681 # do_nothing - Does absolutely nothing.
685 # This procedure does nothing. It is used as a placeholder to allow
686 # the disabling of bindings that would normally be inherited from the
687 # parent widget. I can't think of any other way to do this.
690 proc do_nothing
{} {}
695 # not_implemented_yet - warn that a feature is unavailable
699 # This procedure warns that something doesn't actually work yet.
702 proc not_implemented_yet
{message} {
703 tk_dialog .unimpl
"gdb : unimpl" \
704 "$message: not implemented in the interface yet" \
711 # create_expr_win - Create expression display window
715 # Create the expression display window.
718 proc create_expr_win
{} {
721 wm title .
expr Expression
722 canvas .
expr.c
-yscrollcommand {.
expr.scroll
set} -cursor hand2
\
723 -borderwidth 2 -relief groove
724 scrollbar .
expr.scroll
-orient vertical
-command {.
expr.c yview
}
725 entry .
expr.
entry -borderwidth 2 -relief groove
727 pack .
expr.
entry -side bottom
-fill x
728 pack .
expr.c
-side left
-fill both
-expand yes
729 pack .
expr.scroll
-side right
-fill y
731 .
expr.c create
text 100 0 -text "Text string"
732 .
expr.c create rectangle
245 195 255 205 -outline black
-fill white
738 # display_expression (expression) - Display EXPRESSION in display window
742 # Display EXPRESSION and its value in the expression display window.
745 proc display_expression
{expression
} {
746 if ![winfo exists .
expr] {create_expr_win
}
754 # create_file_win (filename) - Create a win for FILENAME.
758 # The new text widget.
762 # This procedure creates a text widget for FILENAME. It returns the
763 # newly created widget. First, a text widget is created, and given basic
764 # configuration info. Second, all the bindings are setup. Third, the
765 # file FILENAME is read into the text widget. Fourth, margins and line
769 proc create_file_win
{filename debug_file
} {
770 global breakpoint_file
771 global breakpoint_line
774 # Replace all the dirty characters in $filename with clean ones, and generate
775 # a unique name for the text widget.
777 regsub -all {\.
} $filename {} temp
778 set win .src.
text$temp
780 # Open the file, and read it into the text widget
782 if [catch "open $filename" fh
] {
783 # File can't be read. Put error message into .src.nofile window and return.
785 catch {destroy .src.nofile
}
786 text .src.nofile
-height 25 -width 88 -relief raised
\
787 -borderwidth 2 -yscrollcommand textscrollproc
\
788 -setgrid true
-cursor hand2
789 .src.nofile insert
0.0 $fh
790 .src.nofile configure
-state disabled
791 bind .src.nofile
<1> do_nothing
792 bind .src.nofile
<B1-Motion
> do_nothing
796 # Actually create and do basic configuration on the text widget.
798 text $win -height 25 -width 88 -relief raised
-borderwidth 2 \
799 -yscrollcommand textscrollproc
-setgrid true
-cursor hand2
801 # Setup all the bindings
803 bind $win <Enter
> {focus %W
}
804 # bind $win <1> {listing_window_button_1 %W %X %Y %x %y}
805 bind $win <1> do_nothing
806 bind $win <B1-Motion
> do_nothing
808 bind $win n
{catch {gdb_cmd next
} ; update_ptr
}
809 bind $win s
{catch {gdb_cmd step
} ; update_ptr
}
810 bind $win c
{catch {gdb_cmd
continue} ; update_ptr
}
811 bind $win f
{catch {gdb_cmd finish
} ; update_ptr
}
812 bind $win u
{catch {gdb_cmd up
} ; update_ptr
}
813 bind $win d
{catch {gdb_cmd down
} ; update_ptr
}
816 $win insert
0.0 [read $fh]
819 # Add margins (for annotations) and a line number to each line (if requested)
821 set numlines
[$win index end
]
822 set numlines
[lindex [split $numlines .
] 0]
824 for {set i
1} {$i <= $numlines} {incr i
} {
825 $win insert
$i.0 [format " %4d " $i]
826 $win tag add
source $i.8 "$i.0 lineend"
829 for {set i
1} {$i <= $numlines} {incr i
} {
831 $win tag add
source $i.8 "$i.0 lineend"
837 foreach i
[gdb_sourcelines
$debug_file] {
839 $win insert
$i.0 "\xa4"
840 $win tag add margin
$i.0 $i.8
843 $win tag
bind margin
<1> {listing_window_button_1
%W
%X
%Y
%x
%y
}
844 $win tag
bind source <1> {
845 %W mark
set anchor
"@%x,%y wordstart"
846 set last
[%W index
"@%x,%y wordend"]
847 %W tag remove sel
0.0 anchor
848 %W tag remove sel
$last end
849 %W tag add sel anchor
$last
851 # $win tag bind source <Double-Button-1> {
852 # %W mark set anchor "@%x,%y wordstart"
853 # set last [%W index "@%x,%y wordend"]
854 # %W tag remove sel 0.0 anchor
855 # %W tag remove sel $last end
856 # %W tag add sel anchor $last
857 # echo "Selected [selection get]"
859 $win tag
bind source <B1-Motion
> {
860 %W tag remove sel
0.0 anchor
861 %W tag remove sel
$last end
862 %W tag add sel anchor
@%x
,%y
864 $win tag
bind sel
<1> do_nothing
865 $win tag
bind sel
<Double-Button-1
> {display_expression
[selection get
]}
869 # Scan though the breakpoint data base and install any destined for this file
871 foreach bpnum
[array names breakpoint_file
] {
872 if {$breakpoint_file($bpnum) == $filename} {
873 insert_breakpoint_tag
$win $breakpoint_line($bpnum)
877 # Disable the text widget to prevent user modifications
879 $win configure
-state disabled
886 # create_asm_win (funcname pc) - Create an assembly win for FUNCNAME.
890 # The new text widget.
894 # This procedure creates a text widget for FUNCNAME. 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 # function FUNCNAME is read into the text widget.
900 proc create_asm_win
{funcname pc
} {
901 global breakpoint_file
902 global breakpoint_line
903 global current_output_win
906 # Replace all the dirty characters in $filename with clean ones, and generate
907 # a unique name for the text widget.
909 set win
[asm_win_name
$funcname]
911 # Actually create and do basic configuration on the text widget.
913 text $win -height 25 -width 88 -relief raised
-borderwidth 2 \
914 -setgrid true
-cursor hand2
-yscrollcommand asmscrollproc
916 # Setup all the bindings
918 bind $win <Enter
> {focus %W
}
919 bind $win <1> {asm_window_button_1
%W
%X
%Y
%x
%y
}
920 bind $win <B1-Motion
> do_nothing
921 bind $win n
{catch {gdb_cmd nexti
} ; update_ptr
}
922 bind $win s
{catch {gdb_cmd stepi
} ; update_ptr
}
923 bind $win c
{catch {gdb_cmd
continue} ; update_ptr
}
924 bind $win f
{catch {gdb_cmd finish
} ; update_ptr
}
925 bind $win u
{catch {gdb_cmd up
} ; update_ptr
}
926 bind $win d
{catch {gdb_cmd down
} ; update_ptr
}
928 # Disassemble the code, and read it into the new text widget
930 set temp
$current_output_win
931 set current_output_win
$win
932 gdb_cmd
"disassemble $pc"
933 set current_output_win
$temp
935 set numlines
[$win index end
]
936 set numlines
[lindex [split $numlines .
] 0]
939 # Delete the first and last lines, cuz these contain useless info
942 $win delete
{end
- 1 lines
} end
945 # Add margins (for annotations) and note the PC for each line
947 catch "unset pclist($funcname)"
948 lappend pclist
($funcname) Unused
949 for {set i
1} {$i <= $numlines} {incr i
} {
950 scan [$win get
$i.0 "$i.0 lineend"] "%s " pc
951 lappend pclist
($funcname) $pc
956 # Scan though the breakpoint data base and install any destined for this file
958 # foreach bpnum [array names breakpoint_file] {
959 # if {$breakpoint_file($bpnum) == $filename} {
960 # insert_breakpoint_tag $win $breakpoint_line($bpnum)
964 # Disable the text widget to prevent user modifications
966 $win configure
-state disabled
973 # asmscrollproc (WINHEIGHT SCREENHEIGHT SCREENTOP SCREENBOT) - Update the
974 # asm window scrollbar.
978 # This procedure is called to update the assembler window's scrollbar.
981 proc asmscrollproc
{args
} {
982 global asm_screen_height asm_screen_top asm_screen_bot
984 eval ".asm.scroll set $args"
985 set asm_screen_height
[lindex $args 1]
986 set asm_screen_top
[lindex $args 2]
987 set asm_screen_bot
[lindex $args 3]
993 # update_listing (linespec) - Update the listing window according to
998 # This procedure is called from various places to update the listing
999 # window based on LINESPEC. It is usually invoked with the result of
1002 # It will move the cursor, and scroll the text widget if necessary.
1003 # Also, it will switch to another text widget if necessary, and update
1004 # the label widget too.
1006 # LINESPEC is a list of the form:
1008 # { DEBUG_FILE FUNCNAME FILENAME LINE }, where:
1010 # DEBUG_FILE - is the abbreviated form of the file name. This is usually
1011 # the file name string given to the cc command. This is
1012 # primarily needed for breakpoint commands, and when an
1013 # abbreviated for of the filename is desired.
1014 # FUNCNAME - is the name of the function.
1015 # FILENAME - is the fully qualified (absolute) file name. It is usually
1016 # the same as $PWD/$DEBUG_FILE, where PWD is the working dir
1017 # at the time the cc command was given. This is used to
1018 # actually locate the file to be displayed.
1019 # LINE - The line number to be displayed.
1021 # Usually, this procedure will just move the cursor one line down to the
1022 # next line to be executed. However, if the cursor moves out of range
1023 # or into another file, it will scroll the text widget so that the line
1024 # of interest is in the middle of the viewable portion of the widget.
1027 proc update_listing
{linespec
} {
1029 global screen_height
1033 global current_label
1035 global file_to_debug_file
1038 # Rip the linespec apart
1040 set line
[lindex $linespec 3]
1041 set filename [lindex $linespec 2]
1042 set funcname
[lindex $linespec 1]
1043 set debug_file
[lindex $linespec 0]
1045 # Sometimes there's no source file for this location
1047 if {$filename == ""} {set filename Blank
}
1049 # If we want to switch files, we need to unpack the current text widget, and
1050 # stick in the new one.
1052 if {$filename != $cfile} then
{
1053 pack forget
$wins($cfile)
1056 # Create a text widget for this file if necessary
1058 if ![info exists wins
($cfile)] then
{
1059 set wins
($cfile) [create_file_win
$cfile $debug_file]
1060 if {$wins($cfile) != ".src.nofile"} {
1061 set win_to_file
($wins($cfile)) $cfile
1062 set file_to_debug_file
($cfile) $debug_file
1063 set pointers
($cfile) 1.1
1067 # Pack the text widget into the listing widget, and scroll to the right place
1069 pack $wins($cfile) -side left
-expand yes
-in .src.
info \
1070 -fill both
-after .src.scroll
1072 # Make the scrollbar point at the new text widget
1074 .src.scroll configure
-command "$wins($cfile) yview"
1076 $wins($cfile) yview
[expr $line - $screen_height / 2]
1079 # Update the label widget in case the filename or function name has changed
1081 if {$current_label != "$filename.$funcname"} then
{
1082 set tail
[expr [string last
/ $filename] + 1]
1083 set .src.
label "[string range $filename $tail end] : ${funcname}()"
1084 # .src.label configure -text "[string range $filename $tail end] : ${funcname}()"
1085 set current_label
$filename.
$funcname
1088 # Update the pointer, scrolling the text widget if necessary to keep the
1089 # pointer in an acceptable part of the screen.
1091 if [info exists pointers
($cfile)] then
{
1092 $wins($cfile) configure
-state normal
1093 set pointer_pos
$pointers($cfile)
1094 $wins($cfile) configure
-state normal
1095 $wins($cfile) delete
$pointer_pos "$pointer_pos + 2 char"
1096 $wins($cfile) insert
$pointer_pos " "
1098 set pointer_pos
[$wins($cfile) index
$line.1]
1099 set pointers
($cfile) $pointer_pos
1101 $wins($cfile) delete
$pointer_pos "$pointer_pos + 2 char"
1102 $wins($cfile) insert
$pointer_pos "->"
1104 if {$line < $screen_top + 1
1105 ||
$line > $screen_bot} then
{
1106 $wins($cfile) yview
[expr $line - $screen_height / 2]
1109 $wins($cfile) configure
-state disabled
1116 # create_asm_window - Open up the assembly window.
1120 # Create an assembly window if it doesn't exist.
1123 proc create_asm_window
{} {
1126 if ![winfo exists .asm
] {
1128 set win
[asm_win_name
$cfunc]
1130 build_framework .asm Assembly
"*NIL*"
1132 .asm.
text configure
-yscrollcommand asmscrollproc
1137 button .asm.stepi
-width 6 -text Stepi
\
1138 -command {catch {gdb_cmd stepi
} ; update_ptr
}
1139 button .asm.nexti
-width 6 -text Nexti
\
1140 -command {catch {gdb_cmd nexti
} ; update_ptr
}
1141 button .asm.
continue -width 6 -text Cont
\
1142 -command {catch {gdb_cmd
continue} ; update_ptr
}
1143 button .asm.finish
-width 6 -text Finish
\
1144 -command {catch {gdb_cmd finish
} ; update_ptr
}
1145 button .asm.up
-width 6 -text Up
-command {catch {gdb_cmd up
} ; update_ptr
}
1146 button .asm.down
-width 6 -text Down
\
1147 -command {catch {gdb_cmd down
} ; update_ptr
}
1148 button .asm.bottom
-width 6 -text Bottom
\
1149 -command {catch {gdb_cmd
{frame 0}} ; update_ptr
}
1151 pack .asm.stepi .asm.
continue .asm.up .asm.bottom
-side left
-padx 3 -pady 5 -in .asm.row1
1152 pack .asm.nexti .asm.finish .asm.down
-side left
-padx 3 -pady 5 -in .asm.row2
1154 pack .asm.row2 .asm.row1
-side bottom
-anchor w
-before .asm.
info
1158 update_assembly
[gdb_loc
]
1162 proc reg_config_menu
{} {
1163 catch {destroy .reg.config
}
1164 toplevel .reg.config
1165 wm geometry .reg.config
+300+300
1166 wm title .reg.config
"Register configuration"
1167 wm iconname .reg.config
"Reg config"
1168 set regnames
[gdb_regnames
]
1169 set num_regs
[llength $regnames]
1171 frame .reg.config.buts
1173 button .reg.config.done
-text " Done " -command "
1174 recompute_reg_display_list $num_regs
1176 update_registers all
1177 destroy .reg.config "
1179 button .reg.config.
update -text Update
-command "
1180 recompute_reg_display_list $num_regs
1182 update_registers all "
1184 pack .reg.config.buts
-side bottom
-fill x
1186 pack .reg.config.done
-side left
-fill x
-expand yes
-in .reg.config.buts
1187 pack .reg.config.
update -side right
-fill x
-expand yes
-in .reg.config.buts
1189 # Since there can be lots of registers, we build the window with no more than
1190 # 32 rows, and as many columns as needed.
1192 # First, figure out how many columns we need and create that many column frame
1195 set ncols
[expr ($num_regs + 31) / 32]
1197 for {set col
0} {$col < $ncols} {incr col
} {
1198 frame .reg.config.col
$col
1199 pack .reg.config.col
$col -side left
-anchor n
1202 # Now, create the checkbutton widgets and pack them in the appropriate columns
1206 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1207 set regname
[lindex $regnames $regnum]
1208 checkbutton .reg.config.col
$col.
$row -text $regname -pady 0 \
1209 -variable regena
($regnum) -relief flat
-anchor w
-bd 1
1211 pack .reg.config.col
$col.
$row -side top
-fill both
1224 # create_registers_window - Open up the register display window.
1228 # Create the register display window, with automatic updates.
1231 proc create_registers_window
{} {
1234 if [winfo exists .reg
] return
1236 # Create an initial register display list consisting of all registers
1238 if ![info exists reg_format
] {
1239 global reg_display_list
1240 global changed_reg_list
1244 set num_regs
[llength [gdb_regnames
]]
1245 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1246 set regena
($regnum) 1
1248 recompute_reg_display_list
$num_regs
1249 set changed_reg_list
$reg_display_list
1252 build_framework .reg Registers
1254 # First, delete all the old menu entries
1256 .reg.menubar.view.
menu delete
0 last
1259 .reg.menubar.view.
menu add
radiobutton -variable reg_format
\
1260 -label Hex
-value x
-command {update_registers all
}
1263 .reg.menubar.view.
menu add
radiobutton -variable reg_format
\
1264 -label Decimal
-value d
-command {update_registers all
}
1267 .reg.menubar.view.
menu add
radiobutton -variable reg_format
\
1268 -label Octal
-value o
-command {update_registers all
}
1271 .reg.menubar.view.
menu add
radiobutton -variable reg_format
\
1272 -label Natural
-value {} -command {update_registers all
}
1275 .reg.menubar.view.
menu add separator
1277 .reg.menubar.view.
menu add command
-label Config
-command {
1282 # Install the reg names
1285 update_registers all
1288 # Convert regena into a list of the enabled $regnums
1290 proc recompute_reg_display_list
{num_regs
} {
1291 global reg_display_list
1295 catch {unset reg_display_list
}
1298 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1300 if {[set regena
($regnum)] != 0} {
1301 lappend reg_display_list
$regnum
1302 set regmap
($regnum) $line
1308 # Fill out the register window with the names of the regs specified in
1311 proc populate_reg_window
{} {
1312 global max_regname_width
1313 global reg_display_list
1315 .reg.
text configure
-state normal
1317 .reg.
text delete
0.0 end
1319 set regnames
[eval gdb_regnames
$reg_display_list]
1321 # Figure out the longest register name
1323 set max_regname_width
0
1325 foreach reg
$regnames {
1326 set len
[string length
$reg]
1327 if {$len > $max_regname_width} {set max_regname_width
$len}
1330 set width
[expr $max_regname_width + 15]
1332 set height
[llength $regnames]
1334 if {$height > 60} {set height
60}
1336 .reg.
text configure
-height $height -width $width
1338 foreach reg
$regnames {
1339 .reg.
text insert end
[format "%-*s \n" $max_regname_width ${reg
}]
1343 .reg.
text configure
-state disabled
1349 # update_registers - Update the registers window.
1353 # This procedure updates the registers window.
1356 proc update_registers
{which
} {
1357 global max_regname_width
1359 global reg_display_list
1360 global changed_reg_list
1364 set margin
[expr $max_regname_width + 1]
1366 set winwidth
[lindex [$win configure
-width] 4]
1367 set valwidth
[expr $winwidth - $margin]
1369 $win configure
-state normal
1371 if {$which == "all"} {
1373 foreach regnum
$reg_display_list {
1374 set regval
[gdb_fetch_registers
$reg_format $regnum]
1375 set regval
[format "%-*s" $valwidth $regval]
1376 $win delete
$lineindex.
$margin "$lineindex.0 lineend"
1377 $win insert
$lineindex.
$margin $regval
1380 $win configure
-state disabled
1384 # Unhighlight the old values
1386 foreach regnum
$changed_reg_list {
1387 $win tag delete
$win.
$regnum
1390 # Now, highlight the changed values of the interesting registers
1392 set changed_reg_list
[eval gdb_changed_register_list
$reg_display_list]
1395 foreach regnum
$changed_reg_list {
1396 set regval
[gdb_fetch_registers
$reg_format $regnum]
1397 set regval
[format "%-*s" $valwidth $regval]
1399 set lineindex
$regmap($regnum)
1400 $win delete
$lineindex.
$margin "$lineindex.0 lineend"
1401 $win insert
$lineindex.
$margin $regval
1402 $win tag add
$win.
$regnum $lineindex.0 "$lineindex.0 lineend"
1403 eval $win tag configure
$win.
$regnum $highlight
1406 $win configure
-state disabled
1412 # update_assembly - Update the assembly window.
1416 # This procedure updates the assembly window.
1419 proc update_assembly
{linespec
} {
1421 global screen_height
1425 global current_label
1427 global file_to_debug_file
1428 global current_asm_label
1430 global asm_screen_height asm_screen_top asm_screen_bot
1433 # Rip the linespec apart
1435 set pc
[lindex $linespec 4]
1436 set line
[lindex $linespec 3]
1437 set filename [lindex $linespec 2]
1438 set funcname
[lindex $linespec 1]
1439 set debug_file
[lindex $linespec 0]
1441 set win
[asm_win_name
$cfunc]
1443 # Sometimes there's no source file for this location
1445 if {$filename == ""} {set filename Blank
}
1447 # If we want to switch funcs, we need to unpack the current text widget, and
1448 # stick in the new one.
1450 if {$funcname != $cfunc } {
1454 set win
[asm_win_name
$cfunc]
1456 # Create a text widget for this func if necessary
1458 if {![winfo exists
$win]} {
1459 create_asm_win
$cfunc $pc
1460 set asm_pointers
($cfunc) 1.1
1461 set current_asm_label NIL
1464 # Pack the text widget, and scroll to the right place
1467 pack $win -side left
-expand yes
-fill both
\
1469 .asm.scroll configure
-command "$win yview"
1470 set line
[pc_to_line
$pclist($cfunc) $pc]
1472 $win yview
[expr $line - $asm_screen_height / 2]
1475 # Update the label widget in case the filename or function name has changed
1477 if {$current_asm_label != "$pc $funcname"} then
{
1478 set .asm.
label "$pc $funcname"
1479 set current_asm_label
"$pc $funcname"
1482 # Update the pointer, scrolling the text widget if necessary to keep the
1483 # pointer in an acceptable part of the screen.
1485 if [info exists asm_pointers
($cfunc)] then
{
1486 $win configure
-state normal
1487 set pointer_pos
$asm_pointers($cfunc)
1488 $win configure
-state normal
1489 $win delete
$pointer_pos "$pointer_pos + 2 char"
1490 $win insert
$pointer_pos " "
1492 # Map the PC back to a line in the window
1494 set line
[pc_to_line
$pclist($cfunc) $pc]
1497 echo
"Can't find PC $pc"
1501 set pointer_pos
[$win index
$line.1]
1502 set asm_pointers
($cfunc) $pointer_pos
1504 $win delete
$pointer_pos "$pointer_pos + 2 char"
1505 $win insert
$pointer_pos "->"
1507 if {$line < $asm_screen_top + 1
1508 ||
$line > $asm_screen_bot} then
{
1509 $win yview
[expr $line - $asm_screen_height / 2]
1512 $win configure
-state disabled
1519 # update_ptr - Update the listing window.
1523 # This routine will update the listing window using the result of
1527 proc update_ptr
{} {
1528 update_listing
[gdb_loc
]
1529 if [winfo exists .asm
] {
1530 update_assembly
[gdb_loc
]
1532 if [winfo exists .reg
] {
1533 update_registers changed
1537 # Make toplevel window disappear
1541 proc files_command
{} {
1542 toplevel .files_window
1544 wm minsize .files_window
1 1
1545 # wm overrideredirect .files_window true
1546 listbox .files_window.
list -geometry 30x20
-setgrid true
1547 button .files_window.
close -text Close
-command {destroy .files_window
}
1548 tk_listboxSingleSelect .files_window.
list
1549 eval .files_window.
list insert
0 [lsort [gdb_listfiles
]]
1550 pack .files_window.
list -side top
-fill both
-expand yes
1551 pack .files_window.
close -side bottom
-fill x
-expand no
-anchor s
1552 bind .files_window.
list <Any-ButtonRelease-1
> {
1553 set file [%W get
[%W curselection
]]
1554 gdb_cmd
"list $file:1,0"
1555 update_listing
[gdb_loc
$file:1]
1556 destroy .files_window
}
1559 button .files
-text Files
-command files_command
1561 # Setup command window
1563 proc build_framework
{win
{title GDBtk
} {label {}}} {
1567 wm title
${win
} $title
1568 wm minsize
${win
} 1 1
1570 frame ${win
}.menubar
1572 menubutton ${win
}.menubar.
file -padx 12 -text File
\
1573 -menu ${win
}.menubar.
file.
menu -underline 0
1575 menu ${win
}.menubar.
file.
menu
1576 ${win
}.menubar.
file.
menu add command
-label File...
\
1578 set filename [FSBox
"File" "a.out"]
1579 gdb_cmd
"file $filename"
1582 ${win
}.menubar.
file.
menu add command
-label Target...
\
1583 -command { not_implemented_yet
"target" }
1584 ${win
}.menubar.
file.
menu add command
-label Edit
\
1585 -command {exec $editor +[expr ($screen_top + $screen_bot)/2] $cfile &}
1586 ${win
}.menubar.
file.
menu add separator
1587 ${win
}.menubar.
file.
menu add command
-label "Exec File..." \
1589 set filename [FSBox
"Exec File" "a.out"]
1590 gdb_cmd
"exec-file $filename"
1593 ${win
}.menubar.
file.
menu add command
-label "Symbol File..." \
1595 set filename [FSBox
"Symbol File" "a.out"]
1596 gdb_cmd
"symbol-file $filename"
1599 ${win
}.menubar.
file.
menu add command
-label "Add Symbol File..." \
1600 -command { not_implemented_yet
"menu item, add symbol file" }
1601 ${win
}.menubar.
file.
menu add command
-label "Core File..." \
1603 set filename [FSBox
"Core File" "core"]
1604 gdb_cmd
"core-file $filename"
1607 ${win
}.menubar.
file.
menu add separator
1608 ${win
}.menubar.
file.
menu add command
-label Close
\
1609 -command "destroy ${win}"
1610 ${win
}.menubar.
file.
menu add separator
1611 ${win
}.menubar.
file.
menu add command
-label Quit
\
1612 -command { catch { gdb_cmd quit
} }
1614 menubutton ${win
}.menubar.commands
-padx 12 -text Commands
\
1615 -menu ${win
}.menubar.commands.
menu -underline 0
1617 menu ${win
}.menubar.commands.
menu
1618 ${win
}.menubar.commands.
menu add command
-label Run
\
1619 -command { catch {gdb_cmd run
} ; update_ptr
}
1620 ${win
}.menubar.commands.
menu add command
-label Step
\
1621 -command { catch { gdb_cmd step
} ; update_ptr
}
1622 ${win
}.menubar.commands.
menu add command
-label Next
\
1623 -command { catch { gdb_cmd next
} ; update_ptr
}
1624 ${win
}.menubar.commands.
menu add command
-label Continue
\
1625 -command { catch { gdb_cmd
continue } ; update_ptr
}
1626 ${win
}.menubar.commands.
menu add separator
1627 ${win
}.menubar.commands.
menu add command
-label Stepi
\
1628 -command { catch { gdb_cmd stepi
} ; update_ptr
}
1629 ${win
}.menubar.commands.
menu add command
-label Nexti
\
1630 -command { catch { gdb_cmd nexti
} ; update_ptr
}
1632 menubutton ${win
}.menubar.view
-padx 12 -text View
\
1633 -menu ${win
}.menubar.view.
menu -underline 0
1635 menu ${win
}.menubar.view.
menu
1636 ${win
}.menubar.view.
menu add command
-label Hex
\
1638 ${win
}.menubar.view.
menu add command
-label Decimal
\
1639 -command {echo Decimal
}
1640 ${win
}.menubar.view.
menu add command
-label Octal
\
1641 -command {echo Octal
}
1643 menubutton ${win
}.menubar.window
-padx 12 -text Window
\
1644 -menu ${win
}.menubar.window.
menu -underline 0
1646 menu ${win
}.menubar.window.
menu
1647 ${win
}.menubar.window.
menu add command
-label Command
\
1648 -command {echo Command
}
1649 ${win
}.menubar.window.
menu add separator
1650 ${win
}.menubar.window.
menu add command
-label Source
\
1651 -command {echo Source
}
1652 ${win
}.menubar.window.
menu add command
-label Assembly
\
1653 -command {create_asm_window
; update_ptr
}
1654 ${win
}.menubar.window.
menu add separator
1655 ${win
}.menubar.window.
menu add command
-label Registers
\
1656 -command {create_registers_window
; update_ptr
}
1657 ${win
}.menubar.window.
menu add command
-label Stack
\
1658 -command { not_implemented_yet
"stack window" }
1659 ${win
}.menubar.window.
menu add separator
1660 ${win
}.menubar.window.
menu add command
-label Files
\
1661 -command { not_implemented_yet
"files window" }
1662 ${win
}.menubar.window.
menu add separator
1663 ${win
}.menubar.window.
menu add command
-label Breakpoints
\
1664 -command { not_implemented_yet
"breakpoints window" }
1665 ${win
}.menubar.window.
menu add command
-label Signals
\
1666 -command { not_implemented_yet
"signals window" }
1667 ${win
}.menubar.window.
menu add command
-label Variables
\
1668 -command { not_implemented_yet
"variables window" }
1670 menubutton ${win
}.menubar.help
-padx 12 -text Help
\
1671 -menu ${win
}.menubar.help.
menu -underline 0
1673 menu ${win
}.menubar.help.
menu
1674 ${win
}.menubar.help.
menu add command
-label "with GDBtk" \
1675 -command {echo
"with GDBtk"}
1676 ${win
}.menubar.help.
menu add command
-label "with this window" \
1677 -command {echo
"with this window"}
1678 ${win
}.menubar.help.
menu add command
-label "Report bug" \
1679 -command {exec send-pr
}
1681 tk_menuBar
${win
}.menubar
\
1682 ${win
}.menubar.
file \
1683 ${win
}.menubar.commands
\
1684 ${win
}.menubar.view
\
1685 ${win
}.menubar.window
\
1687 pack ${win
}.menubar.
file \
1688 ${win
}.menubar.commands
\
1689 ${win
}.menubar.view
\
1690 ${win
}.menubar.window
-side left
1691 pack ${win
}.menubar.help
-side right
1694 text ${win
}.
text -height 25 -width 80 -relief raised
-borderwidth 2 \
1695 -setgrid true
-cursor hand2
-yscrollcommand "${win}.scroll set"
1697 set ${win
}.
label $label
1698 label ${win
}.
label -textvariable ${win
}.
label -borderwidth 2 -relief raised
1700 scrollbar ${win
}.scroll
-orient vertical
-command "${win}.text yview"
1702 pack ${win
}.
label -side bottom
-fill x
-in ${win
}.
info
1703 pack ${win
}.scroll
-side right
-fill y
-in ${win
}.
info
1704 pack ${win
}.
text -side left
-expand yes
-fill both
-in ${win
}.
info
1706 pack ${win
}.menubar
-side top
-fill x
1707 pack ${win
}.
info -side top
-fill both
-expand yes
1710 proc create_source_window
{} {
1714 build_framework .src Source
"*No file*"
1716 # First, delete all the old view menu entries
1718 .src.menubar.view.
menu delete
0 last
1720 # Source file selection
1721 .src.menubar.view.
menu add command
-label "Select source file" \
1722 -command files_command
1724 # Line numbers enable/disable menu item
1725 .src.menubar.view.
menu add
checkbutton -variable line_numbers
\
1726 -label "Line numbers" -onvalue 1 -offvalue 0 -command {
1727 foreach source [array names wins
] {
1728 if {$source == "Blank"} continue
1729 destroy $wins($source)
1733 update_listing
[gdb_loc
]
1739 button .src.start
-width 6 -text Start
-command \
1740 {catch {gdb_cmd
{break main
}}
1741 catch {gdb_cmd
{enable delete
$bpnum}}
1744 button .src.stop
-width 6 -text Stop
-fg red
-activeforeground red
\
1745 -state disabled
-command gdb_stop
1746 button .src.step
-width 6 -text Step
\
1747 -command {catch {gdb_cmd step
} ; update_ptr
}
1748 button .src.next
-width 6 -text Next
\
1749 -command {catch {gdb_cmd next
} ; update_ptr
}
1750 button .src.
continue -width 6 -text Cont
\
1751 -command {catch {gdb_cmd
continue} ; update_ptr
}
1752 button .src.finish
-width 6 -text Finish
\
1753 -command {catch {gdb_cmd finish
} ; update_ptr
}
1754 button .src.up
-width 6 -text Up
\
1755 -command {catch {gdb_cmd up
} ; update_ptr
}
1756 button .src.down
-width 6 -text Down
\
1757 -command {catch {gdb_cmd down
} ; update_ptr
}
1758 button .src.bottom
-width 6 -text Bottom
\
1759 -command {catch {gdb_cmd
{frame 0}} ; update_ptr
}
1761 pack .src.start .src.step .src.
continue .src.up .src.bottom
\
1762 -side left
-padx 3 -pady 5 -in .src.row1
1763 pack .src.stop .src.next .src.finish .src.down
-side left
-padx 3 \
1764 -pady 5 -in .src.row2
1766 pack .src.row2 .src.row1
-side bottom
-anchor w
-before .src.
info
1768 $wins($cfile) insert
0.0 " This page intentionally left blank."
1769 $wins($cfile) configure
-width 88 -state disabled
\
1770 -yscrollcommand textscrollproc
1772 proc textscrollproc
{args
} {global screen_height screen_top screen_bot
1773 eval ".src.scroll set $args"
1774 set screen_height
[lindex $args 1]
1775 set screen_top
[lindex $args 2]
1776 set screen_bot
[lindex $args 3]}
1779 proc create_command_window
{} {
1782 build_framework .cmd Command
"* Command Buffer *"
1786 gdb_cmd
{set language c
}
1787 gdb_cmd
{set height
0}
1788 gdb_cmd
{set width
0}
1790 bind .cmd.
text <Enter
> {focus %W
}
1791 bind .cmd.
text <Delete
> {delete_char
%W
}
1792 bind .cmd.
text <BackSpace
> {delete_char
%W
}
1793 bind .cmd.
text <Control-u
> {delete_line
%W
}
1794 bind .cmd.
text <Any-Key
> {
1798 %W yview
-pickplace end
1799 append command_line
%A
1801 bind .cmd.
text <Key-Return
> {
1805 %W yview
-pickplace end
1806 catch "gdb_cmd [list $command_line]"
1809 %W insert end
"(gdb) "
1810 %W yview
-pickplace end
1813 proc delete_char
{win
} {
1816 tk_textBackspace
$win
1817 $win yview
-pickplace insert
1818 set tmp
[expr [string length
$command_line] - 2]
1819 set command_line
[string range
$command_line 0 $tmp]
1822 proc delete_line
{win
} {
1825 $win delete
{end linestart
+ 6 chars
} end
1826 $win yview
-pickplace insert
1833 # simple file selector.
1835 # Mario Jorge Silva msilva@cs.Berkeley.EDU
1836 # University of California Berkeley Ph: +1(510)642-8248
1837 # Computer Science Division, 571 Evans Hall Fax: +1(510)642-5775
1841 # Copyright 1993 Regents of the University of California
1842 # Permission to use, copy, modify, and distribute this
1843 # software and its documentation for any purpose and without
1844 # fee is hereby granted, provided that this copyright
1845 # notice appears in all copies. The University of California
1846 # makes no representations about the suitability of this
1847 # software for any purpose. It is provided "as is" without
1848 # express or implied warranty.
1852 # names starting with "fileselect" are reserved by this module
1853 # no other names used.
1854 # Hack - FSBox is defined instead of fileselect for backwards compatibility
1857 # this is the proc that creates the file selector box
1858 # purpose - comment string
1859 # defaultName - initial value for name
1860 # cmd - command to eval upon OK
1861 # errorHandler - command to eval upon Cancel
1862 # If neither cmd or errorHandler are specified, the return value
1863 # of the FSBox procedure is the selected file name.
1865 proc FSBox
{{purpose
"Select file:"} {defaultName
""} {cmd
""} {errorHandler
1869 if [Exwin_Toplevel
$w "Select File" FileSelect
] {
1870 # path independent names for the widgets
1872 set fileselect
(list) $w.
file.sframe.
list
1873 set fileselect
(scroll
) $w.
file.sframe.scroll
1874 set fileselect
(direntry
) $w.
file.f1.direntry
1875 set fileselect
(entry) $w.
file.f2.
entry
1876 set fileselect
(ok
) $w.but.ok
1877 set fileselect
(cancel
) $w.but.cancel
1878 set fileselect
(msg
) $w.
label
1880 set fileselect
(result
) "" ;# value to return if no callback procedures
1883 Widget_Label
$w label {top fillx pady
10 padx
20} -anchor w
-width 24
1884 Widget_Frame
$w file Dialog
{left expand fill
} -bd 10
1886 Widget_Frame
$w.
file f1 Exmh
{top fillx
}
1887 Widget_Label
$w.
file.f1
label {left
} -text "Dir"
1888 Widget_Entry
$w.
file.f1 direntry
{right fillx expand
} -width 30
1890 Widget_Frame
$w.
file sframe
1892 scrollbar $w.
file.sframe.yscroll
-relief sunken
\
1893 -command [list $w.
file.sframe.
list yview
]
1894 listbox $w.
file.sframe.
list -relief sunken
\
1895 -yscroll [list $w.
file.sframe.yscroll
set] -setgrid 1
1896 pack append $w.
file.sframe
\
1897 $w.
file.sframe.yscroll
{right filly
} \
1898 $w.
file.sframe.
list {left expand fill
}
1900 Widget_Frame
$w.
file f2 Exmh
{top fillx
}
1901 Widget_Label
$w.
file.f2
label {left
} -text Name
1902 Widget_Entry
$w.
file.f2
entry {right fillx expand
}
1905 $w.but.quit configure
-text Cancel
\
1906 -command [list fileselect.cancel.cmd
$w]
1908 Widget_AddBut
$w.but ok OK
\
1909 [list fileselect.ok.cmd
$w $cmd $errorHandler] {left padx
1}
1911 Widget_AddBut
$w.but
list List
\
1912 [list fileselect.
list.cmd
$w] {left padx
1}
1913 Widget_CheckBut
$w.but listall
"List all" fileselect
(pattern
)
1914 $w.but.listall configure
-onvalue "{*,.*}" -offvalue "*" \
1915 -command {fileselect.
list.cmd
$fileselect(direntry
)}
1916 $w.but.listall deselect
1918 # Set up bindings for the browser.
1919 foreach ww
[list $w $fileselect(entry)] {
1920 bind $ww <Return
> [list $fileselect(ok
) invoke
]
1921 bind $ww <Control-c
> [list $fileselect(cancel
) invoke
]
1923 bind $fileselect(direntry
) <Return
> [list fileselect.
list.cmd
%W
]
1924 bind $fileselect(direntry
) <Tab
> [list fileselect.tab.dircmd
]
1925 bind $fileselect(entry) <Tab
> [list fileselect.tab.filecmd
]
1927 tk_listboxSingleSelect
$fileselect(list)
1930 bind $fileselect(list) <Button-1
> {
1931 # puts stderr "button 1 release"
1932 %W select from
[%W nearest
%y
]
1933 $fileselect(entry) delete
0 end
1934 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
1937 bind $fileselect(list) <Key
> {
1938 %W select from
[%W nearest
%y
]
1939 $fileselect(entry) delete
0 end
1940 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
1943 bind $fileselect(list) <Double-ButtonPress-1
> {
1944 # puts stderr "double button 1"
1945 %W select from
[%W nearest
%y
]
1946 $fileselect(entry) delete
0 end
1947 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
1948 $fileselect(ok
) invoke
1951 bind $fileselect(list) <Return
> {
1952 %W select from
[%W nearest
%y
]
1953 $fileselect(entry) delete
0 end
1954 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
1955 $fileselect(ok
) invoke
1958 set fileselect
(text) $purpose
1959 $fileselect(msg
) configure
-text $purpose
1960 $fileselect(entry) delete
0 end
1961 $fileselect(entry) insert
0 [file tail
$defaultName]
1963 if {[info exists fileselect
(lastDir
)] && ![string length
$defaultName]} {
1964 set dir
$fileselect(lastDir
)
1966 set dir
[file dirname
$defaultName]
1968 set fileselect
(pwd) [pwd]
1970 $fileselect(direntry
) delete
0 end
1971 $fileselect(direntry
) insert
0 [pwd]/
1973 $fileselect(list) delete
0 end
1974 $fileselect(list) insert
0 "Big directory:"
1975 $fileselect(list) insert
1 $dir
1976 $fileselect(list) insert
2 "Press Return for Listing"
1978 fileselect.
list.cmd
$fileselect(direntry
) startup
1980 # set kbd focus to entry widget
1982 # Exwin_ToplevelFocus $w $fileselect(entry)
1984 # Wait for button hits if no callbacks are defined
1986 if {"$cmd" == "" && "$errorHandler" == ""} {
1987 # wait for the box to be destroyed
1990 tkwait variable fileselect
(result
)
1993 set path
$fileselect(result
)
1994 set fileselect
(lastDir
) [pwd]
1995 fileselect.
cd $fileselect(pwd)
1996 return [string trimright
[string trim
$path] /]
1998 fileselect.
cd $fileselect(pwd)
2002 proc fileselect.
cd { dir
} {
2004 if [catch {cd $dir} err
] {
2009 # auxiliary button procedures
2011 proc fileselect.yck
{ {tag
{}} } {
2013 $fileselect(msg
) configure
-text "Yck! $tag"
2015 proc fileselect.ok
{} {
2017 $fileselect(msg
) configure
-text $fileselect(text)
2020 proc fileselect.cancel.cmd
{w
} {
2022 set fileselect
(result
) {}
2025 proc fileselect.
list.cmd
{w
{state normal
}} {
2027 set seldir
[$fileselect(direntry
) get
]
2028 if {[catch {glob $seldir} dir
]} {
2029 fileselect.yck
"glob failed"
2032 if {[llength $dir] > 1} {
2033 set dir
[file dirname
$seldir]
2034 set pat
[file tail
$seldir]
2036 set pat
$fileselect(pattern
)
2040 if [file isdirectory
$dir] {
2041 fileselect.getfiles
$dir $pat $state
2042 focus $fileselect(entry)
2044 fileselect.yck
"not a dir"
2048 proc fileselect.ok.cmd
{w cmd errorHandler
} {
2050 set selname
[$fileselect(entry) get
]
2051 set seldir
[$fileselect(direntry
) get
]
2053 if [string match
/* $selname] {
2054 set selected
$selname
2056 if [string match ~
* $selname] {
2057 set selected
$selname
2059 set selected
$seldir/$selname
2063 # some nasty file names may cause "file isdirectory" to return an error
2064 if [catch {file isdirectory
$selected} isdir
] {
2065 fileselect.yck
"isdirectory failed"
2068 if [catch {glob $selected} globlist
] {
2069 if ![file isdirectory
[file dirname
$selected]] {
2070 fileselect.yck
"bad pathname"
2073 set globlist
$selected
2078 if {[llength $globlist] > 1} {
2079 set dir
[file dirname
$selected]
2080 set pat
[file tail
$selected]
2081 fileselect.getfiles
$dir $pat
2084 set selected
$globlist
2086 if [file isdirectory
$selected] {
2087 fileselect.getfiles
$selected $fileselect(pattern
)
2088 $fileselect(entry) delete
0 end
2095 set fileselect
(result
) $selected
2099 proc fileselect.getfiles
{ dir
{pat
*} {state normal
} } {
2101 $fileselect(msg
) configure
-text Listing...
2104 set currentDir
[pwd]
2106 if [catch {set files
[lsort [glob -nocomplain $pat]]} err
] {
2107 $fileselect(msg
) configure
-text $err
2108 $fileselect(list) delete
0 end
2114 # Normal case - show current directory
2115 $fileselect(direntry
) delete
0 end
2116 $fileselect(direntry
) insert
0 [pwd]/
2119 # Directory already OK (tab related)
2122 # Changing directory (tab related)
2123 fileselect.
cd $currentDir
2126 # Avoid listing huge directories upon startup.
2127 $fileselect(direntry
) delete
0 end
2128 $fileselect(direntry
) insert
0 [pwd]/
2129 if {[llength $files] > 32} {
2136 # build a reordered list of the files: directories are displayed first
2137 # and marked with a trailing "/"
2138 if [string compare
$dir /] {
2139 fileselect.putfiles
$files [expr {($pat == "*") ?
1 : 0}]
2141 fileselect.putfiles
$files
2146 proc fileselect.putfiles
{files
{dotdot
0} } {
2149 $fileselect(list) delete
0 end
2151 $fileselect(list) insert end
"../"
2154 if {[file isdirectory
$i]} {
2155 $fileselect(list) insert end
$i/
2157 $fileselect(list) insert end
$i
2162 proc FileExistsDialog
{ name
} {
2165 set fileExists
(ok
) 0
2167 message $w.msg
-aspect 1000
2168 pack $w.msg
-side top
-fill both
-padx 20 -pady 20
2169 $w.but.quit config
-text Cancel
-command {FileExistsCancel
}
2170 button $w.but.ok
-text OK
-command {FileExistsOK
}
2171 pack $w.but.ok
-side left
2172 bind $w.msg
<Return
> {FileExistsOK
}
2174 $w.msg config
-text "Warning: file exists
2176 OK to overwrite it?"
2178 set fileExists
(focus) [focus]
2181 tkwait variable fileExists
(ok
)
2183 return $fileExists(ok
)
2185 proc FileExistsCancel
{} {
2187 set fileExists
(ok
) 0
2189 proc FileExistsOK
{} {
2191 set fileExists
(ok
) 1
2194 proc fileselect.getfiledir
{ dir
{basedir
[pwd]} } {
2197 set path
[$fileselect(direntry
) get
]
2201 if {[string index
$path 0] == "~"} {
2205 set path
[$fileselect(entry) get
]
2207 if [catch {set listFile
[glob -nocomplain $path*]}] {
2210 foreach el
$listFile {
2212 if [file isdirectory
$el] {
2213 lappend returnList
[file tail
$el]
2215 } elseif
![file isdirectory
$el] {
2216 lappend returnList
[file tail
$el]
2223 proc fileselect.gethead
{ list } {
2226 for {set i
0} {[string length
[lindex $list 0]] > $i}\
2227 {incr i
; set returnHead
$returnHead$thisChar} {
2228 set thisChar
[string index
[lindex $list 0] $i]
2230 if {[string length
$el] < $i} {
2233 if {$thisChar != [string index
$el $i]} {
2241 proc fileselect.expand.tilde
{ } {
2244 set entry [$fileselect(direntry
) get
]
2245 set dir
[string range
$entry 1 [string length
$entry]]
2253 ## look in /etc/passwd
2254 if [file exists
/etc
/passwd
] {
2255 if [catch {set users
[exec cat
/etc
/passwd | sed s
/:.
*//]} err
] {
2256 puts "Error\#1 $err"
2259 set list [split $users "\n"]
2261 if {[lsearch -exact $list "+"] != -1} {
2262 if [catch {set users
[exec ypcat passwd | sed s
/:.
*//]} err
] {
2263 puts "Error\#2 $err"
2266 set list [concat $list [split $users "\n"]]
2268 $fileselect(list) delete
0 end
2270 if [string match
$dir* $el] {
2271 lappend listmatch
$el
2272 $fileselect(list) insert end
$el
2275 set addings
[fileselect.gethead
$listmatch]
2276 if {$addings == ""} {
2279 $fileselect(direntry
) delete
0 end
2280 if {[llength $listmatch] == 1} {
2281 $fileselect(direntry
) insert
0 [file dirname ~
$addings/]
2282 fileselect.getfiles
[$fileselect(direntry
) get
]
2284 $fileselect(direntry
) insert
0 ~
$addings
2288 proc fileselect.tab.dircmd
{ } {
2291 set dir
[$fileselect(direntry
) get
]
2293 $fileselect(direntry
) delete
0 end
2294 $fileselect(direntry
) insert
0 [pwd]
2295 if [string compare
[pwd] "/"] {
2296 $fileselect(direntry
) insert end
/
2300 if [catch {set tmp
[file isdirectory
[file dirname
$dir]]}] {
2301 if {[string index
$dir 0] == "~"} {
2302 fileselect.expand.tilde
2309 set dirFile
[fileselect.getfiledir
1 $dir]
2310 if ![llength $dirFile] {
2313 if {[llength $dirFile] == 1} {
2314 $fileselect(direntry
) delete
0 end
2315 $fileselect(direntry
) insert
0 [file dirname
$dir]
2316 if [string compare
[file dirname
$dir] /] {
2317 $fileselect(direntry
) insert end
/[lindex $dirFile 0]/
2319 $fileselect(direntry
) insert end
[lindex $dirFile 0]/
2321 fileselect.getfiles
[$fileselect(direntry
) get
] \
2322 "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
2325 set headFile
[fileselect.gethead
$dirFile]
2326 $fileselect(direntry
) delete
0 end
2327 $fileselect(direntry
) insert
0 [file dirname
$dir]
2328 if [string compare
[file dirname
$dir] /] {
2329 $fileselect(direntry
) insert end
/$headFile
2331 $fileselect(direntry
) insert end
$headFile
2333 if {$headFile == "" && [file isdirectory
$dir]} {
2334 fileselect.getfiles
$dir\
2335 "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
2337 fileselect.getfiles
[file dirname
$dir]\
2338 "[file tail [$fileselect(direntry) get]]*" newdir
2342 proc fileselect.tab.filecmd
{ } {
2345 set dir
[$fileselect(direntry
) get
]
2349 if {![file isdirectory
$dir]} {
2350 error "dir $dir doesn't exist"
2352 set listFile
[fileselect.getfiledir
0 $dir]
2354 if ![llength $listFile] {
2357 if {[llength $listFile] == 1} {
2358 $fileselect(entry) delete
0 end
2359 $fileselect(entry) insert
0 [lindex $listFile 0]
2362 set headFile
[fileselect.gethead
$listFile]
2363 $fileselect(entry) delete
0 end
2364 $fileselect(entry) insert
0 $headFile
2365 fileselect.getfiles
$dir "[$fileselect(entry) get]$fileselect(pattern)" opt
2368 proc Exwin_Toplevel
{ path name
{class Dialog
} {dismiss yes
}} {
2370 if [catch {wm state
$path} state
] {
2371 set t
[Widget_Toplevel
$path $name $class]
2372 if ![info exists exwin
(toplevels
)] {
2373 set exwin
(toplevels
) [option get . exwinPaths
{}]
2375 set ix
[lsearch $exwin(toplevels
) $t]
2377 lappend exwin
(toplevels
) $t
2379 if {$dismiss == "yes"} {
2380 set f
[Widget_Frame
$t but Menubar
{top fill
}]
2381 Widget_AddBut
$f quit
"Dismiss" [list Exwin_Dismiss
$path]
2385 if {$state != "normal"} {
2387 wm geometry
$path $exwin(geometry
,$path)
2388 # Exmh_Debug Exwin_Toplevel $path $exwin(geometry,$path)
2398 proc Exwin_Dismiss
{ path
{geo ok
} } {
2402 set exwin
(geometry
,$path) [wm geometry
$path]
2405 set exwin
(geometry
,$path) [string trimleft
[wm geometry
$path] 0123456789x
]
2408 catch {unset exwin
(geometry
,$path)}
2414 proc Widget_Toplevel
{ path name
{class Dialog
} {x
{}} {y
{}} } {
2415 set self
[toplevel $path -class $class]
2416 set usergeo
[option get
$path position Position
]
2417 if {$usergeo != {}} {
2418 if [catch {wm geometry
$self $usergeo} err
] {
2419 # Exmh_Debug Widget_Toplevel $self $usergeo => $err
2422 if {($x != {}) && ($y != {})} {
2423 # Exmh_Debug Event position $self +$x+$y
2424 wm geometry
$self +$x+$y
2427 wm title
$self $name
2432 proc Widget_Frame
{par child
{class GDB
} {where
{top expand fill
}} args
} {
2436 set self
$par.
$child
2438 eval {frame $self -class $class} $args
2439 pack append $par $self $where
2443 proc Widget_AddBut
{par but txt cmd
{where
{right padx
1}} } {
2444 # Create a Packed button. Return the button pathname
2445 set cmd2
[list button $par.
$but -text $txt -command $cmd]
2446 if [catch $cmd2 t
] {
2447 puts stderr
"Widget_AddBut (warning) $t"
2448 eval $cmd2 {-font fixed
}
2450 pack append $par $par.
$but $where
2453 proc Widget_CheckBut
{par but txt var
{where
{right padx
1}} } {
2454 # Create a check button. Return the button pathname
2455 set cmd
[list checkbutton $par.
$but -text $txt -variable $var]
2457 puts stderr
"Widget_CheckBut (warning) $t"
2458 eval $cmd {-font fixed
}
2460 pack append $par $par.
$but $where
2464 proc Widget_Label
{ frame {name
label} {where
{left fill
}} args
} {
2465 set cmd
[list label $frame.
$name ]
2466 if [catch [concat $cmd $args] t
] {
2467 puts stderr
"Widget_Label (warning) $t"
2468 eval $cmd $args {-font fixed
}
2470 pack append $frame $frame.
$name $where
2473 proc Widget_Entry
{ frame {name
entry} {where
{left fill
}} args
} {
2474 set cmd
[list entry $frame.
$name ]
2475 if [catch [concat $cmd $args] t
] {
2476 puts stderr
"Widget_Entry (warning) $t"
2477 eval $cmd $args {-font fixed
}
2479 pack append $frame $frame.
$name $where
2483 # End of fileselect.tcl.
2485 # Setup the initial windows
2487 create_source_window
2489 if {[tk colormodel .src.
text] == "color"} {
2490 set highlight
"-background red2 -borderwidth 2 -relief sunk"
2492 set fg
[lindex [.src.
text config
-foreground] 4]
2493 set bg
[lindex [.src.
text config
-background] 4]
2494 set highlight
"-foreground $bg -background $fg -borderwidth 0"
2497 create_command_window