1 # GDB GUI setup for GDB, the GNU debugger.
2 # Copyright 1994, 1995, 1996
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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24 set wins
($cfile) .src.
text
28 set breakpoint_file
(-1) {[garbage
]}
29 set disassemble_with_source nosource
30 set expr_update_list
(0) 0
31 set gdb_prompt
"(gdb) "
35 #option add *Foreground Black
36 #option add *Background White
37 #option add *Font -*-*-medium-r-normal--18-*-*-*-m-*-*-1
39 proc echo
string {puts stdout
$string}
41 # Assign elements from LIST to variables named in ARGS. FIXME replace
42 # with TclX version someday.
43 proc lassign
{list args
} {
44 set len
[expr {[llength $args] - 1}]
46 upvar [lindex $args $len] local
47 set local
[lindex $list $len]
55 # decr (var val) - compliment to incr
60 proc decr
{var
{val
1}} {
62 set num
[expr {$num - $val}]
67 # Center a window on the screen.
69 proc center_window
toplevel {
70 # Withdraw and update, to ensure geometry computations are finished.
74 set x
[expr {[winfo screenwidth
$toplevel] / 2
75 - [winfo reqwidth
$toplevel] / 2
76 - [winfo vrootx
$toplevel]}]
77 set y
[expr {[winfo screenheight
$toplevel] / 2
78 - [winfo reqheight
$toplevel] / 2
79 - [winfo vrooty
$toplevel]}]
80 wm geometry
$toplevel +${x
}+${y
}
81 wm deiconify
$toplevel
85 # Rearrange the bindtags so the widget comes after the class. I was
86 # always for Ousterhout putting the class bindings first, but no...
88 proc bind_widget_after_class
{widget
} {
89 set class
[winfo class
$widget]
91 foreach tag
[bindtags $widget] {
92 if {$tag == $widget} {
97 lappend newList
$widget
101 bindtags $widget $newList
105 # Make sure line number $LINE is visible in the text widget. But be
106 # more clever than the "see" command: if LINE is not currently
107 # displayed, arrange for LINE to be centered. There are cases in
108 # which this does not work, so as a last resort we revert to "see".
110 # This is inefficient, but probably not slow enough to actually
113 proc ensure_line_visible
{text line
} {
114 set pixHeight
[winfo height
$text]
115 # Compute height of widget in lines. This fails if a line is wider
116 # than the screen. FIXME.
117 set topLine
[lindex [split [$text index
@0,0] .
] 0]
118 set botLine
[lindex [split [$text index
@0,${pixHeight
}] .
] 0]
120 if {$line > $topLine && $line < $botLine} then
{
121 # Onscreen, and not on the very edge.
125 set newTop
[expr {$line - ($botLine - $topLine)}]
126 if {$newTop < 0} then
{
129 $text yview moveto
$newTop
131 # In case the above failed.
135 if {[info exists env
(EDITOR
)]} then
{
136 set editor
$env(EDITOR
)
143 # These functions are called by GDB (from C code) to do various things in
144 # TK-land. All start with the prefix `gdbtk_tcl_' to make them easy to find.
150 # gdbtk_tcl_fputs (text) - Output text to the command window
154 # GDB calls this to output TEXT to the GDB command window. The text is
155 # placed at the end of the text widget. Note that output may not occur,
156 # due to buffering. Use gdbtk_tcl_flush to cause an immediate update.
159 proc gdbtk_tcl_fputs
{arg
} {
160 .cmd.
text insert end
"$arg"
164 proc gdbtk_tcl_fputs_error
{arg
} {
165 .cmd.
text insert end
"$arg"
172 # gdbtk_tcl_flush () - Flush output to the command window
176 # GDB calls this to force all buffered text to the GDB command window.
179 proc gdbtk_tcl_flush
{} {
187 # gdbtk_tcl_query (message) - Create a yes/no query dialog box
191 # GDB calls this to create a yes/no dialog box containing MESSAGE. GDB
192 # is hung while the dialog box is active (ie: no commands will work),
193 # however windows can still be refreshed in case of damage or exposure.
196 proc gdbtk_tcl_query
{message} {
197 # FIXME We really want a Help button here. But Tk's brain-damaged
198 # modal dialogs won't really allow it. Should have async dialog
200 set result
[tk_dialog .query
"gdb : query" "$message" questhead
0 Yes No
]
201 return [expr {!$result}]
207 # gdbtk_start_variable_annotation (args ...) -
211 # Not yet implemented.
214 proc gdbtk_tcl_start_variable_annotation
{valaddr ref_type stor_cl
215 cum_expr field type_cast
} {
216 echo
"gdbtk_tcl_start_variable_annotation $valaddr $ref_type $stor_cl $cum_expr $field $type_cast"
222 # gdbtk_end_variable_annotation (args ...) -
226 # Not yet implemented.
229 proc gdbtk_tcl_end_variable_annotation
{} {
230 echo gdbtk_tcl_end_variable_annotation
236 # gdbtk_tcl_breakpoint (action bpnum file line) - Notify the TK
237 # interface of changes to breakpoints.
241 # GDB calls this to notify TK of changes to breakpoints. ACTION is one
243 # create - Notify of breakpoint creation
244 # delete - Notify of breakpoint deletion
245 # modify - Notify of breakpoint modification
248 # file line pc type enabled disposition silent ignore_count commands cond_string thread hit_count
250 proc gdbtk_tcl_breakpoint
{action bpnum
} {
251 set bpinfo
[gdb_get_breakpoint_info
$bpnum]
252 set file [lindex $bpinfo 0]
253 set line
[lindex $bpinfo 1]
254 set pc
[lindex $bpinfo 2]
255 set enable
[lindex $bpinfo 4]
257 if {$action == "modify"} {
258 if {$enable == "1"} {
265 ${action
}_breakpoint
$bpnum $file $line $pc
268 proc create_breakpoints_window
{} {
271 if {[winfo exists .breakpoints
]} {raise .breakpoints
; return}
273 build_framework .breakpoints
"Breakpoints" ""
275 # First, delete all the old view menu entries
277 .breakpoints.menubar.view.
menu delete
0 last
281 destroy .breakpoints.
label
283 # Replace text with a canvas and fix the scrollbars
285 destroy .breakpoints.
text
286 scrollbar .breakpoints.scrollx
-orient horizontal
\
287 -command {.breakpoints.c xview
} -relief sunken
288 canvas .breakpoints.c
-relief sunken
-bd 2 \
290 -yscrollcommand {.breakpoints.scroll
set} \
291 -xscrollcommand {.breakpoints.scrollx
set}
292 .breakpoints.scroll configure
-command {.breakpoints.c yview
}
294 pack .breakpoints.scrollx
-side bottom
-fill x
-in .breakpoints.
info
295 pack .breakpoints.c
-side left
-expand yes
-fill both
\
296 -in .breakpoints.
info
300 # Create a frame for each breakpoint
302 foreach bpnum
[gdb_get_breakpoint_list
] {
303 add_breakpoint_frame
$bpnum
307 # Create a frame for bpnum in the .breakpoints canvas
309 proc add_breakpoint_frame bpnum
{
314 if {![winfo exists .breakpoints
]} return
316 set bpinfo
[gdb_get_breakpoint_info
$bpnum]
318 lassign
$bpinfo file line pc type enabled
($bpnum) disposition
($bpnum) \
319 silent ignore_count commands cond thread hit_count
321 set f .breakpoints.c.
$bpnum
323 if {![winfo exists
$f]} {
324 frame $f -relief sunken
-bd 2
326 label $f.id
-text "#$bpnum $file:$line ($pc)" \
327 -relief flat
-bd 2 -anchor w
329 label $f.hit_count.
label -text "Hit count:" -relief flat
\
330 -bd 2 -anchor w
-width 11
331 label $f.hit_count.val
-text $hit_count -relief flat
\
333 checkbutton $f.hit_count.enabled
-text Enabled
\
334 -variable enabled
($bpnum) -anchor w
-relief flat
336 pack $f.hit_count.
label $f.hit_count.val
-side left
337 pack $f.hit_count.enabled
-side right
340 label $f.thread.
label -text "Thread: " -relief flat
-bd 2 \
342 entry $f.thread.
entry -bd 2 -relief sunken
-width 10
343 $f.thread.
entry insert end
$thread
344 pack $f.thread.
label -side left
345 pack $f.thread.
entry -side left
-fill x
348 label $f.cond.
label -text "Condition: " -relief flat
-bd 2 \
350 entry $f.cond.
entry -bd 2 -relief sunken
351 $f.cond.
entry insert end
$cond
352 pack $f.cond.
label -side left
353 pack $f.cond.
entry -side left
-fill x
-expand yes
355 frame $f.ignore_count
356 label $f.ignore_count.
label -text "Ignore count: " \
357 -relief flat
-bd 2 -width 11 -anchor w
358 entry $f.ignore_count.
entry -bd 2 -relief sunken
-width 10
359 $f.ignore_count.
entry insert end
$ignore_count
360 pack $f.ignore_count.
label -side left
361 pack $f.ignore_count.
entry -side left
-fill x
365 label $f.disps.
label -text "Disposition: " -relief flat
-bd 2 \
368 radiobutton $f.disps.delete
-text Delete
\
369 -variable disposition
($bpnum) -anchor w
-relief flat
\
370 -command "gdb_cmd \"delete break $bpnum\"" \
373 radiobutton $f.disps.disable
-text Disable
\
374 -variable disposition
($bpnum) -anchor w
-relief flat
\
375 -command "gdb_cmd \"disable break $bpnum\"" \
378 radiobutton $f.disps.donttouch
-text "Leave alone" \
379 -variable disposition
($bpnum) -anchor w
-relief flat
\
380 -command "gdb_cmd \"enable break $bpnum\"" \
383 pack $f.disps.
label $f.disps.delete
$f.disps.disable
\
384 $f.disps.donttouch
-side left
-anchor w
385 text $f.commands
-relief sunken
-bd 2 -setgrid true
\
386 -cursor hand2
-height 3 -width 30
388 foreach line
$commands {
389 $f.commands insert end
"${line}\n"
392 pack $f.id
-side top
-anchor nw
-fill x
393 pack $f.hit_count
$f.cond
$f.thread
$f.ignore_count
$f.disps
\
394 $f.commands
-side top
-fill x
-anchor nw
397 set tag
[.breakpoints.c create window
0 $bpframe_lasty -window $f -anchor nw
]
399 set bbox
[.breakpoints.c bbox
$tag]
401 set bpframe_lasty
[lindex $bbox 3]
403 .breakpoints.c configure
-width [lindex $bbox 2]
406 # Delete a breakpoint frame
408 proc delete_breakpoint_frame bpnum
{
411 if {![winfo exists .breakpoints
]} return
413 # First, clear the canvas
415 .breakpoints.c delete all
417 # Now, repopulate it with all but the doomed breakpoint
420 foreach bp
[gdb_get_breakpoint_list
] {
422 add_breakpoint_frame
$bp
427 proc asm_win_name
{funcname
} {
428 if {$funcname == "*None*"} {return .asm.
text}
430 regsub -all {\.
} $funcname _ temp
432 return .asm.func_
${temp
}
438 # create_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
442 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
443 # land of breakpoint creation. This consists of recording the file and
444 # line number in the breakpoint_file and breakpoint_line arrays. Also,
445 # if there is already a window associated with FILE, it is updated with
449 proc create_breakpoint
{bpnum
file line pc
} {
451 global breakpoint_file
452 global breakpoint_line
453 global pos_to_breakpoint
454 global pos_to_bpcount
458 # Record breakpoint locations
460 set breakpoint_file
($bpnum) $file
461 set breakpoint_line
($bpnum) $line
462 set pos_to_breakpoint
($file:$line) $bpnum
463 if {![info exists pos_to_bpcount
($file:$line)]} {
464 set pos_to_bpcount
($file:$line) 0
466 incr pos_to_bpcount
($file:$line)
467 set pos_to_breakpoint
($pc) $bpnum
468 if {![info exists pos_to_bpcount
($pc)]} {
469 set pos_to_bpcount
($pc) 0
471 incr pos_to_bpcount
($pc)
473 # If there's a window for this file, update it
475 if {[info exists wins
($file)]} {
476 insert_breakpoint_tag
$wins($file) $line
479 # If there's an assembly window, update that too
481 set win
[asm_win_name
$cfunc]
482 if {[winfo exists
$win]} {
483 insert_breakpoint_tag
$win [pc_to_line
$pclist($cfunc) $pc]
486 # Update the breakpoints window
488 add_breakpoint_frame
$bpnum
494 # delete_breakpoint (bpnum file line pc) - Delete breakpoint info from TK land
498 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
499 # land of breakpoint destruction. This consists of removing the file and
500 # line number from the breakpoint_file and breakpoint_line arrays. Also,
501 # if there is already a window associated with FILE, the tags are removed
505 proc delete_breakpoint
{bpnum
file line pc
} {
507 global breakpoint_file
508 global breakpoint_line
509 global pos_to_breakpoint
510 global pos_to_bpcount
513 # Save line number and file for later
515 set line
$breakpoint_line($bpnum)
517 set file $breakpoint_file($bpnum)
519 # Reset breakpoint annotation info
521 if {$pos_to_bpcount($file:$line) > 0} {
522 decr pos_to_bpcount
($file:$line)
524 if {$pos_to_bpcount($file:$line) == 0} {
525 catch "unset pos_to_breakpoint($file:$line)"
527 unset breakpoint_file
($bpnum)
528 unset breakpoint_line
($bpnum)
530 # If there's a window for this file, update it
532 if {[info exists wins
($file)]} {
533 delete_breakpoint_tag
$wins($file) $line
538 # If there's an assembly window, update that too
540 if {$pos_to_bpcount($pc) > 0} {
541 decr pos_to_bpcount
($pc)
543 if {$pos_to_bpcount($pc) == 0} {
544 catch "unset pos_to_breakpoint($pc)"
546 set win
[asm_win_name
$cfunc]
547 if {[winfo exists
$win]} {
548 delete_breakpoint_tag
$win [pc_to_line
$pclist($cfunc) $pc]
553 delete_breakpoint_frame
$bpnum
559 # enable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
563 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
564 # land of a breakpoint being enabled. This consists of unstippling the
565 # specified breakpoint indicator.
568 proc enable_breakpoint
{bpnum
file line pc
} {
573 if {[info exists wins
($file)]} {
574 $wins($file) tag configure
$line -fgstipple {}
577 # If there's an assembly window, update that too
579 set win
[asm_win_name
$cfunc]
580 if {[winfo exists
$win]} {
581 $win tag configure
[pc_to_line
$pclist($cfunc) $pc] -fgstipple {}
584 # If there's a breakpoint window, update that too
586 if {[winfo exists .breakpoints
]} {
587 set enabled
($bpnum) 1
594 # disable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
598 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
599 # land of a breakpoint being disabled. This consists of stippling the
600 # specified breakpoint indicator.
603 proc disable_breakpoint
{bpnum
file line pc
} {
608 if {[info exists wins
($file)]} {
609 $wins($file) tag configure
$line -fgstipple gray50
612 # If there's an assembly window, update that too
614 set win
[asm_win_name
$cfunc]
615 if {[winfo exists
$win]} {
616 $win tag configure
[pc_to_line
$pclist($cfunc) $pc] -fgstipple gray50
619 # If there's a breakpoint window, update that too
621 if {[winfo exists .breakpoints
]} {
622 set enabled
($bpnum) 0
629 # insert_breakpoint_tag (win line) - Insert a breakpoint tag in WIN.
633 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to insert a
634 # breakpoint tag into window WIN at line LINE.
637 proc insert_breakpoint_tag
{win line
} {
638 $win configure
-state normal
640 $win insert
$line.0 "B"
641 $win tag add margin
$line.0 $line.8
643 $win configure
-state disabled
649 # delete_breakpoint_tag (win line) - Remove a breakpoint tag from WIN.
653 # GDB calls this indirectly (through gdbtk_tcl_breakpoint) to remove a
654 # breakpoint tag from window WIN at line LINE.
657 proc delete_breakpoint_tag
{win line
} {
658 $win configure
-state normal
660 if {[string range
$win 0 3] == ".src"} then
{
661 $win insert
$line.0 "\xa4"
663 $win insert
$line.0 " "
665 $win tag add margin
$line.0 $line.8
666 $win configure
-state disabled
669 proc gdbtk_tcl_busy
{} {
670 if {[winfo exists .cmd
]} {
671 .cmd.
text configure
-state disabled
673 if {[winfo exists .src
]} {
674 .src.start configure
-state disabled
675 .src.stop configure
-state normal
676 .src.step configure
-state disabled
677 .src.next configure
-state disabled
678 .src.
continue configure
-state disabled
679 .src.finish configure
-state disabled
680 .src.up configure
-state disabled
681 .src.down configure
-state disabled
682 .src.bottom configure
-state disabled
684 if {[winfo exists .asm
]} {
685 .asm.stepi configure
-state disabled
686 .asm.nexti configure
-state disabled
687 .asm.
continue configure
-state disabled
688 .asm.finish configure
-state disabled
689 .asm.up configure
-state disabled
690 .asm.down configure
-state disabled
691 .asm.bottom configure
-state disabled
696 proc gdbtk_tcl_idle
{} {
697 if {[winfo exists .cmd
]} {
698 .cmd.
text configure
-state normal
700 if {[winfo exists .src
]} {
701 .src.start configure
-state normal
702 .src.stop configure
-state disabled
703 .src.step configure
-state normal
704 .src.next configure
-state normal
705 .src.
continue configure
-state normal
706 .src.finish configure
-state normal
707 .src.up configure
-state normal
708 .src.down configure
-state normal
709 .src.bottom configure
-state normal
711 if {[winfo exists .asm
]} {
712 .asm.stepi configure
-state normal
713 .asm.nexti configure
-state normal
714 .asm.
continue configure
-state normal
715 .asm.finish configure
-state normal
716 .asm.up configure
-state normal
717 .asm.down configure
-state normal
718 .asm.bottom configure
-state normal
726 # pc_to_line (pclist pc) - convert PC to a line number.
730 # Convert PC to a line number from PCLIST. If exact line isn't found,
731 # we return the first line that starts before PC.
733 proc pc_to_line
{pclist pc
} {
734 set line
[lsearch -exact $pclist $pc]
736 if {$line >= 1} { return $line }
739 foreach linepc
[lrange $pclist 1 end
] {
740 if {$pc < $linepc} { decr line
; return $line }
743 return [expr {$line - 1}]
749 # file popup menu - Define the file popup menu.
753 # This menu just contains a bunch of buttons that do various things to
754 # the line under the cursor.
758 # Edit - Run the editor (specified by the environment variable EDITOR) on
759 # this file, at the current line.
760 # Breakpoint - Set a breakpoint at the current line. This just shoves
761 # a `break' command at GDB with the appropriate file and line
762 # number. Eventually, GDB calls us back (at gdbtk_tcl_breakpoint)
763 # to notify us of where the breakpoint needs to show up.
766 menu .file_popup
-cursor hand2
-tearoff 0
767 .file_popup add command
-label "Not yet set" -state disabled
768 .file_popup add separator
769 .file_popup add command
-label "Edit" \
770 -command {exec $editor +$selected_line $selected_file &}
771 .file_popup add command
-label "Set breakpoint" \
772 -command {gdb_cmd
"break $selected_file:$selected_line"}
774 # Use this procedure to get the GDB core to execute the string `cmd'. This is
775 # a wrapper around gdb_cmd, which will catch errors, and send output to the
776 # command window. It will also cause all of the other windows to be updated.
778 proc interactive_cmd
{cmd
} {
779 catch {gdb_cmd
"$cmd"} result
780 .cmd.
text insert end
$result
788 # file popup menu - Define the file popup menu bindings.
792 # This defines the binding for the file popup menu. It simply
793 # unhighlights the line under the cursor.
796 bind .file_popup
<Any-ButtonRelease-1
> {
798 # Unhighlight the selected line
799 $selected_win tag delete breaktag
805 # listing_window_popup (win x y xrel yrel) - Handle popups for listing window
809 # This procedure is invoked by holding down button 2 (usually) in the
810 # listing window. The action taken depends upon where the button was
811 # pressed. If it was in the left margin (the breakpoint column), it
812 # sets or clears a breakpoint. In the main text area, it will pop up a
816 proc listing_window_popup
{win x y xrel yrel
} {
819 global file_to_debug_file
824 global pos_to_breakpoint
826 # Map TK window name back to file name.
828 set file $win_to_file($win)
830 set pos
[split [$win index
@$xrel,$yrel] .
]
832 # Record selected file and line for menu button actions
834 set selected_file
$file_to_debug_file($file)
835 set selected_line
[lindex $pos 0]
836 set selected_col
[lindex $pos 1]
837 set selected_win
$win
839 # Post the menu near the pointer, (and grab it)
841 .file_popup entryconfigure
0 -label "$selected_file:$selected_line"
843 tk_popup .file_popup
$x $y
849 # toggle_breakpoint (win x y xrel yrel) - Handle clicks on breakdots
853 # This procedure sets or clears breakpoints where the button clicked.
856 proc toggle_breakpoint
{win x y xrel yrel
} {
859 global file_to_debug_file
864 global pos_to_breakpoint
866 # Map TK window name back to file name.
868 set file $win_to_file($win)
870 set pos
[split [$win index
@$xrel,$yrel] .
]
872 # Record selected file and line
874 set selected_file
$file_to_debug_file($file)
875 set selected_line
[lindex $pos 0]
876 set selected_col
[lindex $pos 1]
877 set selected_win
$win
879 # If we're in the margin, then toggle the breakpoint
881 if {$selected_col < 8} { # this is alway true actually
882 set pos_break
$selected_file:$selected_line
883 set pos
$file:$selected_line
884 set tmp pos_to_breakpoint
($pos)
885 if {[info exists
$tmp]} {
887 gdb_cmd
"delete $bpnum"
889 gdb_cmd
"break $pos_break"
898 # asm_window_button_1 (win x y xrel yrel) - Handle button 1 in asm window
902 # This procedure is invoked as a result of holding down button 1 in the
903 # assembly window. The action taken depends upon where the button was
904 # pressed. If it was in the left margin (the breakpoint column), it
905 # sets or clears a breakpoint. In the main text area, it will pop up a
909 proc asm_window_button_1
{win x y xrel yrel
} {
912 global file_to_debug_file
917 global pos_to_breakpoint
921 set pos
[split [$win index
@$xrel,$yrel] .
]
923 # Record selected file and line for menu button actions
925 set selected_line
[lindex $pos 0]
926 set selected_col
[lindex $pos 1]
927 set selected_win
$win
931 set pc
[lindex $pclist($cfunc) $selected_line]
933 # If we're in the margin, then toggle the breakpoint
935 if {$selected_col < 11} {
936 set tmp pos_to_breakpoint
($pc)
937 if {[info exists
$tmp]} {
939 gdb_cmd
"delete $bpnum"
946 # Post the menu near the pointer, (and grab it)
948 # .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
949 # .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
956 # do_nothing - Does absolutely nothing.
960 # This procedure does nothing. It is used as a placeholder to allow
961 # the disabling of bindings that would normally be inherited from the
962 # parent widget. I can't think of any other way to do this.
965 proc do_nothing
{} {}
970 # not_implemented_yet - warn that a feature is unavailable
974 # This procedure warns that something doesn't actually work yet.
977 proc not_implemented_yet
{message} {
978 tk_dialog .unimpl
"gdb : unimpl" \
979 "$message: not implemented in the interface yet" \
986 # create_expr_window - Create expression display window
990 # Create the expression display window.
994 set delete_expr_num
0
996 # Set delete_expr_num, and set -state of Delete button.
997 proc expr_update_button
{num
} {
998 global delete_expr_num
999 set delete_expr_num
$num
1000 if {$num > 0} then
{
1005 .
expr.buts.delete configure
-state $state
1008 proc add_expr
{expr} {
1009 global expr_update_list
1017 checkbutton $e.updates.
$f -text "" -relief flat
\
1018 -variable expr_update_list
($expr_num)
1019 text $e.expressions.
$f -width 20 -height 1
1020 $e.expressions.
$f insert
0.0 $expr
1021 bind $e.expressions.
$f <1> "update_expr $expr_num"
1022 text $e.values.
$f -width 20 -height 1
1024 # Set up some bindings.
1025 foreach frame {updates expressions values
} {
1026 bind $e.
$frame.
$f <FocusIn
> "expr_update_button $expr_num"
1027 bind $e.
$frame.
$f <FocusOut
> "expr_update_button 0"
1030 update_expr
$expr_num
1032 pack $e.updates.
$f -side top
1033 pack $e.expressions.
$f -side top
-expand yes
-fill x
1034 pack $e.values.
$f -side top
-expand yes
-fill x
1037 proc delete_expr
{} {
1038 global delete_expr_num
1039 if {$delete_expr_num > 0} then
{
1041 set f e
${delete_expr_num
}
1043 destroy $e.updates.
$f $e.expressions.
$f $e.values.
$f
1045 # FIXME should we unset an element of expr_update_list here?
1049 proc update_expr
{expr_num
} {
1050 global expr_update_list
1055 set expr [$e.expressions.
$f get
0.0 end
]
1056 $e.values.
$f delete
0.0 end
1057 if {! [catch {gdb_eval
$expr} val
]} {
1058 $e.values.
$f insert
0.0 $val
1060 # FIXME consider flashing widget here.
1064 proc update_exprs
{} {
1065 global expr_update_list
1067 foreach expr_num
[array names expr_update_list
] {
1068 if {$expr_update_list($expr_num)} {
1069 update_expr
$expr_num
1074 proc create_expr_window
{} {
1076 if {[winfo exists .
expr]} {raise .
expr ; return}
1079 wm title .
expr "GDB Expressions"
1080 wm iconname .
expr "Expressions"
1082 frame .
expr.entryframe
-borderwidth 2 -relief raised
1083 label .
expr.entryframe.entrylab
-text "Expression: "
1084 entry .
expr.entryframe.
entry -borderwidth 2 -relief sunken
1085 bind .
expr.entryframe.
entry <Return
> {
1086 add_expr
[.
expr.entryframe.
entry get
]
1087 .
expr.entryframe.
entry delete
0 end
1090 pack .
expr.entryframe.entrylab
-side left
1091 pack .
expr.entryframe.
entry -side left
-fill x
-expand yes
1093 frame .
expr.buts
-borderwidth 2 -relief raised
1095 button .
expr.buts.delete
-text Delete
-command delete_expr
\
1098 button .
expr.buts.
close -text Close
-command {destroy .
expr}
1099 button .
expr.buts.help
-text Help
-state disabled
1101 pack .
expr.buts.delete
-side left
1102 pack .
expr.buts.help .
expr.buts.
close -side right
1104 pack .
expr.buts
-side bottom
-fill x
1105 pack .
expr.entryframe
-side bottom
-fill x
1107 frame .
expr.exprs
-borderwidth 2 -relief raised
1109 # Use three subframes so columns will line up. Easier than
1110 # dealing with BLT for a table geometry manager. Someday Tk
1111 # will have one, use it then. FIXME this messes up keyboard
1113 frame .
expr.exprs.updates
-borderwidth 0 -relief flat
1114 frame .
expr.exprs.expressions
-borderwidth 0 -relief flat
1115 frame .
expr.exprs.values
-borderwidth 0 -relief flat
1117 label .
expr.exprs.updates.
label -text Update
1118 pack .
expr.exprs.updates.
label -side top
-anchor w
1119 label .
expr.exprs.expressions.
label -text Expression
1120 pack .
expr.exprs.expressions.
label -side top
-anchor w
1121 label .
expr.exprs.values.
label -text Value
1122 pack .
expr.exprs.values.
label -side top
-anchor w
1124 pack .
expr.exprs.updates
-side left
1125 pack .
expr.exprs.values .
expr.exprs.expressions
\
1126 -side right
-expand 1 -fill x
1128 pack .
expr.exprs
-side top
-fill both
-expand 1 -anchor w
1134 # display_expression (expression) - Display EXPRESSION in display window
1138 # Display EXPRESSION and its value in the expression display window.
1141 proc display_expression
{expression
} {
1144 add_expr
$expression
1150 # create_file_win (filename) - Create a win for FILENAME.
1154 # The new text widget.
1158 # This procedure creates a text widget for FILENAME. It returns the
1159 # newly created widget. First, a text widget is created, and given basic
1160 # configuration info. Second, all the bindings are setup. Third, the
1161 # file FILENAME is read into the text widget. Fourth, margins and line
1162 # numbers are added.
1165 proc create_file_win
{filename debug_file
} {
1166 global breakpoint_file
1167 global breakpoint_line
1169 global debug_interface
1171 # Replace all the dirty characters in $filename with clean ones, and generate
1172 # a unique name for the text widget.
1174 regsub -all {\.
} $filename {} temp
1175 set win .src.
text$temp
1177 # Open the file, and read it into the text widget
1179 if {[catch "open $filename" fh
]} {
1180 # File can't be read. Put error message into .src.nofile window and return.
1182 catch {destroy .src.nofile
}
1183 text .src.nofile
-height 25 -width 88 -relief sunken
\
1184 -borderwidth 2 -yscrollcommand ".src.scroll set" \
1185 -setgrid true
-cursor hand2
1186 .src.nofile insert
0.0 $fh
1187 .src.nofile configure
-state disabled
1188 bind .src.nofile
<1> do_nothing
1189 bind .src.nofile
<B1-Motion
> do_nothing
1193 # Actually create and do basic configuration on the text widget.
1195 text $win -height 25 -width 88 -relief sunken
-borderwidth 2 \
1196 -yscrollcommand ".src.scroll set" -setgrid true
-cursor hand2
1198 # Setup all the bindings
1200 bind $win <Enter
> {focus %W
}
1201 bind $win <1> do_nothing
1202 bind $win <B1-Motion
> do_nothing
1204 bind $win <Key-Alt_R
> do_nothing
1205 bind $win <Key-Alt_L
> do_nothing
1206 bind $win <Key-Prior
> "$win yview {@0,0 - 10 lines}"
1207 bind $win <Key-Next
> "$win yview {@0,0 + 10 lines}"
1208 bind $win <Key-Up
> "$win yview {@0,0 - 1 lines}"
1209 bind $win <Key-Down
> "$win yview {@0,0 + 1 lines}"
1210 bind $win <Key-Home
> {update_listing
[gdb_loc
]}
1211 bind $win <Key-End
> "$win see end"
1213 bind $win n
{interactive_cmd next
}
1214 bind $win s
{interactive_cmd step
}
1215 bind $win c
{interactive_cmd
continue}
1216 bind $win f
{interactive_cmd finish
}
1217 bind $win u
{interactive_cmd up
}
1218 bind $win d
{interactive_cmd down
}
1220 if $debug_interface {
1221 bind $win <Control-C
> {
1227 $win insert
0.0 [read $fh]
1230 # Add margins (for annotations) and a line number to each line (if requested)
1232 set numlines
[$win index end
]
1233 set numlines
[lindex [split $numlines .
] 0]
1234 if {$line_numbers} {
1235 for {set i
1} {$i <= $numlines} {incr i
} {
1236 $win insert
$i.0 [format " %4d " $i]
1237 $win tag add
source $i.8 "$i.0 lineend"
1240 for {set i
1} {$i <= $numlines} {incr i
} {
1241 $win insert
$i.0 " "
1242 $win tag add
source $i.8 "$i.0 lineend"
1248 foreach i
[gdb_sourcelines
$debug_file] {
1250 $win insert
$i.0 "\xa4"
1251 $win tag add margin
$i.0 $i.8
1254 # A debugging trick to highlight sensitive regions.
1255 if $debug_interface {
1256 $win tag
bind source <Enter
> {
1257 %W tag configure
source -background yellow
1259 $win tag
bind source <Leave
> {
1260 %W tag configure
source -background green
1262 $win tag
bind margin
<Enter
> {
1263 %W tag configure margin
-background red
1265 $win tag
bind margin
<Leave
> {
1266 %W tag configure margin
-background skyblue
1270 $win tag
bind margin
<1> {
1271 toggle_breakpoint
%W
%X
%Y
%x
%y
1274 $win tag
bind source <1> {
1275 %W mark
set anchor
"@%x,%y wordstart"
1276 set last
[%W index
"@%x,%y wordend"]
1277 %W tag remove sel
0.0 anchor
1278 %W tag remove sel
$last end
1279 %W tag add sel anchor
$last
1281 # $win tag bind source <Double-Button-1> {
1282 # %W mark set anchor "@%x,%y wordstart"
1283 # set last [%W index "@%x,%y wordend"]
1284 # %W tag remove sel 0.0 anchor
1285 # %W tag remove sel $last end
1286 # %W tag add sel anchor $last
1287 # echo "Selected [selection get]"
1289 $win tag
bind source <B1-Motion
> {
1290 %W tag remove sel
0.0 anchor
1291 %W tag remove sel
$last end
1292 %W tag add sel anchor
@%x
,%y
1294 $win tag
bind sel
<1> break
1295 $win tag
bind sel
<Double-Button-1
> {
1296 display_expression
[selection get
]
1299 $win tag
bind sel
<B1-Motion
> break
1302 $win tag
bind source <2> {
1303 listing_window_popup
%W
%X
%Y
%x
%y
1306 # Make these bindings do nothing on the text window -- they
1307 # are completely handled by the tag bindings above.
1309 bind $win <B1-Motion
> break
1310 bind $win <Double-Button-1
> break
1312 # Scan though the breakpoint data base and install any destined for this file
1314 foreach bpnum
[array names breakpoint_file
] {
1315 if {$breakpoint_file($bpnum) == $filename} {
1316 insert_breakpoint_tag
$win $breakpoint_line($bpnum)
1320 # Disable the text widget to prevent user modifications
1322 $win configure
-state disabled
1329 # create_asm_win (funcname pc) - Create an assembly win for FUNCNAME.
1333 # The new text widget.
1337 # This procedure creates a text widget for FUNCNAME. It returns the
1338 # newly created widget. First, a text widget is created, and given basic
1339 # configuration info. Second, all the bindings are setup. Third, the
1340 # function FUNCNAME is read into the text widget.
1343 proc create_asm_win
{funcname pc
} {
1344 global breakpoint_file
1345 global breakpoint_line
1347 global disassemble_with_source
1349 # Replace all the dirty characters in $filename with clean ones, and generate
1350 # a unique name for the text widget.
1352 set win
[asm_win_name
$funcname]
1354 # Actually create and do basic configuration on the text widget.
1356 text $win -height 25 -width 80 -relief sunken
-borderwidth 2 \
1357 -setgrid true
-cursor hand2
-yscrollcommand ".asm.scroll set"
1359 # Setup all the bindings
1361 bind $win <Enter
> {focus %W
}
1362 bind $win <1> {asm_window_button_1
%W
%X
%Y
%x
%y
; break}
1363 bind $win <B1-Motion
> break
1364 bind $win <Double-Button-1
> break
1366 bind $win <Key-Alt_R
> do_nothing
1367 bind $win <Key-Alt_L
> do_nothing
1369 bind $win n
{interactive_cmd nexti
}
1370 bind $win s
{interactive_cmd stepi
}
1371 bind $win c
{interactive_cmd
continue}
1372 bind $win f
{interactive_cmd finish
}
1373 bind $win u
{interactive_cmd up
}
1374 bind $win d
{interactive_cmd down
}
1376 # Disassemble the code, and read it into the new text widget
1378 $win insert end
[gdb_disassemble
$disassemble_with_source $pc]
1380 set numlines
[$win index end
]
1381 set numlines
[lindex [split $numlines .
] 0]
1384 # Delete the first and last lines, cuz these contain useless info
1386 # $win delete 1.0 2.0
1387 # $win delete {end - 1 lines} end
1390 # Add margins (for annotations) and note the PC for each line
1392 catch "unset pclist($funcname)"
1393 lappend pclist
($funcname) Unused
1394 for {set i
1} {$i <= $numlines} {incr i
} {
1395 scan [$win get
$i.0 "$i.0 lineend"] "%s " pc
1396 lappend pclist
($funcname) $pc
1397 $win insert
$i.0 " "
1400 # Scan though the breakpoint data base and install any destined for this file
1402 # foreach bpnum [array names breakpoint_file] {
1403 # if {$breakpoint_file($bpnum) == $filename} {
1404 # insert_breakpoint_tag $win $breakpoint_line($bpnum)
1408 # Disable the text widget to prevent user modifications
1410 $win configure
-state disabled
1417 # update_listing (linespec) - Update the listing window according to
1422 # This procedure is called from various places to update the listing
1423 # window based on LINESPEC. It is usually invoked with the result of
1426 # It will move the cursor, and scroll the text widget if necessary.
1427 # Also, it will switch to another text widget if necessary, and update
1428 # the label widget too.
1430 # LINESPEC is a list of the form:
1432 # { DEBUG_FILE FUNCNAME FILENAME LINE }, where:
1434 # DEBUG_FILE - is the abbreviated form of the file name. This is usually
1435 # the file name string given to the cc command. This is
1436 # primarily needed for breakpoint commands, and when an
1437 # abbreviated for of the filename is desired.
1438 # FUNCNAME - is the name of the function.
1439 # FILENAME - is the fully qualified (absolute) file name. It is usually
1440 # the same as $PWD/$DEBUG_FILE, where PWD is the working dir
1441 # at the time the cc command was given. This is used to
1442 # actually locate the file to be displayed.
1443 # LINE - The line number to be displayed.
1445 # Usually, this procedure will just move the cursor one line down to the
1446 # next line to be executed. However, if the cursor moves out of range
1447 # or into another file, it will scroll the text widget so that the line
1448 # of interest is in the middle of the viewable portion of the widget.
1451 proc update_listing
{linespec
} {
1454 global current_label
1456 global file_to_debug_file
1459 # Rip the linespec apart
1461 lassign
$linespec debug_file funcname
filename line
1463 # Sometimes there's no source file for this location
1465 if {$filename == ""} {set filename Blank
}
1467 # If we want to switch files, we need to unpack the current text widget, and
1468 # stick in the new one.
1470 if {$filename != $cfile} then
{
1471 pack forget
$wins($cfile)
1474 # Create a text widget for this file if necessary
1476 if {![info exists wins
($cfile)]} then
{
1477 set wins
($cfile) [create_file_win
$cfile $debug_file]
1478 if {$wins($cfile) != ".src.nofile"} {
1479 set win_to_file
($wins($cfile)) $cfile
1480 set file_to_debug_file
($cfile) $debug_file
1481 set pointers
($cfile) 1.1
1485 # Pack the text widget into the listing widget, and scroll to the right place
1487 pack $wins($cfile) -side left
-expand yes
-in .src.
info \
1488 -fill both
-after .src.scroll
1490 # Make the scrollbar point at the new text widget
1492 .src.scroll configure
-command "$wins($cfile) yview"
1494 # $wins($cfile) see "${line}.0 linestart"
1495 ensure_line_visible
$wins($cfile) $line
1498 # Update the label widget in case the filename or function name has changed
1500 if {$current_label != "$filename.$funcname"} then
{
1501 set tail
[expr [string last
/ $filename] + 1]
1502 set .src.
label "[string range $filename $tail end] : ${funcname}()"
1503 # .src.label configure -text "[string range $filename $tail end] : ${funcname}()"
1504 set current_label
$filename.
$funcname
1507 # Update the pointer, scrolling the text widget if necessary to keep the
1508 # pointer in an acceptable part of the screen.
1510 if {[info exists pointers
($cfile)]} then
{
1511 $wins($cfile) configure
-state normal
1512 set pointer_pos
$pointers($cfile)
1513 $wins($cfile) configure
-state normal
1514 $wins($cfile) delete
$pointer_pos "$pointer_pos + 2 char"
1515 $wins($cfile) insert
$pointer_pos " "
1517 set pointer_pos
[$wins($cfile) index
$line.1]
1518 set pointers
($cfile) $pointer_pos
1520 $wins($cfile) delete
$pointer_pos "$pointer_pos + 2 char"
1521 $wins($cfile) insert
$pointer_pos "->"
1522 ensure_line_visible
$wins($cfile) $line
1523 $wins($cfile) configure
-state disabled
1530 # create_asm_window - Open up the assembly window.
1534 # Create an assembly window if it doesn't exist.
1537 proc create_asm_window
{} {
1540 if {[winfo exists .asm
]} {raise .asm
; return}
1543 set win
[asm_win_name
$cfunc]
1545 build_framework .asm Assembly
"*NIL*"
1547 # First, delete all the old menu entries
1549 .asm.menubar.view.
menu delete
0 last
1551 .asm.
text configure
-yscrollcommand ".asm.scroll set"
1556 button .asm.stepi
-width 6 -text Stepi
\
1557 -command {interactive_cmd stepi
}
1558 button .asm.nexti
-width 6 -text Nexti
\
1559 -command {interactive_cmd nexti
}
1560 button .asm.
continue -width 6 -text Cont
\
1561 -command {interactive_cmd
continue}
1562 button .asm.finish
-width 6 -text Finish
\
1563 -command {interactive_cmd finish
}
1564 button .asm.up
-width 6 -text Up
-command {interactive_cmd up
}
1565 button .asm.down
-width 6 -text Down
\
1566 -command {interactive_cmd down
}
1567 button .asm.bottom
-width 6 -text Bottom
\
1568 -command {interactive_cmd
{frame 0}}
1570 pack .asm.stepi .asm.
continue .asm.up .asm.bottom
-side left
-padx 3 -pady 5 -in .asm.row1
1571 pack .asm.nexti .asm.finish .asm.down
-side left
-padx 3 -pady 5 -in .asm.row2
1573 pack .asm.row2 .asm.row1
-side bottom
-anchor w
-before .asm.
info
1577 update_assembly
[gdb_loc
]
1579 # We do this update_assembly to get the proper value of disassemble-from-exec.
1581 # exec file menu item
1582 .asm.menubar.view.
menu add
radiobutton -label "Exec file" \
1583 -variable disassemble-from-exec
-value 1
1584 # target memory menu item
1585 .asm.menubar.view.
menu add
radiobutton -label "Target memory" \
1586 -variable disassemble-from-exec
-value 0
1588 # Disassemble with source
1589 .asm.menubar.view.
menu add
checkbutton -label "Source" \
1590 -variable disassemble_with_source
-onvalue source \
1591 -offvalue nosource
-command {
1592 foreach asm
[info command .asm.func_
*] {
1596 update_assembly
[gdb_loc
]
1600 proc reg_config_menu
{} {
1601 catch {destroy .reg.config
}
1602 toplevel .reg.config
1603 wm geometry .reg.config
+300+300
1604 wm title .reg.config
"Register configuration"
1605 wm iconname .reg.config
"Reg config"
1606 set regnames
[gdb_regnames
]
1607 set num_regs
[llength $regnames]
1609 frame .reg.config.buts
1611 button .reg.config.done
-text " Done " -command "
1612 recompute_reg_display_list $num_regs
1614 update_registers all
1615 destroy .reg.config "
1617 button .reg.config.
update -text Update
-command "
1618 recompute_reg_display_list $num_regs
1620 update_registers all "
1622 pack .reg.config.buts
-side bottom
-fill x
1624 pack .reg.config.done
-side left
-fill x
-expand yes
-in .reg.config.buts
1625 pack .reg.config.
update -side right
-fill x
-expand yes
-in .reg.config.buts
1627 # Since there can be lots of registers, we build the window with no more than
1628 # 32 rows, and as many columns as needed.
1630 # First, figure out how many columns we need and create that many column frame
1633 set ncols
[expr ($num_regs + 31) / 32]
1635 for {set col
0} {$col < $ncols} {incr col
} {
1636 frame .reg.config.col
$col
1637 pack .reg.config.col
$col -side left
-anchor n
1640 # Now, create the checkbutton widgets and pack them in the appropriate columns
1644 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1645 set regname
[lindex $regnames $regnum]
1646 checkbutton .reg.config.col
$col.
$row -text $regname -pady 0 \
1647 -variable regena
($regnum) -relief flat
-anchor w
-bd 1
1649 pack .reg.config.col
$col.
$row -side top
-fill both
1662 # create_registers_window - Open up the register display window.
1666 # Create the register display window, with automatic updates.
1669 proc create_registers_window
{} {
1672 if {[winfo exists .reg
]} {raise .reg
; return}
1674 # Create an initial register display list consisting of all registers
1676 if {![info exists reg_format
]} {
1677 global reg_display_list
1678 global changed_reg_list
1682 set num_regs
[llength [gdb_regnames
]]
1683 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1684 set regena
($regnum) 1
1686 recompute_reg_display_list
$num_regs
1687 set changed_reg_list
$reg_display_list
1690 build_framework .reg Registers
1692 # First, delete all the old menu entries
1694 .reg.menubar.view.
menu delete
0 last
1697 .reg.menubar.view.
menu add
radiobutton -label Hex
\
1698 -command {set reg_format x
; update_registers all
}
1701 .reg.menubar.view.
menu add
radiobutton -label Decimal
\
1702 -command {set reg_format d
; update_registers all
}
1705 .reg.menubar.view.
menu add
radiobutton -label Octal
\
1706 -command {set reg_format o
; update_registers all
}
1709 .reg.menubar.view.
menu add
radiobutton -label Natural
\
1710 -command {set reg_format
{} ; update_registers all
}
1713 .reg.menubar.view.
menu add separator
1715 .reg.menubar.view.
menu add command
-label Config
-command {
1720 # Install the reg names
1723 update_registers all
1726 # Convert regena into a list of the enabled $regnums
1728 proc recompute_reg_display_list
{num_regs
} {
1729 global reg_display_list
1733 catch {unset reg_display_list
}
1736 for {set regnum
0} {$regnum < $num_regs} {incr regnum
} {
1738 if {[set regena
($regnum)] != 0} {
1739 lappend reg_display_list
$regnum
1740 set regmap
($regnum) $line
1746 # Fill out the register window with the names of the regs specified in
1749 proc populate_reg_window
{} {
1750 global max_regname_width
1751 global reg_display_list
1753 .reg.
text configure
-state normal
1755 .reg.
text delete
0.0 end
1757 set regnames
[eval gdb_regnames
$reg_display_list]
1759 # Figure out the longest register name
1761 set max_regname_width
0
1763 foreach reg
$regnames {
1764 set len
[string length
$reg]
1765 if {$len > $max_regname_width} {set max_regname_width
$len}
1768 set width
[expr $max_regname_width + 15]
1770 set height
[llength $regnames]
1772 if {$height > 60} {set height
60}
1774 .reg.
text configure
-height $height -width $width
1776 foreach reg
$regnames {
1777 .reg.
text insert end
[format "%-*s \n" $max_regname_width ${reg
}]
1781 .reg.
text configure
-state disabled
1787 # update_registers - Update the registers window.
1791 # This procedure updates the registers window.
1794 proc update_registers
{which
} {
1795 global max_regname_width
1797 global reg_display_list
1798 global changed_reg_list
1802 set margin
[expr $max_regname_width + 1]
1804 set winwidth
[lindex [$win configure
-width] 4]
1805 set valwidth
[expr $winwidth - $margin]
1807 $win configure
-state normal
1809 if {$which == "all"} {
1811 foreach regnum
$reg_display_list {
1812 set regval
[gdb_fetch_registers
$reg_format $regnum]
1813 set regval
[format "%-*s" $valwidth $regval]
1814 $win delete
$lineindex.
$margin "$lineindex.0 lineend"
1815 $win insert
$lineindex.
$margin $regval
1818 $win configure
-state disabled
1822 # Unhighlight the old values
1824 foreach regnum
$changed_reg_list {
1825 $win tag delete
$win.
$regnum
1828 # Now, highlight the changed values of the interesting registers
1830 set changed_reg_list
[eval gdb_changed_register_list
$reg_display_list]
1833 foreach regnum
$changed_reg_list {
1834 set regval
[gdb_fetch_registers
$reg_format $regnum]
1835 set regval
[format "%-*s" $valwidth $regval]
1837 set lineindex
$regmap($regnum)
1838 $win delete
$lineindex.
$margin "$lineindex.0 lineend"
1839 $win insert
$lineindex.
$margin $regval
1840 $win tag add
$win.
$regnum $lineindex.0 "$lineindex.0 lineend"
1841 eval $win tag configure
$win.
$regnum $highlight
1844 $win configure
-state disabled
1850 # update_assembly - Update the assembly window.
1854 # This procedure updates the assembly window.
1857 proc update_assembly
{linespec
} {
1860 global current_label
1862 global file_to_debug_file
1863 global current_asm_label
1867 # Rip the linespec apart
1869 lassign
$linespec debug_file funcname
filename line pc
1871 set win
[asm_win_name
$cfunc]
1873 # Sometimes there's no source file for this location
1875 if {$filename == ""} {set filename Blank
}
1877 # If we want to switch funcs, we need to unpack the current text widget, and
1878 # stick in the new one.
1880 if {$funcname != $cfunc } {
1884 set win
[asm_win_name
$cfunc]
1886 # Create a text widget for this func if necessary
1888 if {![winfo exists
$win]} {
1889 create_asm_win
$cfunc $pc
1890 set asm_pointers
($cfunc) 1.1
1891 set current_asm_label NIL
1894 # Pack the text widget, and scroll to the right place
1897 pack $win -side left
-expand yes
-fill both
\
1899 .asm.scroll configure
-command "$win yview"
1900 set line
[pc_to_line
$pclist($cfunc) $pc]
1901 ensure_line_visible
$win $line
1905 # Update the label widget in case the filename or function name has changed
1907 if {$current_asm_label != "$pc $funcname"} then
{
1908 set .asm.
label "$pc $funcname"
1909 set current_asm_label
"$pc $funcname"
1912 # Update the pointer, scrolling the text widget if necessary to keep the
1913 # pointer in an acceptable part of the screen.
1915 if {[info exists asm_pointers
($cfunc)]} then
{
1916 $win configure
-state normal
1917 set pointer_pos
$asm_pointers($cfunc)
1918 $win configure
-state normal
1919 $win delete
$pointer_pos "$pointer_pos + 2 char"
1920 $win insert
$pointer_pos " "
1922 # Map the PC back to a line in the window
1924 set line
[pc_to_line
$pclist($cfunc) $pc]
1927 echo
"Can't find PC $pc"
1931 set pointer_pos
[$win index
$line.1]
1932 set asm_pointers
($cfunc) $pointer_pos
1934 $win delete
$pointer_pos "$pointer_pos + 2 char"
1935 $win insert
$pointer_pos "->"
1936 ensure_line_visible
$win $line
1937 $win configure
-state disabled
1944 # update_ptr - Update the listing window.
1948 # This routine will update the listing window using the result of
1952 proc update_ptr
{} {
1953 update_listing
[gdb_loc
]
1954 if {[winfo exists .asm
]} {
1955 update_assembly
[gdb_loc
]
1957 if {[winfo exists .reg
]} {
1958 update_registers changed
1960 if {[winfo exists .
expr]} {
1963 if {[winfo exists .autocmd
]} {
1968 # Make toplevel window disappear
1972 proc files_command
{} {
1973 toplevel .files_window
1975 wm minsize .files_window
1 1
1976 # wm overrideredirect .files_window true
1977 listbox .files_window.
list -width 30 -height 20 -setgrid true
\
1978 -yscrollcommand {.files_window.scroll
set} -relief sunken
\
1980 scrollbar .files_window.scroll
-orient vertical
\
1981 -command {.files_window.
list yview
} -relief sunken
1982 button .files_window.
close -text Close
-command {destroy .files_window
}
1983 .files_window.
list configure
-selectmode single
1985 # Get the file list from GDB, sort it, and insert into the widget.
1986 eval .files_window.
list insert
0 [lsort [gdb_listfiles
]]
1988 pack .files_window.
close -side bottom
-fill x
-expand no
-anchor s
1989 pack .files_window.scroll
-side right
-fill both
1990 pack .files_window.
list -side left
-fill both
-expand yes
1991 bind .files_window.
list <Any-ButtonRelease-1
> {
1992 set file [%W get
[%W curselection
]]
1993 gdb_cmd
"list $file:1,0"
1994 update_listing
[gdb_loc
$file:1]
1995 destroy .files_window
1999 button .files
-text Files
-command files_command
2001 proc apply_filespec
{label default command
} {
2002 set filename [FSBox
$label $default]
2003 if {$filename != ""} {
2004 if {[catch {gdb_cmd
"$command $filename"} retval
]} {
2005 tk_dialog .filespec_error
"gdb : $label error" \
2006 "Error in command \"$command $filename\"" error \
2015 proc run_editor
{editor
file} {
2016 # FIXME should use index of line in middle of window, not line at
2019 set lineNo
[lindex [split [$wins($file) index
@0,0] .
] 0]
2020 exec $editor +$lineNo $file
2023 # Setup command window
2024 proc build_framework
{win
{title GDBtk
} {label {}}} {
2028 wm title
${win
} $title
2029 wm minsize
${win
} 1 1
2031 frame ${win
}.menubar
2033 menubutton ${win
}.menubar.
file -padx 12 -text File
\
2034 -menu ${win
}.menubar.
file.
menu -underline 0
2036 menu ${win
}.menubar.
file.
menu
2037 ${win
}.menubar.
file.
menu add command
-label File...
\
2038 -command {apply_filespec File a.out
file}
2039 ${win
}.menubar.
file.
menu add command
-label Target...
\
2040 -command { not_implemented_yet
"target" }
2041 ${win
}.menubar.
file.
menu add command
-label Edit
\
2042 -command {run_editor
$editor $cfile}
2043 ${win
}.menubar.
file.
menu add separator
2044 ${win
}.menubar.
file.
menu add command
-label "Exec File..." \
2045 -command {apply_filespec
{Exec File
} a.out exec-file
}
2046 ${win
}.menubar.
file.
menu add command
-label "Symbol File..." \
2047 -command {apply_filespec
{Symbol File
} a.out symbol-file
}
2048 ${win
}.menubar.
file.
menu add command
-label "Add Symbol File..." \
2049 -command { not_implemented_yet
"menu item, add symbol file" }
2050 ${win
}.menubar.
file.
menu add command
-label "Core File..." \
2051 -command {apply_filespec
{Core File
} core core-file
}
2053 ${win
}.menubar.
file.
menu add separator
2054 ${win
}.menubar.
file.
menu add command
-label Close
\
2055 -command "destroy ${win}"
2056 ${win
}.menubar.
file.
menu add separator
2057 ${win
}.menubar.
file.
menu add command
-label Quit
\
2058 -command {interactive_cmd quit
}
2060 menubutton ${win
}.menubar.commands
-padx 12 -text Commands
\
2061 -menu ${win
}.menubar.commands.
menu -underline 0
2063 menu ${win
}.menubar.commands.
menu
2064 ${win
}.menubar.commands.
menu add command
-label Run
\
2065 -command {interactive_cmd run
}
2066 ${win
}.menubar.commands.
menu add command
-label Step
\
2067 -command {interactive_cmd step
}
2068 ${win
}.menubar.commands.
menu add command
-label Next
\
2069 -command {interactive_cmd next
}
2070 ${win
}.menubar.commands.
menu add command
-label Continue
\
2071 -command {interactive_cmd
continue}
2072 ${win
}.menubar.commands.
menu add separator
2073 ${win
}.menubar.commands.
menu add command
-label Stepi
\
2074 -command {interactive_cmd stepi
}
2075 ${win
}.menubar.commands.
menu add command
-label Nexti
\
2076 -command {interactive_cmd nexti
}
2078 menubutton ${win
}.menubar.view
-padx 12 -text Options
\
2079 -menu ${win
}.menubar.view.
menu -underline 0
2081 menu ${win
}.menubar.view.
menu
2082 ${win
}.menubar.view.
menu add command
-label Hex
\
2084 ${win
}.menubar.view.
menu add command
-label Decimal
\
2085 -command {echo Decimal
}
2086 ${win
}.menubar.view.
menu add command
-label Octal
\
2087 -command {echo Octal
}
2089 menubutton ${win
}.menubar.window
-padx 12 -text Window
\
2090 -menu ${win
}.menubar.window.
menu -underline 0
2092 menu ${win
}.menubar.window.
menu
2093 ${win
}.menubar.window.
menu add command
-label Command
\
2094 -command create_command_window
2095 ${win
}.menubar.window.
menu add separator
2096 ${win
}.menubar.window.
menu add command
-label Source
\
2097 -command create_source_window
2098 ${win
}.menubar.window.
menu add command
-label Assembly
\
2099 -command create_asm_window
2100 ${win
}.menubar.window.
menu add separator
2101 ${win
}.menubar.window.
menu add command
-label Registers
\
2102 -command create_registers_window
2103 ${win
}.menubar.window.
menu add command
-label Expressions
\
2104 -command create_expr_window
2105 ${win
}.menubar.window.
menu add command
-label "Auto Command" \
2106 -command create_autocmd_window
2107 ${win
}.menubar.window.
menu add command
-label Breakpoints
\
2108 -command create_breakpoints_window
2110 # ${win}.menubar.window.menu add separator
2111 # ${win}.menubar.window.menu add command -label Files \
2112 # -command { not_implemented_yet "files window" }
2114 menubutton ${win
}.menubar.help
-padx 12 -text Help
\
2115 -menu ${win
}.menubar.help.
menu -underline 0
2117 menu ${win
}.menubar.help.
menu
2118 ${win
}.menubar.help.
menu add command
-label "with GDBtk" \
2119 -command {echo
"with GDBtk"}
2120 ${win
}.menubar.help.
menu add command
-label "with this window" \
2121 -command {echo
"with this window"}
2122 ${win
}.menubar.help.
menu add command
-label "Report bug" \
2123 -command {exec send-pr
}
2125 pack ${win
}.menubar.
file \
2126 ${win
}.menubar.view
\
2127 ${win
}.menubar.window
-side left
2128 pack ${win
}.menubar.help
-side right
2131 text ${win
}.
text -height 25 -width 80 -relief sunken
-borderwidth 2 \
2132 -setgrid true
-cursor hand2
-yscrollcommand "${win}.scroll set"
2134 set ${win
}.
label $label
2135 label ${win
}.
label -textvariable ${win
}.
label -borderwidth 2 -relief sunken
2137 scrollbar ${win
}.scroll
-orient vertical
-command "${win}.text yview" \
2140 bind $win <Key-Alt_R
> do_nothing
2141 bind $win <Key-Alt_L
> do_nothing
2143 pack ${win
}.
label -side bottom
-fill x
-in ${win
}.
info
2144 pack ${win
}.scroll
-side right
-fill y
-in ${win
}.
info
2145 pack ${win
}.
text -side left
-expand yes
-fill both
-in ${win
}.
info
2147 pack ${win
}.menubar
-side top
-fill x
2148 pack ${win
}.
info -side top
-fill both
-expand yes
2151 proc create_source_window
{} {
2155 if {[winfo exists .src
]} {raise .src
; return}
2157 build_framework .src Source
"*No file*"
2159 # First, delete all the old view menu entries
2161 .src.menubar.view.
menu delete
0 last
2163 # Source file selection
2164 .src.menubar.view.
menu add command
-label "Select source file" \
2165 -command files_command
2167 # Line numbers enable/disable menu item
2168 .src.menubar.view.
menu add
checkbutton -variable line_numbers
\
2169 -label "Line numbers" -onvalue 1 -offvalue 0 -command {
2170 foreach source [array names wins
] {
2171 if {$source == "Blank"} continue
2172 destroy $wins($source)
2176 update_listing
[gdb_loc
]
2182 button .src.start
-width 6 -text Start
-command \
2183 {interactive_cmd
{break main
}
2184 interactive_cmd
{enable delete
$bpnum}
2185 interactive_cmd run
}
2186 button .src.stop
-width 6 -text Stop
-fg red
-activeforeground red
\
2187 -state disabled
-command gdb_stop
2188 button .src.step
-width 6 -text Step
\
2189 -command {interactive_cmd step
}
2190 button .src.next
-width 6 -text Next
\
2191 -command {interactive_cmd next
}
2192 button .src.
continue -width 6 -text Cont
\
2193 -command {interactive_cmd
continue}
2194 button .src.finish
-width 6 -text Finish
\
2195 -command {interactive_cmd finish
}
2196 button .src.up
-width 6 -text Up
\
2197 -command {interactive_cmd up
}
2198 button .src.down
-width 6 -text Down
\
2199 -command {interactive_cmd down
}
2200 button .src.bottom
-width 6 -text Bottom
\
2201 -command {interactive_cmd
{frame 0}}
2203 pack .src.start .src.step .src.
continue .src.up .src.bottom
\
2204 -side left
-padx 3 -pady 5 -in .src.row1
2205 pack .src.stop .src.next .src.finish .src.down
-side left
-padx 3 \
2206 -pady 5 -in .src.row2
2208 pack .src.row2 .src.row1
-side bottom
-anchor w
-before .src.
info
2210 $wins($cfile) insert
0.0 " This page intentionally left blank."
2211 $wins($cfile) configure
-width 88 -state disabled
\
2212 -yscrollcommand ".src.scroll set"
2215 proc update_autocmd
{} {
2216 global .autocmd.
label
2217 global accumulate_output
2219 catch {gdb_cmd
"${.autocmd.label}"} result
2220 if {!$accumulate_output} { .autocmd.
text delete
0.0 end
}
2221 .autocmd.
text insert end
$result
2222 .autocmd.
text see end
2225 proc create_autocmd_window
{} {
2226 global .autocmd.
label
2228 if {[winfo exists .autocmd
]} {raise .autocmd
; return}
2230 build_framework .autocmd
"Auto Command" ""
2232 # First, delete all the old view menu entries
2234 .autocmd.menubar.view.
menu delete
0 last
2236 # Accumulate output option
2238 .autocmd.menubar.view.
menu add
checkbutton \
2239 -variable accumulate_output
\
2240 -label "Accumulate output" -onvalue 1 -offvalue 0
2242 # Now, create entry widget with label
2244 frame .autocmd.entryframe
2246 entry .autocmd.
entry -borderwidth 2 -relief sunken
2247 bind .autocmd.
entry <Key-Return
> {
2248 set .autocmd.
label [.autocmd.
entry get
]
2249 .autocmd.
entry delete
0 end
2252 label .autocmd.entrylab
-text "Command: "
2254 pack .autocmd.entrylab
-in .autocmd.entryframe
-side left
2255 pack .autocmd.
entry -in .autocmd.entryframe
-side left
-fill x
-expand yes
2257 pack .autocmd.entryframe
-side bottom
-fill x
-before .autocmd.
info
2260 # Return the longest common prefix in SLIST. Can be empty string.
2262 proc find_lcp slist
{
2263 # Handle trivial cases where list is empty or length 1
2264 if {[llength $slist] <= 1} {return [lindex $slist 0]}
2266 set prefix
[lindex $slist 0]
2267 set prefixlast
[expr [string length
$prefix] - 1]
2269 foreach str
[lrange $slist 1 end
] {
2270 set test_str
[string range
$str 0 $prefixlast]
2271 while {[string compare
$test_str $prefix] != 0} {
2273 set prefix
[string range
$prefix 0 $prefixlast]
2274 set test_str
[string range
$str 0 $prefixlast]
2276 if {$prefixlast < 0} break
2281 # Look through COMPLETIONS to generate the suffix needed to do command
2282 # completion on CMD.
2284 proc find_completion
{cmd completions
} {
2285 # Get longest common prefix
2286 set lcp
[find_lcp
$completions]
2287 set cmd_len
[string length
$cmd]
2288 # Return suffix beyond end of cmd
2289 return [string range
$lcp $cmd_len end
]
2292 proc create_command_window
{} {
2298 if {[winfo exists .cmd
]} {raise .cmd
; return}
2300 build_framework .cmd Command
"* Command Buffer *"
2302 # Put focus on command area.
2307 gdb_cmd
{set language c
}
2308 gdb_cmd
{set height
0}
2309 gdb_cmd
{set width
0}
2311 bind .cmd.
text <Control-c
> gdb_stop
2313 # Tk uses the Motifism that Delete means delete forward. I
2314 # hate this, and I'm not gonna take it any more.
2315 set bsBinding
[bind Text
<BackSpace
>]
2316 bind .cmd.
text <Delete
> "delete_char %W ; $bsBinding; break"
2317 bind .cmd.
text <BackSpace
> {
2318 if {([%W cget
-state] == "disabled")} { break }
2321 bind .cmd.
text <Control-u
> {
2322 if {([%W cget
-state] == "disabled")} { break }
2326 bind .cmd.
text <Any-Key
> {
2327 if {([%W cget
-state] == "disabled")} { break }
2331 append command_line
%A
2334 bind .cmd.
text <Key-Return
> {
2335 if {([%W cget
-state] == "disabled")} { break }
2338 interactive_cmd
$command_line
2341 # catch "gdb_cmd [list $command_line]" result
2342 # %W insert end $result
2345 %W insert end
"$gdb_prompt"
2349 bind .cmd.
text <Button-2
> {
2350 %W insert end
[selection get
]
2352 append command_line
[selection get
]
2355 bind .cmd.
text <B2-Motion
> break
2356 bind .cmd.
text <ButtonRelease-2
> break
2357 bind .cmd.
text <Key-Tab
> {
2358 if {([%W cget
-state] == "disabled")} { break }
2359 set choices
[gdb_cmd
"complete $command_line"]
2360 set choices
[string trimright
$choices \n]
2361 set choices
[split $choices \n]
2363 # Just do completion if this is the first tab
2366 set completion
[find_completion
$command_line $choices]
2367 append command_line
$completion
2368 # Here is where the completion is actually done. If there
2369 # is one match, complete the command and print a space.
2370 # If two or more matches, complete the command and beep.
2371 # If no match, just beep.
2372 switch [llength $choices] {
2375 %W insert end
"$completion "
2376 append command_line
" "
2381 %W insert end
$completion
2387 # User hit another consecutive tab. List the choices.
2388 # Note that at this point, choices may contain commands
2389 # with spaces. We have to lop off everything before (and
2390 # including) the last space so that the completion list
2391 # only shows the possibilities for the last token.
2392 set choices
[lsort $choices]
2393 if {[regexp ".* " $command_line prefix
]} {
2394 regsub -all $prefix $choices {} choices
2396 %W insert end
"\n[join $choices { }]\n$gdb_prompt$command_line"
2403 # Trim one character off the command line. The argument is ignored.
2405 proc delete_char
{win
} {
2407 set tmp
[expr [string length
$command_line] - 2]
2408 set command_line
[string range
$command_line 0 $tmp]
2411 # FIXME: This should actually check that the first characters of the current
2412 # line match the gdb prompt, since the user can move the insertion point
2413 # anywhere. It should also check that the insertion point is in the last
2414 # line of the text widget.
2416 proc delete_line
{win
} {
2420 set tmp
[string length
$gdb_prompt]
2421 $win delete
"insert linestart + $tmp chars" "insert lineend"
2428 # simple file selector.
2430 # Mario Jorge Silva msilva@cs.Berkeley.EDU
2431 # University of California Berkeley Ph: +1(510)642-8248
2432 # Computer Science Division, 571 Evans Hall Fax: +1(510)642-5775
2436 # Copyright 1993 Regents of the University of California
2437 # Permission to use, copy, modify, and distribute this
2438 # software and its documentation for any purpose and without
2439 # fee is hereby granted, provided that this copyright
2440 # notice appears in all copies. The University of California
2441 # makes no representations about the suitability of this
2442 # software for any purpose. It is provided "as is" without
2443 # express or implied warranty.
2447 # names starting with "fileselect" are reserved by this module
2448 # no other names used.
2449 # Hack - FSBox is defined instead of fileselect for backwards compatibility
2452 # this is the proc that creates the file selector box
2453 # purpose - comment string
2454 # defaultName - initial value for name
2455 # cmd - command to eval upon OK
2456 # errorHandler - command to eval upon Cancel
2457 # If neither cmd or errorHandler are specified, the return value
2458 # of the FSBox procedure is the selected file name.
2460 proc FSBox
{{purpose
"Select file:"} {defaultName
""} {cmd
""} {errorHandler
2464 if {[Exwin_Toplevel
$w "Select File" FileSelect
]} {
2465 # path independent names for the widgets
2467 set fileselect
(list) $w.
file.sframe.
list
2468 set fileselect
(scroll
) $w.
file.sframe.scroll
2469 set fileselect
(direntry
) $w.
file.f1.direntry
2470 set fileselect
(entry) $w.
file.f2.
entry
2471 set fileselect
(ok
) $w.but.ok
2472 set fileselect
(cancel
) $w.but.cancel
2473 set fileselect
(msg
) $w.
label
2475 set fileselect
(result
) "" ;# value to return if no callback procedures
2478 Widget_Label
$w label {top fillx pady
10 padx
20} -anchor w
-width 24
2479 Widget_Frame
$w file Dialog
{left expand fill
} -bd 10
2481 Widget_Frame
$w.
file f1 Exmh
{top fillx
}
2482 Widget_Label
$w.
file.f1
label {left
} -text "Dir"
2483 Widget_Entry
$w.
file.f1 direntry
{right fillx expand
} -width 30
2485 Widget_Frame
$w.
file sframe
2487 scrollbar $w.
file.sframe.yscroll
-relief sunken
\
2488 -command [list $w.
file.sframe.
list yview
]
2489 listbox $w.
file.sframe.
list -relief sunken
\
2490 -yscroll [list $w.
file.sframe.yscroll
set] -setgrid 1
2491 pack append $w.
file.sframe
\
2492 $w.
file.sframe.yscroll
{right filly
} \
2493 $w.
file.sframe.
list {left expand fill
}
2495 Widget_Frame
$w.
file f2 Exmh
{top fillx
}
2496 Widget_Label
$w.
file.f2
label {left
} -text Name
2497 Widget_Entry
$w.
file.f2
entry {right fillx expand
}
2500 $w.but.quit configure
-text Cancel
\
2501 -command [list fileselect.cancel.cmd
$w]
2503 Widget_AddBut
$w.but ok OK
\
2504 [list fileselect.ok.cmd
$w $cmd $errorHandler] {left padx
1}
2506 Widget_AddBut
$w.but
list List
\
2507 [list fileselect.
list.cmd
$w] {left padx
1}
2508 Widget_CheckBut
$w.but listall
"List all" fileselect
(pattern
)
2509 $w.but.listall configure
-onvalue "{*,.*}" -offvalue "*" \
2510 -command {fileselect.
list.cmd
$fileselect(direntry
)}
2511 $w.but.listall deselect
2513 # Set up bindings for the browser.
2514 foreach ww
[list $w $fileselect(entry)] {
2515 bind $ww <Return
> [list $fileselect(ok
) invoke
]
2516 bind $ww <Control-c
> [list $fileselect(cancel
) invoke
]
2518 bind $fileselect(direntry
) <Return
> [list fileselect.
list.cmd
%W
]
2519 bind $fileselect(direntry
) <Tab
> [list fileselect.tab.dircmd
]
2520 bind $fileselect(entry) <Tab
> [list fileselect.tab.filecmd
]
2522 $fileselect(list) configure
-selectmode single
2524 bind $fileselect(list) <Button-1
> {
2525 # puts stderr "button 1 release"
2526 $fileselect(entry) delete
0 end
2527 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2530 bind $fileselect(list) <Key
> {
2531 $fileselect(entry) delete
0 end
2532 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2535 bind $fileselect(list) <Double-ButtonPress-1
> {
2536 # puts stderr "double button 1"
2537 $fileselect(entry) delete
0 end
2538 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2539 $fileselect(ok
) invoke
2542 bind $fileselect(list) <Return
> {
2543 $fileselect(entry) delete
0 end
2544 $fileselect(entry) insert
0 [%W get
[%W nearest
%y
]]
2545 $fileselect(ok
) invoke
2548 set fileselect
(text) $purpose
2549 $fileselect(msg
) configure
-text $purpose
2550 $fileselect(entry) delete
0 end
2551 $fileselect(entry) insert
0 [file tail
$defaultName]
2553 if {[info exists fileselect
(lastDir
)] && ![string length
$defaultName]} {
2554 set dir
$fileselect(lastDir
)
2556 set dir
[file dirname
$defaultName]
2558 set fileselect
(pwd) [pwd]
2560 $fileselect(direntry
) delete
0 end
2561 $fileselect(direntry
) insert
0 [pwd]/
2563 $fileselect(list) delete
0 end
2564 $fileselect(list) insert
0 "Big directory:"
2565 $fileselect(list) insert
1 $dir
2566 $fileselect(list) insert
2 "Press Return for Listing"
2568 fileselect.
list.cmd
$fileselect(direntry
) startup
2570 # set kbd focus to entry widget
2572 # Exwin_ToplevelFocus $w $fileselect(entry)
2574 # Wait for button hits if no callbacks are defined
2576 if {"$cmd" == "" && "$errorHandler" == ""} {
2577 # wait for the box to be destroyed
2580 tkwait variable fileselect
(result
)
2583 set path
$fileselect(result
)
2584 set fileselect
(lastDir
) [pwd]
2585 fileselect.
cd $fileselect(pwd)
2586 return [string trimright
[string trim
$path] /]
2588 fileselect.
cd $fileselect(pwd)
2592 proc fileselect.
cd { dir
} {
2594 if {[catch {cd $dir} err
]} {
2599 # auxiliary button procedures
2601 proc fileselect.yck
{ {tag
{}} } {
2603 $fileselect(msg
) configure
-text "Yck! $tag"
2606 proc fileselect.ok
{} {
2608 $fileselect(msg
) configure
-text $fileselect(text)
2611 proc fileselect.cancel.cmd
{w
} {
2613 set fileselect
(result
) {}
2617 proc fileselect.
list.cmd
{w
{state normal
}} {
2619 set seldir
[$fileselect(direntry
) get
]
2620 if {[catch {glob $seldir} dir
]} {
2621 fileselect.yck
"glob failed"
2624 if {[llength $dir] > 1} {
2625 set dir
[file dirname
$seldir]
2626 set pat
[file tail
$seldir]
2628 set pat
$fileselect(pattern
)
2632 if {[file isdirectory
$dir]} {
2633 fileselect.getfiles
$dir $pat $state
2634 focus $fileselect(entry)
2636 fileselect.yck
"not a dir"
2640 proc fileselect.ok.cmd
{w cmd errorHandler
} {
2642 set selname
[$fileselect(entry) get
]
2643 set seldir
[$fileselect(direntry
) get
]
2645 if {[string match
/* $selname]} {
2646 set selected
$selname
2648 if {[string match ~
* $selname]} {
2649 set selected
$selname
2651 set selected
$seldir/$selname
2655 # some nasty file names may cause "file isdirectory" to return an error
2656 if {[catch {file isdirectory
$selected} isdir
]} {
2657 fileselect.yck
"isdirectory failed"
2660 if {[catch {glob $selected} globlist
]} {
2661 if {![file isdirectory
[file dirname
$selected]]} {
2662 fileselect.yck
"bad pathname"
2665 set globlist
$selected
2670 if {[llength $globlist] > 1} {
2671 set dir
[file dirname
$selected]
2672 set pat
[file tail
$selected]
2673 fileselect.getfiles
$dir $pat
2676 set selected
$globlist
2678 if {[file isdirectory
$selected]} {
2679 fileselect.getfiles
$selected $fileselect(pattern
)
2680 $fileselect(entry) delete
0 end
2687 set fileselect
(result
) $selected
2692 proc fileselect.getfiles
{ dir
{pat
*} {state normal
} } {
2694 $fileselect(msg
) configure
-text Listing...
2697 set currentDir
[pwd]
2699 if {[catch {set files
[lsort [glob -nocomplain $pat]]} err
]} {
2700 $fileselect(msg
) configure
-text $err
2701 $fileselect(list) delete
0 end
2707 # Normal case - show current directory
2708 $fileselect(direntry
) delete
0 end
2709 $fileselect(direntry
) insert
0 [pwd]/
2712 # Directory already OK (tab related)
2715 # Changing directory (tab related)
2716 fileselect.
cd $currentDir
2719 # Avoid listing huge directories upon startup.
2720 $fileselect(direntry
) delete
0 end
2721 $fileselect(direntry
) insert
0 [pwd]/
2722 if {[llength $files] > 32} {
2729 # build a reordered list of the files: directories are displayed first
2730 # and marked with a trailing "/"
2731 if {[string compare
$dir /]} {
2732 fileselect.putfiles
$files [expr {($pat == "*") ?
1 : 0}]
2734 fileselect.putfiles
$files
2739 proc fileselect.putfiles
{files
{dotdot
0} } {
2742 $fileselect(list) delete
0 end
2744 $fileselect(list) insert end
"../"
2747 if {[file isdirectory
$i]} {
2748 $fileselect(list) insert end
$i/
2750 $fileselect(list) insert end
$i
2755 proc FileExistsDialog
{ name
} {
2758 set fileExists
(ok
) 0
2760 message $w.msg
-aspect 1000
2761 pack $w.msg
-side top
-fill both
-padx 20 -pady 20
2762 $w.but.quit config
-text Cancel
-command {FileExistsCancel
}
2763 button $w.but.ok
-text OK
-command {FileExistsOK
}
2764 pack $w.but.ok
-side left
2765 bind $w.msg
<Return
> {FileExistsOK
}
2767 $w.msg config
-text "Warning: file exists
2769 OK to overwrite it?"
2771 set fileExists
(focus) [focus]
2774 tkwait variable fileExists
(ok
)
2777 return $fileExists(ok
)
2780 proc FileExistsCancel
{} {
2782 set fileExists
(ok
) 0
2785 proc FileExistsOK
{} {
2787 set fileExists
(ok
) 1
2790 proc fileselect.getfiledir
{ dir
{basedir
[pwd]} } {
2793 set path
[$fileselect(direntry
) get
]
2797 if {[string index
$path 0] == "~"} {
2801 set path
[$fileselect(entry) get
]
2803 if {[catch {set listFile
[glob -nocomplain $path*]}]} {
2806 foreach el
$listFile {
2808 if {[file isdirectory
$el]} {
2809 lappend returnList
[file tail
$el]
2811 } elseif
{![file isdirectory
$el]} {
2812 lappend returnList
[file tail
$el]
2819 proc fileselect.gethead
{ list } {
2822 for {set i
0} {[string length
[lindex $list 0]] > $i}\
2823 {incr i
; set returnHead
$returnHead$thisChar} {
2824 set thisChar
[string index
[lindex $list 0] $i]
2826 if {[string length
$el] < $i} {
2829 if {$thisChar != [string index
$el $i]} {
2837 # FIXME this function is a crock. Can write tilde expanding function
2838 # in terms of glob and quote_glob; do so.
2839 proc fileselect.expand.tilde
{ } {
2842 set entry [$fileselect(direntry
) get
]
2843 set dir
[string range
$entry 1 [string length
$entry]]
2851 ## look in /etc/passwd
2852 if {[file exists
/etc
/passwd
]} {
2853 if {[catch {set users
[exec cat
/etc
/passwd | sed s
/:.
*//]} err
]} {
2854 puts "Error\#1 $err"
2857 set list [split $users "\n"]
2859 if {[lsearch -exact $list "+"] != -1} {
2860 if {[catch {set users
[exec ypcat passwd | sed s
/:.
*//]} err
]} {
2861 puts "Error\#2 $err"
2864 set list [concat $list [split $users "\n"]]
2866 $fileselect(list) delete
0 end
2868 if {[string match
$dir* $el]} {
2869 lappend listmatch
$el
2870 $fileselect(list) insert end
$el
2873 set addings
[fileselect.gethead
$listmatch]
2874 if {$addings == ""} {
2877 $fileselect(direntry
) delete
0 end
2878 if {[llength $listmatch] == 1} {
2879 $fileselect(direntry
) insert
0 [file dirname ~
$addings/]
2880 fileselect.getfiles
[$fileselect(direntry
) get
]
2882 $fileselect(direntry
) insert
0 ~
$addings
2886 proc fileselect.tab.dircmd
{ } {
2889 set dir
[$fileselect(direntry
) get
]
2891 $fileselect(direntry
) delete
0 end
2892 $fileselect(direntry
) insert
0 [pwd]
2893 if {[string compare
[pwd] "/"]} {
2894 $fileselect(direntry
) insert end
/
2898 if {[catch {set tmp
[file isdirectory
[file dirname
$dir]]}]} {
2899 if {[string index
$dir 0] == "~"} {
2900 fileselect.expand.tilde
2907 set dirFile
[fileselect.getfiledir
1 $dir]
2908 if {![llength $dirFile]} {
2911 if {[llength $dirFile] == 1} {
2912 $fileselect(direntry
) delete
0 end
2913 $fileselect(direntry
) insert
0 [file dirname
$dir]
2914 if {[string compare
[file dirname
$dir] /]} {
2915 $fileselect(direntry
) insert end
/[lindex $dirFile 0]/
2917 $fileselect(direntry
) insert end
[lindex $dirFile 0]/
2919 fileselect.getfiles
[$fileselect(direntry
) get
] \
2920 "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
2923 set headFile
[fileselect.gethead
$dirFile]
2924 $fileselect(direntry
) delete
0 end
2925 $fileselect(direntry
) insert
0 [file dirname
$dir]
2926 if {[string compare
[file dirname
$dir] /]} {
2927 $fileselect(direntry
) insert end
/$headFile
2929 $fileselect(direntry
) insert end
$headFile
2931 if {$headFile == "" && [file isdirectory
$dir]} {
2932 fileselect.getfiles
$dir\
2933 "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
2935 fileselect.getfiles
[file dirname
$dir]\
2936 "[file tail [$fileselect(direntry) get]]*" newdir
2940 proc fileselect.tab.filecmd
{ } {
2943 set dir
[$fileselect(direntry
) get
]
2947 if {![file isdirectory
$dir]} {
2948 error "dir $dir doesn't exist"
2950 set listFile
[fileselect.getfiledir
0 $dir]
2952 if {![llength $listFile]} {
2955 if {[llength $listFile] == 1} {
2956 $fileselect(entry) delete
0 end
2957 $fileselect(entry) insert
0 [lindex $listFile 0]
2960 set headFile
[fileselect.gethead
$listFile]
2961 $fileselect(entry) delete
0 end
2962 $fileselect(entry) insert
0 $headFile
2963 fileselect.getfiles
$dir "[$fileselect(entry) get]$fileselect(pattern)" opt
2966 proc Exwin_Toplevel
{ path name
{class Dialog
} {dismiss yes
}} {
2968 if {[catch {wm state
$path} state
]} {
2969 set t
[Widget_Toplevel
$path $name $class]
2970 if {![info exists exwin
(toplevels
)]} {
2971 set exwin
(toplevels
) [option get . exwinPaths
{}]
2973 set ix
[lsearch $exwin(toplevels
) $t]
2975 lappend exwin
(toplevels
) $t
2977 if {$dismiss == "yes"} {
2978 set f
[Widget_Frame
$t but Menubar
{top fill
}]
2979 Widget_AddBut
$f quit
"Dismiss" [list Exwin_Dismiss
$path]
2983 if {$state != "normal"} {
2985 wm geometry
$path $exwin(geometry
,$path)
2986 # Exmh_Debug Exwin_Toplevel $path $exwin(geometry,$path)
2996 proc Exwin_Dismiss
{ path
{geo ok
} } {
3000 set exwin
(geometry
,$path) [wm geometry
$path]
3003 set exwin
(geometry
,$path) [string trimleft
[wm geometry
$path] 0123456789x
]
3006 catch {unset exwin
(geometry
,$path)}
3012 proc Widget_Toplevel
{ path name
{class Dialog
} {x
{}} {y
{}} } {
3013 set self
[toplevel $path -class $class]
3014 set usergeo
[option get
$path position Position
]
3015 if {$usergeo != {}} {
3016 if {[catch {wm geometry
$self $usergeo} err
]} {
3017 # Exmh_Debug Widget_Toplevel $self $usergeo => $err
3020 if {($x != {}) && ($y != {})} {
3021 # Exmh_Debug Event position $self +$x+$y
3022 wm geometry
$self +$x+$y
3025 wm title
$self $name
3030 proc Widget_Frame
{par child
{class GDB
} {where
{top expand fill
}} args
} {
3034 set self
$par.
$child
3036 eval {frame $self -class $class} $args
3037 pack append $par $self $where
3041 proc Widget_AddBut
{par but txt cmd
{where
{right padx
1}} } {
3042 # Create a Packed button. Return the button pathname
3043 set cmd2
[list button $par.
$but -text $txt -command $cmd]
3044 if {[catch $cmd2 t
]} {
3045 puts stderr
"Widget_AddBut (warning) $t"
3046 eval $cmd2 {-font fixed
}
3048 pack append $par $par.
$but $where
3052 proc Widget_CheckBut
{par but txt var
{where
{right padx
1}} } {
3053 # Create a check button. Return the button pathname
3054 set cmd
[list checkbutton $par.
$but -text $txt -variable $var]
3055 if {[catch $cmd t
]} {
3056 puts stderr
"Widget_CheckBut (warning) $t"
3057 eval $cmd {-font fixed
}
3059 pack append $par $par.
$but $where
3063 proc Widget_Label
{ frame {name
label} {where
{left fill
}} args
} {
3064 set cmd
[list label $frame.
$name ]
3065 if {[catch [concat $cmd $args] t
]} {
3066 puts stderr
"Widget_Label (warning) $t"
3067 eval $cmd $args {-font fixed
}
3069 pack append $frame $frame.
$name $where
3073 proc Widget_Entry
{ frame {name
entry} {where
{left fill
}} args
} {
3074 set cmd
[list entry $frame.
$name ]
3075 if {[catch [concat $cmd $args] t
]} {
3076 puts stderr
"Widget_Entry (warning) $t"
3077 eval $cmd $args {-font fixed
}
3079 pack append $frame $frame.
$name $where
3083 # End of fileselect.tcl.
3086 # Create a copyright window and center it on the screen. Arrange for
3087 # it to disappear when the user clicks it, or after a suitable period
3090 proc create_copyright_window
{} {
3092 message .c.m
-text [gdb_cmd
{show version
}] -aspect 500 -relief raised
3095 bind .c.m
<1> {destroy .c
}
3096 bind .c
<Leave
> {destroy .c
}
3097 # "suitable period" currently means "15 seconds".
3099 if {[winfo exists .c
]} then
{
3108 # Begin support primarily for debugging the tcl/tk portion of gdbtk. You can
3109 # start gdbtk, and then issue the command "tk tclsh" and a window will pop up
3110 # giving you direct access to the tcl interpreter. With this, it is very easy
3111 # to examine the values of global variables, directly invoke routines that are
3112 # part of the gdbtk interface, replace existing proc's with new ones, etc.
3113 # This code was inspired from example 11-3 in Brent Welch's "Practical
3114 # Programming in Tcl and Tk"
3116 set tcl_prompt
"tcl> "
3118 # Get the current command that user has typed, from cmdstart to end of text
3119 # widget. Evaluate it, insert result back into text widget, issue a new
3120 # prompt, update text widget and update command start mark.
3122 proc evaluate_tcl_command
{ twidget
} {
3125 set command
[$twidget get cmdstart end
]
3126 if [info complete
$command] {
3127 set err
[catch {uplevel #0 $command} result]
3128 $twidget insert insert
\n$result\n
3129 $twidget insert insert
$tcl_prompt
3131 $twidget mark
set cmdstart insert
3136 # Create the evaluation window and set up the keybindings to evaluate the
3137 # last single line entered by the user. FIXME: allow multiple lines?
3142 # If another evaluation window already exists, just bring it to the front.
3143 if {[winfo exists .
eval]} {raise .
eval ; return}
3145 # Create top level frame with scrollbar and text widget.
3147 wm title .
eval "Tcl Evaluation"
3148 wm iconname .
eval "Tcl"
3149 text .
eval.
text -width 80 -height 20 -setgrid true
-cursor hand2
\
3150 -yscrollcommand {.
eval.scroll
set}
3151 scrollbar .
eval.scroll
-command {.
eval.
text yview
}
3152 pack .
eval.scroll
-side left
-fill y
3153 pack .
eval.
text -side right
-fill both
-expand true
3155 # Insert the tcl_prompt and initialize the cmdstart mark
3156 .
eval.
text insert insert
$tcl_prompt
3157 .
eval.
text mark
set cmdstart insert
3158 .
eval.
text mark gravity cmdstart left
3160 # Make this window the current one for input.
3163 # Keybindings that limit input and evaluate things
3164 bind .
eval.
text <Return
> { evaluate_tcl_command .
eval.
text ; break }
3165 bind .
eval.
text <Any-Key
> {
3166 if [%W compare insert
< cmdstart
] {
3167 %W mark
set insert end
3170 bindtags .
eval.
text {.
eval.
text Text all
}
3173 # This proc is executed just prior to falling into the Tk main event loop.
3174 proc gdbtk_tcl_preloop
{} {
3176 .cmd.
text insert end
"$gdb_prompt"
3181 # FIXME need to handle mono here. In Tk4 that is more complicated.
3182 set highlight
"-background red2 -borderwidth 2 -relief sunken"
3184 # Setup the initial windows
3185 create_source_window
3186 create_command_window
3188 # Make this last so user actually sees it.
3189 create_copyright_window
3193 if {[file exists ~
/.gdbtkinit
]} {