gdb/gdbtk.tcl

   1 # GDB GUI setup for GDB, the GNU debugger.
   2 # Copyright 1994, 1995
   3 # Free Software Foundation, Inc.
   4
   5 # Written by Stu Grossman <[email protected]> of Cygnus Support.
   6
   7 # This file is part of GDB.
   8
   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.
  13
  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.
  18
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program; if not, write to the Free Software
  21 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  22
  23 set cfile Blank
  24 set wins($cfile) .src.text
  25 set current_label {}
  26 set screen_height 0
  27 set screen_top 0
  28 set screen_bot 0
  29 set cfunc NIL
  30 set line_numbers 1
  31 set breakpoint_file(-1) {[garbage]}
  32 set disassemble_with_source nosource
  33 set expr_update_list(0) 0
  34
  35 #option add *Foreground Black
  36 #option add *Background White
  37 #option add *Font -*-*-medium-r-normal--18-*-*-*-m-*-*-1
  38 tk colormodel . monochrome
  39
  40 proc echo string {puts stdout $string}
  41
  42 if [info exists env(EDITOR)] then {
  43         set editor $env(EDITOR)
  44         } else {
  45         set editor emacs
  46 }
  47
  48 # GDB callbacks
  49 #
  50 #  These functions are called by GDB (from C code) to do various things in
  51 #  TK-land.  All start with the prefix `gdbtk_tcl_' to make them easy to find.
  52 #
  53
  54 #
  55 # GDB Callback:
  56 #
  57 #       gdbtk_tcl_fputs (text) - Output text to the command window
  58 #
  59 # Description:
  60 #
  61 #       GDB calls this to output TEXT to the GDB command window.  The text is
  62 #       placed at the end of the text widget.  Note that output may not occur,
  63 #       due to buffering.  Use gdbtk_tcl_flush to cause an immediate update.
  64 #
  65
  66 proc gdbtk_tcl_fputs {arg} {
  67         .cmd.text insert end "$arg"
  68         .cmd.text yview -pickplace end
  69 }
  70
  71 proc gdbtk_tcl_fputs_error {arg} {
  72         .cmd.text insert end "$arg"
  73         .cmd.text yview -pickplace end
  74 }
  75
  76 #
  77 # GDB Callback:
  78 #
  79 #       gdbtk_tcl_flush () - Flush output to the command window
  80 #
  81 # Description:
  82 #
  83 #       GDB calls this to force all buffered text to the GDB command window.
  84 #
  85
  86 proc gdbtk_tcl_flush {} {
  87         .cmd.text yview -pickplace end
  88         update idletasks
  89 }
  90
  91 #
  92 # GDB Callback:
  93 #
  94 #       gdbtk_tcl_query (message) - Create a yes/no query dialog box
  95 #
  96 # Description:
  97 #
  98 #       GDB calls this to create a yes/no dialog box containing MESSAGE.  GDB
  99 #       is hung while the dialog box is active (ie: no commands will work),
 100 #       however windows can still be refreshed in case of damage or exposure.
 101 #
 102
 103 proc gdbtk_tcl_query {message} {
 104         tk_dialog .query "gdb : query" "$message" {} 1 "No" "Yes"
 105         }
 106
 107 #
 108 # GDB Callback:
 109 #
 110 #       gdbtk_start_variable_annotation (args ...) -
 111 #
 112 # Description:
 113 #
 114 #       Not yet implemented.
 115 #
 116
 117 proc gdbtk_tcl_start_variable_annotation {valaddr ref_type stor_cl cum_expr field type_cast} {
 118         echo "gdbtk_tcl_start_variable_annotation $valaddr $ref_type $stor_cl $cum_expr $field $type_cast"
 119 }
 120
 121 #
 122 # GDB Callback:
 123 #
 124 #       gdbtk_end_variable_annotation (args ...) -
 125 #
 126 # Description:
 127 #
 128 #       Not yet implemented.
 129 #
 130
 131 proc gdbtk_tcl_end_variable_annotation {} {
 132         echo gdbtk_tcl_end_variable_annotation
 133 }
 134
 135 #
 136 # GDB Callback:
 137 #
 138 #       gdbtk_tcl_breakpoint (action bpnum file line) - Notify the TK
 139 #       interface of changes to breakpoints.
 140 #
 141 # Description:
 142 #
 143 #       GDB calls this to notify TK of changes to breakpoints.  ACTION is one
 144 #       of:
 145 #               create          - Notify of breakpoint creation
 146 #               delete          - Notify of breakpoint deletion
 147 #               modify          - Notify of breakpoint modification
 148 #
 149
 150 # file line pc type enabled disposition silent ignore_count commands cond_string thread hit_count
 151
 152 proc gdbtk_tcl_breakpoint {action bpnum} {
 153         set bpinfo [gdb_get_breakpoint_info $bpnum]
 154         set file [lindex $bpinfo 0]
 155         set line [lindex $bpinfo 1]
 156         set pc [lindex $bpinfo 2]
 157         set enable [lindex $bpinfo 4]
 158
 159         if {$action == "modify"} {
 160                 if {$enable == "enabled"} {
 161                         set action enable
 162                 } else {
 163                         set action disable
 164                 }
 165         }
 166
 167         ${action}_breakpoint $bpnum $file $line $pc
 168 }
 169
 170 proc create_breakpoints_window {} {
 171         global bpframe_lasty
 172
 173         if [winfo exists .breakpoints] {raise .breakpoints ; return}
 174
 175         build_framework .breakpoints "Breakpoints" ""
 176
 177 # First, delete all the old view menu entries
 178
 179         .breakpoints.menubar.view.menu delete 0 last
 180
 181 # Get rid of label
 182
 183         destroy .breakpoints.label
 184
 185 # Replace text with a canvas and fix the scrollbars
 186
 187         destroy .breakpoints.text
 188         canvas .breakpoints.c -relief sunken -bd 2 \
 189                 -cursor hand2 -yscrollcommand {.breakpoints.scroll set}
 190         .breakpoints.scroll configure -command {.breakpoints.c yview}
 191         scrollbar .breakpoints.scrollx -orient horizontal \
 192                 -command {.breakpoints.c xview} -relief sunken
 193
 194         pack .breakpoints.scrollx -side bottom -fill x -in .breakpoints.info
 195         pack .breakpoints.c -side left -expand yes -fill both \
 196                 -in .breakpoints.info
 197
 198         set bpframe_lasty 0
 199
 200 # Create a frame for each breakpoint
 201
 202         foreach bpnum [gdb_get_breakpoint_list] {
 203                 add_breakpoint_frame $bpnum
 204         }
 205 }
 206
 207 # Create a frame for bpnum in the .breakpoints canvas
 208
 209 proc add_breakpoint_frame bpnum {
 210         global bpframe_lasty
 211
 212         if ![winfo exists .breakpoints] return
 213
 214         set bpinfo [gdb_get_breakpoint_info $bpnum]
 215
 216         set file [lindex $bpinfo 0]
 217         set line [lindex $bpinfo 1]
 218         set pc [lindex $bpinfo 2]
 219         set type [lindex $bpinfo 3]
 220         set enabled [lindex $bpinfo 4]
 221         set disposition [lindex $bpinfo 5]
 222         set silent [lindex $bpinfo 6]
 223         set ignore_count [lindex $bpinfo 7]
 224         set commands [lindex $bpinfo 8]
 225         set cond [lindex $bpinfo 9]
 226         set thread [lindex $bpinfo 10]
 227         set hit_count [lindex $bpinfo 11]
 228
 229         set f .breakpoints.c.$bpnum
 230
 231         if ![winfo exists $f] {
 232                 frame $f -relief sunken -bd 2
 233
 234                 label $f.id -text "#$bpnum     $file:$line    ($pc)" \
 235                         -relief flat -bd 2 -anchor w
 236                 label $f.hit_count -text "Hit count: $hit_count" -relief flat \
 237                         -bd 2 -anchor w
 238
 239                 frame $f.thread
 240                 label $f.thread.label -text "Thread: " -relief flat -bd 2 \
 241                         -width 11 -anchor w
 242                 entry $f.thread.entry -bd 2 -relief sunken -width 10
 243                 $f.thread.entry insert end $thread
 244                 pack $f.thread.label -side left
 245                 pack $f.thread.entry -side left -fill x
 246
 247                 frame $f.cond
 248                 label $f.cond.label -text "Condition: " -relief flat -bd 2 \
 249                         -width 11 -anchor w
 250                 entry $f.cond.entry -bd 2 -relief sunken
 251                 $f.cond.entry insert end $cond
 252                 pack $f.cond.label -side left
 253                 pack $f.cond.entry -side left -fill x -expand yes
 254
 255                 frame $f.ignore_count
 256                 label $f.ignore_count.label -text "Ignore count: " \
 257                         -relief flat -bd 2 -width 11 -anchor w
 258                 entry $f.ignore_count.entry -bd 2 -relief sunken -width 10
 259                 $f.ignore_count.entry insert end $ignore_count
 260                 pack $f.ignore_count.label -side left
 261                 pack $f.ignore_count.entry -side left -fill x
 262
 263                 frame $f.disps
 264
 265                 checkbutton $f.disps.enabled -text "Enabled " \
 266                         -variable enabled -anchor w -relief flat
 267
 268                 radiobutton $f.disps.delete -text Delete \
 269                         -variable disposition -anchor w -relief flat
 270
 271                 radiobutton $f.disps.disable -text Disable \
 272                         -variable disposition -anchor w -relief flat
 273
 274                 radiobutton $f.disps.donttouch -text "Leave alone" \
 275                                  -variable disposition -anchor w -relief flat
 276
 277                 pack  $f.disps.delete $f.disps.disable $f.disps.donttouch \
 278                         -side left -anchor w
 279                 pack $f.disps.enabled -side right -anchor e
 280                 text $f.commands -relief sunken -bd 2 -setgrid true \
 281                         -cursor hand2 -height 3 -width 30
 282
 283                 foreach line $commands {
 284                                 $f.commands insert end "${line}\n"
 285                 }
 286
 287                 pack $f.id -side top -anchor nw -fill x
 288                 pack $f.hit_count $f.cond $f.thread $f.ignore_count $f.disps \
 289                                 $f.commands -side top -fill x -anchor nw
 290         }
 291
 292         set tag [.breakpoints.c create window 0 $bpframe_lasty -window $f -anchor nw]
 293         update
 294         set bbox [.breakpoints.c bbox $tag]
 295
 296         set bpframe_lasty [lindex $bbox 3]
 297 }
 298
 299 # Delete a breakpoint frame
 300
 301 proc delete_breakpoint_frame bpnum {
 302         global bpframe_lasty
 303
 304         if ![winfo exists .breakpoints] return
 305
 306 # First, clear the canvas
 307
 308         .breakpoints.c delete all
 309
 310 # Now, repopulate it with all but the doomed breakpoint
 311
 312         set bpframe_lasty 0
 313         foreach bp [gdb_get_breakpoint_list] {
 314                 if {$bp != $bpnum} {
 315                         add_breakpoint_frame $bp
 316                 }
 317         }
 318 }
 319
 320 proc asm_win_name {funcname} {
 321         if {$funcname == "*None*"} {return .asm.text}
 322
 323         regsub -all {\.} $funcname _ temp
 324
 325         return .asm.func_${temp}
 326 }
 327
 328 #
 329 # Local procedure:
 330 #
 331 #       create_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
 332 #
 333 # Description:
 334 #
 335 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
 336 #       land of breakpoint creation.  This consists of recording the file and
 337 #       line number in the breakpoint_file and breakpoint_line arrays.  Also,
 338 #       if there is already a window associated with FILE, it is updated with
 339 #       a breakpoint tag.
 340 #
 341
 342 proc create_breakpoint {bpnum file line pc} {
 343         global wins
 344         global breakpoint_file
 345         global breakpoint_line
 346         global pos_to_breakpoint
 347         global pos_to_bpcount
 348         global cfunc
 349         global pclist
 350
 351 # Record breakpoint locations
 352
 353         set breakpoint_file($bpnum) $file
 354         set breakpoint_line($bpnum) $line
 355         set pos_to_breakpoint($file:$line) $bpnum
 356         if ![info exists pos_to_bpcount($file:$line)] {
 357                 set pos_to_bpcount($file:$line) 0
 358         }
 359         incr pos_to_bpcount($file:$line)
 360         set pos_to_breakpoint($pc) $bpnum
 361         if ![info exists pos_to_bpcount($pc)] {
 362                 set pos_to_bpcount($pc) 0
 363         }
 364         incr pos_to_bpcount($pc)
 365
 366 # If there's a window for this file, update it
 367
 368         if [info exists wins($file)] {
 369                 insert_breakpoint_tag $wins($file) $line
 370         }
 371
 372 # If there's an assembly window, update that too
 373
 374         set win [asm_win_name $cfunc]
 375         if [winfo exists $win] {
 376                 insert_breakpoint_tag $win [pc_to_line $pclist($cfunc) $pc]
 377         }
 378
 379 # Update the breakpoints window
 380
 381         add_breakpoint_frame $bpnum
 382 }
 383
 384 #
 385 # Local procedure:
 386 #
 387 #       delete_breakpoint (bpnum file line pc) - Delete breakpoint info from TK land
 388 #
 389 # Description:
 390 #
 391 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
 392 #       land of breakpoint destruction.  This consists of removing the file and
 393 #       line number from the breakpoint_file and breakpoint_line arrays.  Also,
 394 #       if there is already a window associated with FILE, the tags are removed
 395 #       from it.
 396 #
 397
 398 proc delete_breakpoint {bpnum file line pc} {
 399         global wins
 400         global breakpoint_file
 401         global breakpoint_line
 402         global pos_to_breakpoint
 403         global pos_to_bpcount
 404         global cfunc pclist
 405
 406 # Save line number and file for later
 407
 408         set line $breakpoint_line($bpnum)
 409
 410         set file $breakpoint_file($bpnum)
 411
 412 # Reset breakpoint annotation info
 413
 414         if {$pos_to_bpcount($file:$line) > 0} {
 415                 decr pos_to_bpcount($file:$line)
 416
 417                 if {$pos_to_bpcount($file:$line) == 0} {
 418                         catch "unset pos_to_breakpoint($file:$line)"
 419
 420                         unset breakpoint_file($bpnum)
 421                         unset breakpoint_line($bpnum)
 422
 423 # If there's a window for this file, update it
 424
 425                         if [info exists wins($file)] {
 426                                 delete_breakpoint_tag $wins($file) $line
 427                         }
 428                 }
 429         }
 430
 431 # If there's an assembly window, update that too
 432
 433         if {$pos_to_bpcount($pc) > 0} {
 434                 decr pos_to_bpcount($pc)
 435
 436                 if {$pos_to_bpcount($pc) == 0} {
 437                         catch "unset pos_to_breakpoint($pc)"
 438
 439                         set win [asm_win_name $cfunc]
 440                         if [winfo exists $win] {
 441                                 delete_breakpoint_tag $win [pc_to_line $pclist($cfunc) $pc]
 442                         }
 443                 }
 444         }
 445
 446         delete_breakpoint_frame $bpnum
 447 }
 448
 449 #
 450 # Local procedure:
 451 #
 452 #       enable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
 453 #
 454 # Description:
 455 #
 456 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
 457 #       land of a breakpoint being enabled.  This consists of unstippling the
 458 #       specified breakpoint indicator.
 459 #
 460
 461 proc enable_breakpoint {bpnum file line pc} {
 462         global wins
 463         global cfunc pclist
 464
 465         if [info exists wins($file)] {
 466                 $wins($file) tag configure $line -fgstipple {}
 467         }
 468
 469 # If there's an assembly window, update that too
 470
 471         set win [asm_win_name $cfunc]
 472         if [winfo exists $win] {
 473                 $win tag configure [pc_to_line $pclist($cfunc) $pc] -fgstipple {}
 474         }
 475 }
 476
 477 #
 478 # Local procedure:
 479 #
 480 #       disable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
 481 #
 482 # Description:
 483 #
 484 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
 485 #       land of a breakpoint being disabled.  This consists of stippling the
 486 #       specified breakpoint indicator.
 487 #
 488
 489 proc disable_breakpoint {bpnum file line pc} {
 490         global wins
 491         global cfunc pclist
 492
 493         if [info exists wins($file)] {
 494                 $wins($file) tag configure $line -fgstipple gray50
 495         }
 496
 497 # If there's an assembly window, update that too
 498
 499         set win [asm_win_name $cfunc]
 500         if [winfo exists $win] {
 501                 $win tag configure [pc_to_line $pclist($cfunc) $pc] -fgstipple gray50
 502         }
 503 }
 504
 505 #
 506 # Local procedure:
 507 #
 508 #       insert_breakpoint_tag (win line) - Insert a breakpoint tag in WIN.
 509 #
 510 # Description:
 511 #
 512 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to insert a
 513 #       breakpoint tag into window WIN at line LINE.
 514 #
 515
 516 proc insert_breakpoint_tag {win line} {
 517         $win configure -state normal
 518         $win delete $line.0
 519         $win insert $line.0 "B"
 520         $win tag add $line $line.0
 521         $win tag add delete $line.0 "$line.0 lineend"
 522         $win tag add margin $line.0 "$line.0 lineend"
 523
 524         $win configure -state disabled
 525 }
 526
 527 #
 528 # Local procedure:
 529 #
 530 #       delete_breakpoint_tag (win line) - Remove a breakpoint tag from WIN.
 531 #
 532 # Description:
 533 #
 534 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to remove a
 535 #       breakpoint tag from window WIN at line LINE.
 536 #
 537
 538 proc delete_breakpoint_tag {win line} {
 539         $win configure -state normal
 540         $win delete $line.0
 541         if {[string range $win 0 3] == ".src"} then {
 542                 $win insert $line.0 "\xa4"
 543         } else {
 544                 $win insert $line.0 " "
 545         }
 546         $win tag delete $line
 547         $win tag add delete $line.0 "$line.0 lineend"
 548         $win tag add margin $line.0 "$line.0 lineend"
 549         $win configure -state disabled
 550 }
 551
 552 proc gdbtk_tcl_busy {} {
 553         if [winfo exists .src] {
 554                 .src.start configure -state disabled
 555                 .src.stop configure -state normal
 556                 .src.step configure -state disabled
 557                 .src.next configure -state disabled
 558                 .src.continue configure -state disabled
 559                 .src.finish configure -state disabled
 560                 .src.up configure -state disabled
 561                 .src.down configure -state disabled
 562                 .src.bottom configure -state disabled
 563         }
 564         if [winfo exists .asm] {
 565                 .asm.stepi configure -state disabled
 566                 .asm.nexti configure -state disabled
 567                 .asm.continue configure -state disabled
 568                 .asm.finish configure -state disabled
 569                 .asm.up configure -state disabled
 570                 .asm.down configure -state disabled
 571                 .asm.bottom configure -state disabled
 572         }
 573         return
 574 }
 575
 576 proc gdbtk_tcl_idle {} {
 577         if [winfo exists .src] {
 578                 .src.start configure -state normal
 579                 .src.stop configure -state disabled
 580                 .src.step configure -state normal
 581                 .src.next configure -state normal
 582                 .src.continue configure -state normal
 583                 .src.finish configure -state normal
 584                 .src.up configure -state normal
 585                 .src.down configure -state normal
 586                 .src.bottom configure -state normal
 587         }
 588
 589         if [winfo exists .asm] {
 590                 .asm.stepi configure -state normal
 591                 .asm.nexti configure -state normal
 592                 .asm.continue configure -state normal
 593                 .asm.finish configure -state normal
 594                 .asm.up configure -state normal
 595                 .asm.down configure -state normal
 596                 .asm.bottom configure -state normal
 597         }
 598         return
 599 }
 600
 601 #
 602 # Local procedure:
 603 #
 604 #       decr (var val) - compliment to incr
 605 #
 606 # Description:
 607 #
 608 #
 609 proc decr {var {val 1}} {
 610         upvar $var num
 611         set num [expr $num - $val]
 612         return $num
 613 }
 614
 615 #
 616 # Local procedure:
 617 #
 618 #       pc_to_line (pclist pc) - convert PC to a line number.
 619 #
 620 # Description:
 621 #
 622 #       Convert PC to a line number from PCLIST.  If exact line isn't found,
 623 #       we return the first line that starts before PC.
 624 #
 625 proc pc_to_line {pclist pc} {
 626         set line [lsearch -exact $pclist $pc]
 627
 628         if {$line >= 1} { return $line }
 629
 630         set line 1
 631         foreach linepc [lrange $pclist 1 end] {
 632                 if {$pc < $linepc} { decr line ; return $line }
 633                 incr line
 634         }
 635         return [expr $line - 1]
 636 }
 637
 638 #
 639 # Menu:
 640 #
 641 #       file popup menu - Define the file popup menu.
 642 #
 643 # Description:
 644 #
 645 #       This menu just contains a bunch of buttons that do various things to
 646 #       the line under the cursor.
 647 #
 648 # Items:
 649 #
 650 #       Edit - Run the editor (specified by the environment variable EDITOR) on
 651 #              this file, at the current line.
 652 #       Breakpoint - Set a breakpoint at the current line.  This just shoves
 653 #               a `break' command at GDB with the appropriate file and line
 654 #               number.  Eventually, GDB calls us back (at gdbtk_tcl_breakpoint)
 655 #               to notify us of where the breakpoint needs to show up.
 656 #
 657
 658 menu .file_popup -cursor hand2
 659 .file_popup add command -label "Not yet set" -state disabled
 660 .file_popup add separator
 661 .file_popup add command -label "Edit" -command {exec $editor +$selected_line $selected_file &}
 662 .file_popup add command -label "Set breakpoint" -command {gdb_cmd "break $selected_file:$selected_line"}
 663
 664 # Use this procedure to get the GDB core to execute the string `cmd'.  This is
 665 # a wrapper around gdb_cmd, which will catch errors, and send output to the
 666 # command window.  It will also cause all of the other windows to be updated.
 667
 668 proc interactive_cmd {cmd} {
 669         catch {gdb_cmd "$cmd"} result
 670         .cmd.text insert end $result
 671         .cmd.text yview -pickplace end
 672         update_ptr
 673 }
 674
 675 #
 676 # Bindings:
 677 #
 678 #       file popup menu - Define the file popup menu bindings.
 679 #
 680 # Description:
 681 #
 682 #       This defines the binding for the file popup menu.  Currently, there is
 683 #       only one, which is activated when Button-1 is released.  This causes
 684 #       the menu to be unposted, releases the grab for the menu, and then
 685 #       unhighlights the line under the cursor.  After that, the selected menu
 686 #       item is invoked.
 687 #
 688
 689 bind .file_popup <Any-ButtonRelease-1> {
 690         global selected_win
 691
 692 # First, remove the menu, and release the pointer
 693
 694         .file_popup unpost
 695         grab release .file_popup
 696
 697 # Unhighlight the selected line
 698
 699         $selected_win tag delete breaktag
 700
 701 # Actually invoke the menubutton here!
 702
 703         tk_invokeMenu %W
 704 }
 705
 706 #
 707 # Local procedure:
 708 #
 709 #       file_popup_menu (win x y xrel yrel) - Popup the file popup menu.
 710 #
 711 # Description:
 712 #
 713 #       This procedure is invoked as a result of a command binding in the
 714 #       listing window.  It does several things:
 715 #               o - It highlights the line under the cursor.
 716 #               o - It pops up the file popup menu which is intended to do
 717 #                   various things to the aforementioned line.
 718 #               o - Grabs the mouse for the file popup menu.
 719 #
 720
 721 # Button 1 has been pressed in a listing window.  Pop up a menu.
 722
 723 proc file_popup_menu {win x y xrel yrel} {
 724         global wins
 725         global win_to_file
 726         global file_to_debug_file
 727         global highlight
 728         global selected_line
 729         global selected_file
 730         global selected_win
 731
 732 # Map TK window name back to file name.
 733
 734         set file $win_to_file($win)
 735
 736         set pos [$win index @$xrel,$yrel]
 737
 738 # Record selected file and line for menu button actions
 739
 740         set selected_file $file_to_debug_file($file)
 741         set selected_line [lindex [split $pos .] 0]
 742         set selected_win $win
 743
 744 # Highlight the selected line
 745
 746         eval $win tag config breaktag $highlight
 747         $win tag add breaktag "$pos linestart" "$pos linestart + 1l"
 748
 749 # Post the menu near the pointer, (and grab it)
 750
 751         .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
 752         .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
 753         grab .file_popup
 754 }
 755
 756 #
 757 # Local procedure:
 758 #
 759 #       listing_window_button_1 (win x y xrel yrel) - Handle button 1 in listing window
 760 #
 761 # Description:
 762 #
 763 #       This procedure is invoked as a result of holding down button 1 in the
 764 #       listing window.  The action taken depends upon where the button was
 765 #       pressed.  If it was in the left margin (the breakpoint column), it
 766 #       sets or clears a breakpoint.  In the main text area, it will pop up a
 767 #       menu.
 768 #
 769
 770 proc listing_window_button_1 {win x y xrel yrel} {
 771         global wins
 772         global win_to_file
 773         global file_to_debug_file
 774         global highlight
 775         global selected_line
 776         global selected_file
 777         global selected_win
 778         global pos_to_breakpoint
 779
 780 # Map TK window name back to file name.
 781
 782         set file $win_to_file($win)
 783
 784         set pos [split [$win index @$xrel,$yrel] .]
 785
 786 # Record selected file and line for menu button actions
 787
 788         set selected_file $file_to_debug_file($file)
 789         set selected_line [lindex $pos 0]
 790         set selected_col [lindex $pos 1]
 791         set selected_win $win
 792
 793 # If we're in the margin, then toggle the breakpoint
 794
 795         if {$selected_col < 8} {
 796                 set pos_break $selected_file:$selected_line
 797                 set pos $file:$selected_line
 798                 set tmp pos_to_breakpoint($pos)
 799                 if [info exists $tmp] {
 800                         set bpnum [set $tmp]
 801                         gdb_cmd "delete $bpnum"
 802                 } else {
 803                         gdb_cmd "break $pos_break"
 804                 }
 805                 return
 806         }
 807
 808 # Post the menu near the pointer, (and grab it)
 809
 810         .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
 811         .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
 812         grab .file_popup
 813 }
 814
 815 #
 816 # Local procedure:
 817 #
 818 #       asm_window_button_1 (win x y xrel yrel) - Handle button 1 in asm window
 819 #
 820 # Description:
 821 #
 822 #       This procedure is invoked as a result of holding down button 1 in the
 823 #       assembly window.  The action taken depends upon where the button was
 824 #       pressed.  If it was in the left margin (the breakpoint column), it
 825 #       sets or clears a breakpoint.  In the main text area, it will pop up a
 826 #       menu.
 827 #
 828
 829 proc asm_window_button_1 {win x y xrel yrel} {
 830         global wins
 831         global win_to_file
 832         global file_to_debug_file
 833         global highlight
 834         global selected_line
 835         global selected_file
 836         global selected_win
 837         global pos_to_breakpoint
 838         global pclist
 839         global cfunc
 840
 841         set pos [split [$win index @$xrel,$yrel] .]
 842
 843 # Record selected file and line for menu button actions
 844
 845         set selected_line [lindex $pos 0]
 846         set selected_col [lindex $pos 1]
 847         set selected_win $win
 848
 849 # Figure out the PC
 850
 851         set pc [lindex $pclist($cfunc) $selected_line]
 852
 853 # If we're in the margin, then toggle the breakpoint
 854
 855         if {$selected_col < 11} {
 856                 set tmp pos_to_breakpoint($pc)
 857                 if [info exists $tmp] {
 858                         set bpnum [set $tmp]
 859                         gdb_cmd "delete $bpnum"
 860                 } else {
 861                         gdb_cmd "break *$pc"
 862                 }
 863                 return
 864         }
 865
 866 # Post the menu near the pointer, (and grab it)
 867
 868 #       .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
 869 #       .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
 870 #       grab .file_popup
 871 }
 872
 873 #
 874 # Local procedure:
 875 #
 876 #       do_nothing - Does absolutely nothing.
 877 #
 878 # Description:
 879 #
 880 #       This procedure does nothing.  It is used as a placeholder to allow
 881 #       the disabling of bindings that would normally be inherited from the
 882 #       parent widget.  I can't think of any other way to do this.
 883 #
 884
 885 proc do_nothing {} {}
 886
 887 #
 888 # Local procedure:
 889 #
 890 #       not_implemented_yet - warn that a feature is unavailable
 891 #
 892 # Description:
 893 #
 894 #       This procedure warns that something doesn't actually work yet.
 895 #
 896
 897 proc not_implemented_yet {message} {
 898         tk_dialog .unimpl "gdb : unimpl" \
 899                 "$message: not implemented in the interface yet" \
 900                 {} 1 "OK"
 901 }
 902
 903 ##
 904 # Local procedure:
 905 #
 906 #       create_expr_window - Create expression display window
 907 #
 908 # Description:
 909 #
 910 #       Create the expression display window.
 911 #
 912
 913 set expr_num 0
 914
 915 proc add_expr {expr} {
 916         global expr_update_list
 917         global expr_num
 918
 919         incr expr_num
 920
 921         set e .expr.e${expr_num}
 922
 923         frame $e
 924
 925         checkbutton $e.update -text "      " -relief flat \
 926                 -variable expr_update_list($expr_num)
 927         text $e.expr -width 20 -height 1
 928         $e.expr insert 0.0 $expr
 929         bind $e.expr <1> "update_expr $expr_num"
 930         text $e.val -width 20 -height 1
 931
 932         update_expr $expr_num
 933
 934         pack $e.update -side left -anchor nw
 935         pack $e.expr $e.val -side left -expand yes -fill x
 936
 937         pack $e -side top -fill x -anchor w
 938 }
 939
 940 set delete_expr_flag 0
 941
 942 # This is a krock!!!
 943
 944 proc delete_expr {} {
 945         global delete_expr_flag
 946
 947         if {$delete_expr_flag == 1} {
 948                 set delete_expr_flag 0
 949                 tk_butUp .expr.delete
 950                 bind .expr.delete <Any-Leave> {}
 951         } else {
 952                 set delete_expr_flag 1
 953                 bind .expr.delete <Any-Leave> do_nothing
 954                 tk_butDown .expr.delete
 955         }
 956 }
 957
 958 proc update_expr {expr_num} {
 959         global delete_expr_flag
 960         global expr_update_list
 961
 962         set e .expr.e${expr_num}
 963
 964         if {$delete_expr_flag == 1} {
 965                 set delete_expr_flag 0
 966                 destroy $e
 967                 tk_butUp .expr.delete
 968                 tk_butLeave .expr.delete
 969                 bind .expr.delete <Any-Leave> {}
 970                 unset expr_update_list($expr_num)
 971                 return
 972         }
 973
 974         set expr [$e.expr get 0.0 end]
 975
 976         $e.val delete 0.0 end
 977         if [catch "gdb_eval $expr" val] {
 978
 979         } else {
 980                 $e.val insert 0.0 $val
 981         }
 982 }
 983
 984 proc update_exprs {} {
 985         global expr_update_list
 986
 987         foreach expr_num [array names expr_update_list] {
 988                 if $expr_update_list($expr_num) {
 989                         update_expr $expr_num
 990                 }
 991         }
 992 }
 993
 994 proc create_expr_window {} {
 995
 996         if [winfo exists .expr] {raise .expr ; return}
 997
 998         toplevel .expr
 999         wm minsize .expr 1 1
1000         wm title .expr Expression
1001         wm iconname .expr "Reg config"
1002
1003         frame .expr.entryframe
1004
1005         entry .expr.entry -borderwidth 2 -relief sunken
1006         bind .expr <Enter> {focus .expr.entry}
1007         bind .expr.entry <Key-Return> {add_expr [.expr.entry get]
1008                                         .expr.entry delete 0 end }
1009
1010         label .expr.entrylab -text "Expression: "
1011
1012         pack .expr.entrylab -in .expr.entryframe -side left
1013         pack .expr.entry -in .expr.entryframe -side left -fill x -expand yes
1014
1015         frame .expr.buts
1016
1017         button .expr.delete -text Delete
1018         bind .expr.delete <1> delete_expr
1019
1020         button .expr.close -text Close -command {destroy .expr}
1021
1022         pack .expr.delete -side left -fill x -expand yes -in .expr.buts
1023         pack .expr.close -side right -fill x -expand yes -in .expr.buts
1024
1025         pack .expr.buts -side bottom -fill x
1026         pack .expr.entryframe -side bottom -fill x
1027
1028         frame .expr.labels
1029
1030         label .expr.updlab -text Update
1031         label .expr.exprlab -text Expression
1032         label .expr.vallab -text Value
1033
1034         pack .expr.updlab -side left -in .expr.labels
1035         pack .expr.exprlab .expr.vallab -side left -in .expr.labels -expand yes -anchor w
1036
1037         pack .expr.labels -side top -fill x -anchor w
1038 }
1039
1040 #
1041 # Local procedure:
1042 #
1043 #       display_expression (expression) - Display EXPRESSION in display window
1044 #
1045 # Description:
1046 #
1047 #       Display EXPRESSION and its value in the expression display window.
1048 #
1049
1050 proc display_expression {expression} {
1051         create_expr_window
1052
1053         add_expr $expression
1054 }
1055
1056 #
1057 # Local procedure:
1058 #
1059 #       create_file_win (filename) - Create a win for FILENAME.
1060 #
1061 # Return value:
1062 #
1063 #       The new text widget.
1064 #
1065 # Description:
1066 #
1067 #       This procedure creates a text widget for FILENAME.  It returns the
1068 #       newly created widget.  First, a text widget is created, and given basic
1069 #       configuration info.  Second, all the bindings are setup.  Third, the
1070 #       file FILENAME is read into the text widget.  Fourth, margins and line
1071 #       numbers are added.
1072 #
1073
1074 proc create_file_win {filename debug_file} {
1075         global breakpoint_file
1076         global breakpoint_line
1077         global line_numbers
1078
1079 # Replace all the dirty characters in $filename with clean ones, and generate
1080 # a unique name for the text widget.
1081
1082         regsub -all {\.} $filename {} temp
1083         set win .src.text$temp
1084
1085 # Open the file, and read it into the text widget
1086
1087         if [catch "open $filename" fh] {
1088 # File can't be read.  Put error message into .src.nofile window and return.
1089
1090                 catch {destroy .src.nofile}
1091                 text .src.nofile -height 25 -width 88 -relief sunken \
1092                         -borderwidth 2 -yscrollcommand textscrollproc \
1093                         -setgrid true -cursor hand2
1094                 .src.nofile insert 0.0 $fh
1095                 .src.nofile configure -state disabled
1096                 bind .src.nofile <1> do_nothing
1097                 bind .src.nofile <B1-Motion> do_nothing
1098                 return .src.nofile
1099         }
1100
1101 # Actually create and do basic configuration on the text widget.
1102
1103         text $win -height 25 -width 88 -relief sunken -borderwidth 2 \
1104                 -yscrollcommand textscrollproc -setgrid true -cursor hand2
1105
1106 # Setup all the bindings
1107
1108         bind $win <Enter> {focus %W}
1109         bind $win <1> do_nothing
1110         bind $win <B1-Motion> do_nothing
1111
1112         bind $win n {interactive_cmd next}
1113         bind $win s {interactive_cmd step}
1114         bind $win c {interactive_cmd continue}
1115         bind $win f {interactive_cmd finish}
1116         bind $win u {interactive_cmd up}
1117         bind $win d {interactive_cmd down}
1118
1119         $win delete 0.0 end
1120         $win insert 0.0 [read $fh]
1121         close $fh
1122
1123 # Add margins (for annotations) and a line number to each line (if requested)
1124
1125         set numlines [$win index end]
1126         set numlines [lindex [split $numlines .] 0]
1127         if $line_numbers {
1128                 for {set i 1} {$i <= $numlines} {incr i} {
1129                         $win insert $i.0 [format "   %4d " $i]
1130                         $win tag add source $i.8 "$i.0 lineend"
1131                         }
1132         } else {
1133                 for {set i 1} {$i <= $numlines} {incr i} {
1134                         $win insert $i.0 "        "
1135                         $win tag add source $i.8 "$i.0 lineend"
1136                         }
1137         }
1138
1139 # Add the breakdots
1140
1141         foreach i [gdb_sourcelines $debug_file] {
1142                 $win delete $i.0
1143                 $win insert $i.0 "\xa4"
1144                 $win tag add margin $i.0 $i.8
1145                 }
1146
1147         $win tag bind margin <1> {listing_window_button_1 %W %X %Y %x %y}
1148         $win tag bind source <1> {
1149                 %W mark set anchor "@%x,%y wordstart"
1150                 set last [%W index "@%x,%y wordend"]
1151                 %W tag remove sel 0.0 anchor
1152                 %W tag remove sel $last end
1153                 %W tag add sel anchor $last
1154                 }
1155 #       $win tag bind source <Double-Button-1> {
1156 #               %W mark set anchor "@%x,%y wordstart"
1157 #               set last [%W index "@%x,%y wordend"]
1158 #               %W tag remove sel 0.0 anchor
1159 #               %W tag remove sel $last end
1160 #               %W tag add sel anchor $last
1161 #               echo "Selected [selection get]"
1162 #               }
1163         $win tag bind source <B1-Motion> {
1164                 %W tag remove sel 0.0 anchor
1165                 %W tag remove sel $last end
1166                 %W tag add sel anchor @%x,%y
1167                 }
1168         $win tag bind sel <1> do_nothing
1169         $win tag bind sel <Double-Button-1> {display_expression [selection get]}
1170         $win tag raise sel
1171
1172
1173 # Scan though the breakpoint data base and install any destined for this file
1174
1175         foreach bpnum [array names breakpoint_file] {
1176                 if {$breakpoint_file($bpnum) == $filename} {
1177                         insert_breakpoint_tag $win $breakpoint_line($bpnum)
1178                         }
1179                 }
1180
1181 # Disable the text widget to prevent user modifications
1182
1183         $win configure -state disabled
1184         return $win
1185 }
1186
1187 #
1188 # Local procedure:
1189 #
1190 #       create_asm_win (funcname pc) - Create an assembly win for FUNCNAME.
1191 #
1192 # Return value:
1193 #
1194 #       The new text widget.
1195 #
1196 # Description:
1197 #
1198 #       This procedure creates a text widget for FUNCNAME.  It returns the
1199 #       newly created widget.  First, a text widget is created, and given basic
1200 #       configuration info.  Second, all the bindings are setup.  Third, the
1201 #       function FUNCNAME is read into the text widget.
1202 #
1203
1204 proc create_asm_win {funcname pc} {
1205         global breakpoint_file
1206         global breakpoint_line
1207         global pclist
1208         global disassemble_with_source
1209
1210 # Replace all the dirty characters in $filename with clean ones, and generate
1211 # a unique name for the text widget.
1212
1213         set win [asm_win_name $funcname]
1214
1215 # Actually create and do basic configuration on the text widget.
1216
1217         text $win -height 25 -width 80 -relief sunken -borderwidth 2 \
1218                 -setgrid true -cursor hand2 -yscrollcommand asmscrollproc
1219
1220 # Setup all the bindings
1221
1222         bind $win <Enter> {focus %W}
1223         bind $win <1> {asm_window_button_1 %W %X %Y %x %y}
1224         bind $win <B1-Motion> do_nothing
1225         bind $win n {interactive_cmd nexti}
1226         bind $win s {interactive_cmd stepi}
1227         bind $win c {interactive_cmd continue}
1228         bind $win f {interactive_cmd finish}
1229         bind $win u {interactive_cmd up}
1230         bind $win d {interactive_cmd down}
1231
1232 # Disassemble the code, and read it into the new text widget
1233
1234         $win insert end [gdb_disassemble $disassemble_with_source $pc]
1235
1236         set numlines [$win index end]
1237         set numlines [lindex [split $numlines .] 0]
1238         decr numlines
1239
1240 # Delete the first and last lines, cuz these contain useless info
1241
1242 #       $win delete 1.0 2.0
1243 #       $win delete {end - 1 lines} end
1244 #       decr numlines 2
1245
1246 # Add margins (for annotations) and note the PC for each line
1247
1248         catch "unset pclist($funcname)"
1249         lappend pclist($funcname) Unused
1250         for {set i 1} {$i <= $numlines} {incr i} {
1251                 scan [$win get $i.0 "$i.0 lineend"] "%s " pc
1252                 lappend pclist($funcname) $pc
1253                 $win insert $i.0 "    "
1254                 }
1255
1256 # Scan though the breakpoint data base and install any destined for this file
1257
1258 #       foreach bpnum [array names breakpoint_file] {
1259 #               if {$breakpoint_file($bpnum) == $filename} {
1260 #                       insert_breakpoint_tag $win $breakpoint_line($bpnum)
1261 #                       }
1262 #               }
1263
1264 # Disable the text widget to prevent user modifications
1265
1266         $win configure -state disabled
1267         return $win
1268 }
1269
1270 #
1271 # Local procedure:
1272 #
1273 #       asmscrollproc (WINHEIGHT SCREENHEIGHT SCREENTOP SCREENBOT) - Update the
1274 #       asm window scrollbar.
1275 #
1276 # Description:
1277 #
1278 #       This procedure is called to update the assembler window's scrollbar.
1279 #
1280
1281 proc asmscrollproc {args} {
1282         global asm_screen_height asm_screen_top asm_screen_bot
1283
1284         eval ".asm.scroll set $args"
1285         set asm_screen_height [lindex $args 1]
1286         set asm_screen_top [lindex $args 2]
1287         set asm_screen_bot [lindex $args 3]
1288 }
1289
1290 #
1291 # Local procedure:
1292 #
1293 #       update_listing (linespec) - Update the listing window according to
1294 #                                   LINESPEC.
1295 #
1296 # Description:
1297 #
1298 #       This procedure is called from various places to update the listing
1299 #       window based on LINESPEC.  It is usually invoked with the result of
1300 #       gdb_loc.
1301 #
1302 #       It will move the cursor, and scroll the text widget if necessary.
1303 #       Also, it will switch to another text widget if necessary, and update
1304 #       the label widget too.
1305 #
1306 #       LINESPEC is a list of the form:
1307 #
1308 #       { DEBUG_FILE FUNCNAME FILENAME LINE }, where:
1309 #
1310 #       DEBUG_FILE - is the abbreviated form of the file name.  This is usually
1311 #                    the file name string given to the cc command.  This is
1312 #                    primarily needed for breakpoint commands, and when an
1313 #                    abbreviated for of the filename is desired.
1314 #       FUNCNAME - is the name of the function.
1315 #       FILENAME - is the fully qualified (absolute) file name.  It is usually
1316 #                  the same as $PWD/$DEBUG_FILE, where PWD is the working dir
1317 #                  at the time the cc command was given.  This is used to
1318 #                  actually locate the file to be displayed.
1319 #       LINE - The line number to be displayed.
1320 #
1321 #       Usually, this procedure will just move the cursor one line down to the
1322 #       next line to be executed.  However, if the cursor moves out of range
1323 #       or into another file, it will scroll the text widget so that the line
1324 #       of interest is in the middle of the viewable portion of the widget.
1325 #
1326
1327 proc update_listing {linespec} {
1328         global pointers
1329         global screen_height
1330         global screen_top
1331         global screen_bot
1332         global wins cfile
1333         global current_label
1334         global win_to_file
1335         global file_to_debug_file
1336         global .src.label
1337
1338 # Rip the linespec apart
1339
1340         set line [lindex $linespec 3]
1341         set filename [lindex $linespec 2]
1342         set funcname [lindex $linespec 1]
1343         set debug_file [lindex $linespec 0]
1344
1345 # Sometimes there's no source file for this location
1346
1347         if {$filename == ""} {set filename Blank}
1348
1349 # If we want to switch files, we need to unpack the current text widget, and
1350 # stick in the new one.
1351
1352         if {$filename != $cfile} then {
1353                 pack forget $wins($cfile)
1354                 set cfile $filename
1355
1356 # Create a text widget for this file if necessary
1357
1358                 if ![info exists wins($cfile)] then {
1359                         set wins($cfile) [create_file_win $cfile $debug_file]
1360                         if {$wins($cfile) != ".src.nofile"} {
1361                                 set win_to_file($wins($cfile)) $cfile
1362                                 set file_to_debug_file($cfile) $debug_file
1363                                 set pointers($cfile) 1.1
1364                                 }
1365                         }
1366
1367 # Pack the text widget into the listing widget, and scroll to the right place
1368
1369                 pack $wins($cfile) -side left -expand yes -in .src.info \
1370                         -fill both -after .src.scroll
1371
1372 # Make the scrollbar point at the new text widget
1373
1374                 .src.scroll configure -command "$wins($cfile) yview"
1375
1376                 $wins($cfile) yview [expr $line - $screen_height / 2]
1377                 }
1378
1379 # Update the label widget in case the filename or function name has changed
1380
1381         if {$current_label != "$filename.$funcname"} then {
1382                 set tail [expr [string last / $filename] + 1]
1383                 set .src.label "[string range $filename $tail end] : ${funcname}()"
1384 #               .src.label configure -text "[string range $filename $tail end] : ${funcname}()"
1385                 set current_label $filename.$funcname
1386                 }
1387
1388 # Update the pointer, scrolling the text widget if necessary to keep the
1389 # pointer in an acceptable part of the screen.
1390
1391         if [info exists pointers($cfile)] then {
1392                 $wins($cfile) configure -state normal
1393                 set pointer_pos $pointers($cfile)
1394                 $wins($cfile) configure -state normal
1395                 $wins($cfile) delete $pointer_pos "$pointer_pos + 2 char"
1396                 $wins($cfile) insert $pointer_pos "  "
1397
1398                 set pointer_pos [$wins($cfile) index $line.1]
1399                 set pointers($cfile) $pointer_pos
1400
1401                 $wins($cfile) delete $pointer_pos "$pointer_pos + 2 char"
1402                 $wins($cfile) insert $pointer_pos "->"
1403
1404                 if {$line < $screen_top + 1
1405                     || $line > $screen_bot} then {
1406                         $wins($cfile) yview [expr $line - $screen_height / 2]
1407                         }
1408
1409                 $wins($cfile) configure -state disabled
1410                 }
1411 }
1412
1413 #
1414 # Local procedure:
1415 #
1416 #       create_asm_window - Open up the assembly window.
1417 #
1418 # Description:
1419 #
1420 #       Create an assembly window if it doesn't exist.
1421 #
1422
1423 proc create_asm_window {} {
1424         global cfunc
1425
1426         if [winfo exists .asm] {raise .asm ; return}
1427
1428         set cfunc *None*
1429         set win [asm_win_name $cfunc]
1430
1431         build_framework .asm Assembly "*NIL*"
1432
1433 # First, delete all the old menu entries
1434
1435         .asm.menubar.view.menu delete 0 last
1436
1437         .asm.text configure -yscrollcommand asmscrollproc
1438
1439         frame .asm.row1
1440         frame .asm.row2
1441
1442         button .asm.stepi -width 6 -text Stepi \
1443                 -command {interactive_cmd stepi}
1444         button .asm.nexti -width 6 -text Nexti \
1445                 -command {interactive_cmd nexti}
1446         button .asm.continue -width 6 -text Cont \
1447                 -command {interactive_cmd continue}
1448         button .asm.finish -width 6 -text Finish \
1449                 -command {interactive_cmd finish}
1450         button .asm.up -width 6 -text Up -command {interactive_cmd up}
1451         button .asm.down -width 6 -text Down \
1452                 -command {interactive_cmd down}
1453         button .asm.bottom -width 6 -text Bottom \
1454                 -command {interactive_cmd {frame 0}}
1455
1456         pack .asm.stepi .asm.continue .asm.up .asm.bottom -side left -padx 3 -pady 5 -in .asm.row1
1457         pack .asm.nexti .asm.finish .asm.down -side left -padx 3 -pady 5 -in .asm.row2
1458
1459         pack .asm.row2 .asm.row1 -side bottom -anchor w -before .asm.info
1460
1461         update
1462
1463         update_assembly [gdb_loc]
1464
1465 # We do this update_assembly to get the proper value of disassemble-from-exec.
1466
1467 # exec file menu item
1468         .asm.menubar.view.menu add radiobutton -label "Exec file" \
1469                 -variable disassemble-from-exec -value 1
1470 # target memory menu item
1471         .asm.menubar.view.menu add radiobutton -label "Target memory" \
1472                 -variable disassemble-from-exec -value 0
1473
1474 # Disassemble with source
1475         .asm.menubar.view.menu add checkbutton -label "Source" \
1476                 -variable disassemble_with_source -onvalue source \
1477                 -offvalue nosource -command {
1478                         foreach asm [info command .asm.func_*] {
1479                                 destroy $asm
1480                                 }
1481                         set cfunc NIL
1482                         update_assembly [gdb_loc]
1483                 }
1484 }
1485
1486 proc reg_config_menu {} {
1487         catch {destroy .reg.config}
1488         toplevel .reg.config
1489         wm geometry .reg.config +300+300
1490         wm title .reg.config "Register configuration"
1491         wm iconname .reg.config "Reg config"
1492         set regnames [gdb_regnames]
1493         set num_regs [llength $regnames]
1494
1495         frame .reg.config.buts
1496
1497         button .reg.config.done -text " Done " -command "
1498                 recompute_reg_display_list $num_regs
1499                 populate_reg_window
1500                 update_registers all
1501                 destroy .reg.config "
1502
1503         button .reg.config.update -text Update -command "
1504                 recompute_reg_display_list $num_regs
1505                 populate_reg_window
1506                 update_registers all "
1507
1508         pack .reg.config.buts -side bottom -fill x
1509
1510         pack .reg.config.done -side left -fill x -expand yes -in .reg.config.buts
1511         pack .reg.config.update -side right -fill x -expand yes -in .reg.config.buts
1512
1513 # Since there can be lots of registers, we build the window with no more than
1514 # 32 rows, and as many columns as needed.
1515
1516 # First, figure out how many columns we need and create that many column frame
1517 # widgets
1518
1519         set ncols [expr ($num_regs + 31) / 32]
1520
1521         for {set col 0} {$col < $ncols} {incr col} {
1522                 frame .reg.config.col$col
1523                 pack .reg.config.col$col -side left -anchor n
1524         }
1525
1526 # Now, create the checkbutton widgets and pack them in the appropriate columns
1527
1528         set col 0
1529         set row 0
1530         for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
1531                 set regname [lindex $regnames $regnum]
1532                 checkbutton .reg.config.col$col.$row -text $regname -pady 0 \
1533                         -variable regena($regnum) -relief flat -anchor w -bd 1
1534
1535                 pack .reg.config.col$col.$row -side top -fill both
1536
1537                 incr row
1538                 if {$row >= 32} {
1539                         incr col
1540                         set row 0
1541                 }
1542         }
1543 }
1544
1545 #
1546 # Local procedure:
1547 #
1548 #       create_registers_window - Open up the register display window.
1549 #
1550 # Description:
1551 #
1552 #       Create the register display window, with automatic updates.
1553 #
1554
1555 proc create_registers_window {} {
1556         global reg_format
1557
1558         if [winfo exists .reg] {raise .reg ; return}
1559
1560 # Create an initial register display list consisting of all registers
1561
1562         if ![info exists reg_format] {
1563                 global reg_display_list
1564                 global changed_reg_list
1565                 global regena
1566
1567                 set reg_format {}
1568                 set num_regs [llength [gdb_regnames]]
1569                 for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
1570                         set regena($regnum) 1
1571                 }
1572                 recompute_reg_display_list $num_regs
1573                 set changed_reg_list $reg_display_list
1574         }
1575
1576         build_framework .reg Registers
1577
1578 # First, delete all the old menu entries
1579
1580         .reg.menubar.view.menu delete 0 last
1581
1582 # Hex menu item
1583         .reg.menubar.view.menu add radiobutton -label Hex \
1584                 -command {set reg_format x ; update_registers all}
1585
1586 # Decimal menu item
1587         .reg.menubar.view.menu add radiobutton -label Decimal \
1588                 -command {set reg_format d ; update_registers all}
1589
1590 # Octal menu item
1591         .reg.menubar.view.menu add radiobutton -label Octal \
1592                 -command {set reg_format o ; update_registers all}
1593
1594 # Natural menu item
1595         .reg.menubar.view.menu add radiobutton -label Natural \
1596                 -command {set reg_format {} ; update_registers all}
1597
1598 # Config menu item
1599         .reg.menubar.view.menu add separator
1600
1601         .reg.menubar.view.menu add command -label Config -command {
1602                 reg_config_menu }
1603
1604         destroy .reg.label
1605
1606 # Install the reg names
1607
1608         populate_reg_window
1609         update_registers all
1610 }
1611
1612 # Convert regena into a list of the enabled $regnums
1613
1614 proc recompute_reg_display_list {num_regs} {
1615         global reg_display_list
1616         global regmap
1617         global regena
1618
1619         catch {unset reg_display_list}
1620
1621         set line 1
1622         for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
1623
1624                 if {[set regena($regnum)] != 0} {
1625                         lappend reg_display_list $regnum
1626                         set regmap($regnum) $line
1627                         incr line
1628                 }
1629         }
1630 }
1631
1632 # Fill out the register window with the names of the regs specified in
1633 # reg_display_list.
1634
1635 proc populate_reg_window {} {
1636         global max_regname_width
1637         global reg_display_list
1638
1639         .reg.text configure -state normal
1640
1641         .reg.text delete 0.0 end
1642
1643         set regnames [eval gdb_regnames $reg_display_list]
1644
1645 # Figure out the longest register name
1646
1647         set max_regname_width 0
1648
1649         foreach reg $regnames {
1650                 set len [string length $reg]
1651                 if {$len > $max_regname_width} {set max_regname_width $len}
1652         }
1653
1654         set width [expr $max_regname_width + 15]
1655
1656         set height [llength $regnames]
1657
1658         if {$height > 60} {set height 60}
1659
1660         .reg.text configure -height $height -width $width
1661
1662         foreach reg $regnames {
1663                 .reg.text insert end [format "%-*s \n" $max_regname_width ${reg}]
1664         }
1665
1666         .reg.text yview 0
1667         .reg.text configure -state disabled
1668 }
1669
1670 #
1671 # Local procedure:
1672 #
1673 #       update_registers - Update the registers window.
1674 #
1675 # Description:
1676 #
1677 #       This procedure updates the registers window.
1678 #
1679
1680 proc update_registers {which} {
1681         global max_regname_width
1682         global reg_format
1683         global reg_display_list
1684         global changed_reg_list
1685         global highlight
1686         global regmap
1687
1688         set margin [expr $max_regname_width + 1]
1689         set win .reg.text
1690         set winwidth [lindex [$win configure -width] 4]
1691         set valwidth [expr $winwidth - $margin]
1692
1693         $win configure -state normal
1694
1695         if {$which == "all"} {
1696                 set lineindex 1
1697                 foreach regnum $reg_display_list {
1698                         set regval [gdb_fetch_registers $reg_format $regnum]
1699                         set regval [format "%-*s" $valwidth $regval]
1700                         $win delete $lineindex.$margin "$lineindex.0 lineend"
1701                         $win insert $lineindex.$margin $regval
1702                         incr lineindex
1703                 }
1704                 $win configure -state disabled
1705                 return
1706         }
1707
1708 # Unhighlight the old values
1709
1710         foreach regnum $changed_reg_list {
1711                 $win tag delete $win.$regnum
1712         }
1713
1714 # Now, highlight the changed values of the interesting registers
1715
1716         set changed_reg_list [eval gdb_changed_register_list $reg_display_list]
1717
1718         set lineindex 1
1719         foreach regnum $changed_reg_list {
1720                 set regval [gdb_fetch_registers $reg_format $regnum]
1721                 set regval [format "%-*s" $valwidth $regval]
1722
1723                 set lineindex $regmap($regnum)
1724                 $win delete $lineindex.$margin "$lineindex.0 lineend"
1725                 $win insert $lineindex.$margin $regval
1726                 $win tag add $win.$regnum $lineindex.0 "$lineindex.0 lineend"
1727                 eval $win tag configure $win.$regnum $highlight
1728         }
1729
1730         $win configure -state disabled
1731 }
1732
1733 #
1734 # Local procedure:
1735 #
1736 #       update_assembly - Update the assembly window.
1737 #
1738 # Description:
1739 #
1740 #       This procedure updates the assembly window.
1741 #
1742
1743 proc update_assembly {linespec} {
1744         global asm_pointers
1745         global screen_height
1746         global screen_top
1747         global screen_bot
1748         global wins cfunc
1749         global current_label
1750         global win_to_file
1751         global file_to_debug_file
1752         global current_asm_label
1753         global pclist
1754         global asm_screen_height asm_screen_top asm_screen_bot
1755         global .asm.label
1756
1757 # Rip the linespec apart
1758
1759         set pc [lindex $linespec 4]
1760         set line [lindex $linespec 3]
1761         set filename [lindex $linespec 2]
1762         set funcname [lindex $linespec 1]
1763         set debug_file [lindex $linespec 0]
1764
1765         set win [asm_win_name $cfunc]
1766
1767 # Sometimes there's no source file for this location
1768
1769         if {$filename == ""} {set filename Blank}
1770
1771 # If we want to switch funcs, we need to unpack the current text widget, and
1772 # stick in the new one.
1773
1774         if {$funcname != $cfunc } {
1775                 set oldwin $win
1776                 set cfunc $funcname
1777
1778                 set win [asm_win_name $cfunc]
1779
1780 # Create a text widget for this func if necessary
1781
1782                 if {![winfo exists $win]} {
1783                         create_asm_win $cfunc $pc
1784                         set asm_pointers($cfunc) 1.1
1785                         set current_asm_label NIL
1786                         }
1787
1788 # Pack the text widget, and scroll to the right place
1789
1790                 pack forget $oldwin
1791                 pack $win -side left -expand yes -fill both \
1792                         -after .asm.scroll
1793                 .asm.scroll configure -command "$win yview"
1794                 set line [pc_to_line $pclist($cfunc) $pc]
1795                 update
1796                 $win yview [expr $line - $asm_screen_height / 2]
1797                 }
1798
1799 # Update the label widget in case the filename or function name has changed
1800
1801         if {$current_asm_label != "$pc $funcname"} then {
1802                 set .asm.label "$pc $funcname"
1803                 set current_asm_label "$pc $funcname"
1804                 }
1805
1806 # Update the pointer, scrolling the text widget if necessary to keep the
1807 # pointer in an acceptable part of the screen.
1808
1809         if [info exists asm_pointers($cfunc)] then {
1810                 $win configure -state normal
1811                 set pointer_pos $asm_pointers($cfunc)
1812                 $win configure -state normal
1813                 $win delete $pointer_pos "$pointer_pos + 2 char"
1814                 $win insert $pointer_pos "  "
1815
1816 # Map the PC back to a line in the window
1817
1818                 set line [pc_to_line $pclist($cfunc) $pc]
1819
1820                 if {$line == -1} {
1821                         echo "Can't find PC $pc"
1822                         return
1823                         }
1824
1825                 set pointer_pos [$win index $line.1]
1826                 set asm_pointers($cfunc) $pointer_pos
1827
1828                 $win delete $pointer_pos "$pointer_pos + 2 char"
1829                 $win insert $pointer_pos "->"
1830
1831                 if {$line < $asm_screen_top + 1
1832                     || $line > $asm_screen_bot} then {
1833                         $win yview [expr $line - $asm_screen_height / 2]
1834                         }
1835
1836                 $win configure -state disabled
1837                 }
1838 }
1839
1840 #
1841 # Local procedure:
1842 #
1843 #       update_ptr - Update the listing window.
1844 #
1845 # Description:
1846 #
1847 #       This routine will update the listing window using the result of
1848 #       gdb_loc.
1849 #
1850
1851 proc update_ptr {} {
1852         update_listing [gdb_loc]
1853         if [winfo exists .asm] {
1854                 update_assembly [gdb_loc]
1855         }
1856         if [winfo exists .reg] {
1857                 update_registers changed
1858         }
1859         if [winfo exists .expr] {
1860                 update_exprs
1861         }
1862         if [winfo exists .autocmd] {
1863                 update_autocmd
1864         }
1865 }
1866
1867 # Make toplevel window disappear
1868
1869 wm withdraw .
1870
1871 proc files_command {} {
1872         toplevel .files_window
1873
1874         wm minsize .files_window 1 1
1875 #       wm overrideredirect .files_window true
1876         listbox .files_window.list -geometry 30x20 -setgrid true \
1877                 -yscrollcommand {.files_window.scroll set} -relief sunken \
1878                 -borderwidth 2
1879         scrollbar .files_window.scroll -orient vertical \
1880                 -command {.files_window.list yview} -relief sunken
1881         button .files_window.close -text Close -command {destroy .files_window}
1882         tk_listboxSingleSelect .files_window.list
1883
1884 # Get the file list from GDB, sort it, and format it as one entry per line.
1885
1886         set filelist [join [lsort [gdb_listfiles]] "\n"]
1887
1888 # Now, remove duplicates (by using uniq)
1889
1890         set fh [open "| uniq > /tmp/gdbtk.[pid]" w]
1891         puts $fh $filelist
1892         close $fh
1893         set fh [open /tmp/gdbtk.[pid]]
1894         set filelist [split [read $fh] "\n"]
1895         set filelist [lrange $filelist 0 [expr [llength $filelist] - 2]]
1896         close $fh
1897         exec rm /tmp/gdbtk.[pid]
1898
1899 # Insert the file list into the widget
1900
1901         eval .files_window.list insert 0 $filelist
1902
1903         pack .files_window.close -side bottom -fill x -expand no -anchor s
1904         pack .files_window.scroll -side right -fill both
1905         pack .files_window.list -side left -fill both -expand yes
1906         bind .files_window.list <Any-ButtonRelease-1> {
1907                 set file [%W get [%W curselection]]
1908                 gdb_cmd "list $file:1,0"
1909                 update_listing [gdb_loc $file:1]
1910                 destroy .files_window}
1911 }
1912
1913 button .files -text Files -command files_command
1914
1915 proc apply_filespec {label default command} {
1916     set filename [FSBox $label $default]
1917     if {$filename != ""} {
1918         if [catch {gdb_cmd "$command $filename"} retval] {
1919             tk_dialog .filespec_error "gdb : $label error" \
1920                         "Error in command \"$command $filename\"" {} 0 Dismiss
1921             return
1922         }
1923     update_ptr
1924     }
1925 }
1926
1927 # Setup command window
1928
1929 proc build_framework {win {title GDBtk} {label {}}} {
1930         global ${win}.label
1931
1932         toplevel ${win}
1933         wm title ${win} $title
1934         wm minsize ${win} 1 1
1935
1936         frame ${win}.menubar
1937
1938         menubutton ${win}.menubar.file -padx 12 -text File \
1939                 -menu ${win}.menubar.file.menu -underline 0
1940
1941         menu ${win}.menubar.file.menu
1942         ${win}.menubar.file.menu add command -label File... \
1943                 -command {apply_filespec File a.out file}
1944         ${win}.menubar.file.menu add command -label Target... \
1945                 -command { not_implemented_yet "target" }
1946         ${win}.menubar.file.menu add command -label Edit \
1947                 -command {exec $editor +[expr ($screen_top + $screen_bot)/2] $cfile &}
1948         ${win}.menubar.file.menu add separator
1949         ${win}.menubar.file.menu add command -label "Exec File..." \
1950                 -command {apply_filespec {Exec File} a.out exec-file}
1951         ${win}.menubar.file.menu add command -label "Symbol File..." \
1952                 -command {apply_filespec {Symbol File} a.out symbol-file}
1953         ${win}.menubar.file.menu add command -label "Add Symbol File..." \
1954                 -command { not_implemented_yet "menu item, add symbol file" }
1955         ${win}.menubar.file.menu add command -label "Core File..." \
1956                 -command {apply_filespec {Core File} core core-file}
1957
1958         ${win}.menubar.file.menu add separator
1959         ${win}.menubar.file.menu add command -label Close \
1960                 -command "destroy ${win}"
1961         ${win}.menubar.file.menu add separator
1962         ${win}.menubar.file.menu add command -label Quit \
1963                 -command {interactive_cmd quit}
1964
1965         menubutton ${win}.menubar.commands -padx 12 -text Commands \
1966                 -menu ${win}.menubar.commands.menu -underline 0
1967
1968         menu ${win}.menubar.commands.menu
1969         ${win}.menubar.commands.menu add command -label Run \
1970                 -command {interactive_cmd run}
1971         ${win}.menubar.commands.menu add command -label Step \
1972                 -command {interactive_cmd step}
1973         ${win}.menubar.commands.menu add command -label Next \
1974                 -command {interactive_cmd next}
1975         ${win}.menubar.commands.menu add command -label Continue \
1976                 -command {interactive_cmd continue}
1977         ${win}.menubar.commands.menu add separator
1978         ${win}.menubar.commands.menu add command -label Stepi \
1979                 -command {interactive_cmd stepi}
1980         ${win}.menubar.commands.menu add command -label Nexti \
1981                 -command {interactive_cmd nexti}
1982
1983         menubutton ${win}.menubar.view -padx 12 -text Options \
1984                 -menu ${win}.menubar.view.menu -underline 0
1985
1986         menu ${win}.menubar.view.menu
1987         ${win}.menubar.view.menu add command -label Hex \
1988                 -command {echo Hex}
1989         ${win}.menubar.view.menu add command -label Decimal \
1990                 -command {echo Decimal}
1991         ${win}.menubar.view.menu add command -label Octal \
1992                 -command {echo Octal}
1993
1994         menubutton ${win}.menubar.window -padx 12 -text Window \
1995                 -menu ${win}.menubar.window.menu -underline 0
1996
1997         menu ${win}.menubar.window.menu
1998         ${win}.menubar.window.menu add command -label Command \
1999                 -command create_command_window
2000         ${win}.menubar.window.menu add separator
2001         ${win}.menubar.window.menu add command -label Source \
2002                 -command create_source_window
2003         ${win}.menubar.window.menu add command -label Assembly \
2004                 -command create_asm_window
2005         ${win}.menubar.window.menu add separator
2006         ${win}.menubar.window.menu add command -label Registers \
2007                 -command create_registers_window
2008         ${win}.menubar.window.menu add command -label Expressions \
2009                 -command create_expr_window
2010         ${win}.menubar.window.menu add command -label "Auto Command" \
2011                 -command create_autocmd_window
2012 #       ${win}.menubar.window.menu add command -label Breakpoints \
2013 #               -command create_breakpoints_window
2014
2015 #       ${win}.menubar.window.menu add separator
2016 #       ${win}.menubar.window.menu add command -label Files \
2017 #               -command { not_implemented_yet "files window" }
2018
2019         menubutton ${win}.menubar.help -padx 12 -text Help \
2020                 -menu ${win}.menubar.help.menu -underline 0
2021
2022         menu ${win}.menubar.help.menu
2023         ${win}.menubar.help.menu add command -label "with GDBtk" \
2024                 -command {echo "with GDBtk"}
2025         ${win}.menubar.help.menu add command -label "with this window" \
2026                 -command {echo "with this window"}
2027         ${win}.menubar.help.menu add command -label "Report bug" \
2028                 -command {exec send-pr}
2029
2030         tk_menuBar ${win}.menubar \
2031                 ${win}.menubar.file \
2032                 ${win}.menubar.view \
2033                 ${win}.menubar.window \
2034                 ${win}.menubar.help
2035         pack    ${win}.menubar.file \
2036                 ${win}.menubar.view \
2037                 ${win}.menubar.window -side left
2038         pack    ${win}.menubar.help -side right
2039
2040         frame ${win}.info
2041         text ${win}.text -height 25 -width 80 -relief sunken -borderwidth 2 \
2042                 -setgrid true -cursor hand2 -yscrollcommand "${win}.scroll set"
2043
2044         set ${win}.label $label
2045         label ${win}.label -textvariable ${win}.label -borderwidth 2 -relief sunken
2046
2047         scrollbar ${win}.scroll -orient vertical -command "${win}.text yview" \
2048                 -relief sunken
2049
2050         pack ${win}.label -side bottom -fill x -in ${win}.info
2051         pack ${win}.scroll -side right -fill y -in ${win}.info
2052         pack ${win}.text -side left -expand yes -fill both -in ${win}.info
2053
2054         pack ${win}.menubar -side top -fill x
2055         pack ${win}.info -side top -fill both -expand yes
2056 }
2057
2058 proc create_source_window {} {
2059         global wins
2060         global cfile
2061
2062         if [winfo exists .src] {raise .src ; return}
2063
2064         build_framework .src Source "*No file*"
2065
2066 # First, delete all the old view menu entries
2067
2068         .src.menubar.view.menu delete 0 last
2069
2070 # Source file selection
2071         .src.menubar.view.menu add command -label "Select source file" \
2072                 -command files_command
2073
2074 # Line numbers enable/disable menu item
2075         .src.menubar.view.menu add checkbutton -variable line_numbers \
2076                 -label "Line numbers" -onvalue 1 -offvalue 0 -command {
2077                 foreach source [array names wins] {
2078                         if {$source == "Blank"} continue
2079                         destroy $wins($source)
2080                         unset wins($source)
2081                         }
2082                 set cfile Blank
2083                 update_listing [gdb_loc]
2084                 }
2085
2086         frame .src.row1
2087         frame .src.row2
2088
2089         button .src.start -width 6 -text Start -command \
2090                 {interactive_cmd {break main}
2091                  interactive_cmd {enable delete $bpnum}
2092                  interactive_cmd run }
2093         button .src.stop -width 6 -text Stop -fg red -activeforeground red \
2094                 -state disabled -command gdb_stop
2095         button .src.step -width 6 -text Step \
2096                 -command {interactive_cmd step}
2097         button .src.next -width 6 -text Next \
2098                 -command {interactive_cmd next}
2099         button .src.continue -width 6 -text Cont \
2100                 -command {interactive_cmd continue}
2101         button .src.finish -width 6 -text Finish \
2102                 -command {interactive_cmd finish}
2103         button .src.up -width 6 -text Up \
2104                 -command {interactive_cmd up}
2105         button .src.down -width 6 -text Down \
2106                 -command {interactive_cmd down}
2107         button .src.bottom -width 6 -text Bottom \
2108                 -command {interactive_cmd {frame 0}}
2109
2110         pack .src.start .src.step .src.continue .src.up .src.bottom \
2111                 -side left -padx 3 -pady 5 -in .src.row1
2112         pack .src.stop .src.next .src.finish .src.down -side left -padx 3 \
2113                 -pady 5 -in .src.row2
2114
2115         pack .src.row2 .src.row1 -side bottom -anchor w -before .src.info
2116
2117         $wins($cfile) insert 0.0 "  This page intentionally left blank."
2118         $wins($cfile) configure -width 88 -state disabled \
2119                 -yscrollcommand textscrollproc
2120
2121         proc textscrollproc {args} {global screen_height screen_top screen_bot
2122                                     eval ".src.scroll set $args"
2123                                     set screen_height [lindex $args 1]
2124                                     set screen_top [lindex $args 2]
2125                                     set screen_bot [lindex $args 3]}
2126 }
2127
2128 proc update_autocmd {} {
2129         global .autocmd.label
2130         global accumulate_output
2131
2132         catch {gdb_cmd "${.autocmd.label}"} result
2133         if !$accumulate_output { .autocmd.text delete 0.0 end }
2134         .autocmd.text insert end $result
2135         .autocmd.text yview -pickplace end
2136 }
2137
2138 proc create_autocmd_window {} {
2139         global .autocmd.label
2140
2141         if [winfo exists .autocmd] {raise .autocmd ; return}
2142
2143         build_framework .autocmd "Auto Command" ""
2144
2145 # First, delete all the old view menu entries
2146
2147         .autocmd.menubar.view.menu delete 0 last
2148
2149 # Accumulate output option
2150
2151         .autocmd.menubar.view.menu add checkbutton \
2152                 -variable accumulate_output \
2153                 -label "Accumulate output" -onvalue 1 -offvalue 0
2154
2155 # Now, create entry widget with label
2156
2157         frame .autocmd.entryframe
2158
2159         entry .autocmd.entry -borderwidth 2 -relief sunken
2160         bind .autocmd <Enter> {focus .autocmd.entry}
2161         bind .autocmd.entry <Key-Return> {set .autocmd.label [.autocmd.entry get]
2162                                           .autocmd.entry delete 0 end }
2163
2164         label .autocmd.entrylab -text "Command: "
2165
2166         pack .autocmd.entrylab -in .autocmd.entryframe -side left
2167         pack .autocmd.entry -in .autocmd.entryframe -side left -fill x -expand yes
2168
2169         pack .autocmd.entryframe -side bottom -fill x -before .autocmd.info
2170 }
2171
2172 proc create_command_window {} {
2173         global command_line
2174
2175         if [winfo exists .cmd] {raise .cmd ; return}
2176
2177         build_framework .cmd Command "* Command Buffer *"
2178
2179         set command_line {}
2180
2181         gdb_cmd {set language c}
2182         gdb_cmd {set height 0}
2183         gdb_cmd {set width 0}
2184
2185         bind .cmd.text <Enter> {focus %W}
2186         bind .cmd.text <Delete> {delete_char %W}
2187         bind .cmd.text <BackSpace> {delete_char %W}
2188         bind .cmd.text <Control-u> {delete_line %W}
2189         bind .cmd.text <Any-Key> {
2190                 global command_line
2191
2192                 %W insert end %A
2193                 %W yview -pickplace end
2194                 append command_line %A
2195                 }
2196         bind .cmd.text <Key-Return> {
2197                 global command_line
2198
2199                 %W insert end \n
2200                 interactive_cmd $command_line
2201
2202 #               %W yview -pickplace end
2203 #               catch "gdb_cmd [list $command_line]" result
2204 #               %W insert end $result
2205                 set command_line {}
2206 #               update_ptr
2207                 %W insert end "(gdb) "
2208                 %W yview -pickplace end
2209                 }
2210         bind .cmd.text <Button-2> {
2211                 global command_line
2212
2213                 %W insert end [selection get]
2214                 %W yview -pickplace end
2215                 append command_line [selection get]
2216         }
2217         proc delete_char {win} {
2218                 global command_line
2219
2220                 tk_textBackspace $win
2221                 $win yview -pickplace insert
2222                 set tmp [expr [string length $command_line] - 2]
2223                 set command_line [string range $command_line 0 $tmp]
2224         }
2225         proc delete_line {win} {
2226                 global command_line
2227
2228                 $win delete {end linestart + 6 chars} end
2229                 $win yview -pickplace insert
2230                 set command_line {}
2231         }
2232 }
2233
2234 #
2235 # fileselect.tcl --
2236 # simple file selector.
2237 #
2238 # Mario Jorge Silva                               [email protected]
2239 # University of California Berkeley                 Ph:    +1(510)642-8248
2240 # Computer Science Division, 571 Evans Hall         Fax:   +1(510)642-5775
2241 # Berkeley CA 94720
2242 #
2243 #
2244 # Copyright 1993 Regents of the University of California
2245 # Permission to use, copy, modify, and distribute this
2246 # software and its documentation for any purpose and without
2247 # fee is hereby granted, provided that this copyright
2248 # notice appears in all copies.  The University of California
2249 # makes no representations about the suitability of this
2250 # software for any purpose.  It is provided "as is" without
2251 # express or implied warranty.
2252 #
2253
2254
2255 # names starting with "fileselect" are reserved by this module
2256 # no other names used.
2257 # Hack - FSBox is defined instead of fileselect for backwards compatibility
2258
2259
2260 # this is the proc that creates the file selector box
2261 # purpose - comment string
2262 # defaultName - initial value for name
2263 # cmd - command to eval upon OK
2264 # errorHandler - command to eval upon Cancel
2265 # If neither cmd or errorHandler are specified, the return value
2266 # of the FSBox procedure is the selected file name.
2267
2268 proc FSBox {{purpose "Select file:"} {defaultName ""} {cmd ""} {errorHandler
2269 ""}} {
2270     global fileselect
2271     set w .fileSelect
2272     if [Exwin_Toplevel $w "Select File" FileSelect] {
2273         # path independent names for the widgets
2274
2275         set fileselect(list) $w.file.sframe.list
2276         set fileselect(scroll) $w.file.sframe.scroll
2277         set fileselect(direntry) $w.file.f1.direntry
2278         set fileselect(entry) $w.file.f2.entry
2279         set fileselect(ok) $w.but.ok
2280         set fileselect(cancel) $w.but.cancel
2281         set fileselect(msg) $w.label
2282
2283         set fileselect(result) ""       ;# value to return if no callback procedures
2284
2285         # widgets
2286         Widget_Label $w label {top fillx pady 10 padx 20} -anchor w -width 24
2287         Widget_Frame $w file Dialog {left expand fill} -bd 10
2288
2289         Widget_Frame $w.file f1 Exmh {top fillx}
2290         Widget_Label $w.file.f1 label {left} -text "Dir"
2291         Widget_Entry $w.file.f1 direntry {right fillx expand}  -width 30
2292
2293         Widget_Frame $w.file sframe
2294
2295         scrollbar $w.file.sframe.yscroll -relief sunken \
2296                 -command [list $w.file.sframe.list yview]
2297         listbox $w.file.sframe.list -relief sunken \
2298                 -yscroll [list $w.file.sframe.yscroll set] -setgrid 1
2299         pack append $w.file.sframe \
2300                 $w.file.sframe.yscroll {right filly} \
2301                 $w.file.sframe.list {left expand fill}
2302
2303         Widget_Frame $w.file f2 Exmh {top fillx}
2304         Widget_Label $w.file.f2 label {left} -text Name
2305         Widget_Entry $w.file.f2 entry {right fillx expand}
2306
2307         # buttons
2308         $w.but.quit configure -text Cancel \
2309                 -command [list fileselect.cancel.cmd $w]
2310
2311         Widget_AddBut $w.but ok OK \
2312                 [list fileselect.ok.cmd $w $cmd $errorHandler] {left padx 1}
2313
2314         Widget_AddBut $w.but list List \
2315                 [list fileselect.list.cmd $w] {left padx 1}
2316         Widget_CheckBut $w.but listall "List all" fileselect(pattern)
2317         $w.but.listall configure -onvalue "{*,.*}" -offvalue "*" \
2318             -command {fileselect.list.cmd $fileselect(direntry)}
2319         $w.but.listall deselect
2320
2321         # Set up bindings for the browser.
2322         foreach ww [list $w $fileselect(entry)] {
2323             bind $ww <Return> [list $fileselect(ok) invoke]
2324             bind $ww <Control-c> [list $fileselect(cancel) invoke]
2325         }
2326         bind $fileselect(direntry) <Return> [list fileselect.list.cmd %W]
2327         bind $fileselect(direntry) <Tab> [list fileselect.tab.dircmd]
2328         bind $fileselect(entry) <Tab> [list fileselect.tab.filecmd]
2329
2330         tk_listboxSingleSelect $fileselect(list)
2331
2332
2333         bind $fileselect(list) <Button-1> {
2334             # puts stderr "button 1 release"
2335             %W select from [%W nearest %y]
2336             $fileselect(entry) delete 0 end
2337             $fileselect(entry) insert 0 [%W get [%W nearest %y]]
2338         }
2339
2340         bind $fileselect(list) <Key> {
2341             %W select from [%W nearest %y]
2342             $fileselect(entry) delete 0 end
2343             $fileselect(entry) insert 0 [%W get [%W nearest %y]]
2344         }
2345
2346         bind $fileselect(list) <Double-ButtonPress-1> {
2347             # puts stderr "double button 1"
2348             %W select from [%W nearest %y]
2349             $fileselect(entry) delete 0 end
2350             $fileselect(entry) insert 0 [%W get [%W nearest %y]]
2351             $fileselect(ok) invoke
2352         }
2353
2354         bind $fileselect(list) <Return> {
2355             %W select from [%W nearest %y]
2356             $fileselect(entry) delete 0 end
2357             $fileselect(entry) insert 0 [%W get [%W nearest %y]]
2358             $fileselect(ok) invoke
2359         }
2360     }
2361     set fileselect(text) $purpose
2362     $fileselect(msg) configure -text $purpose
2363     $fileselect(entry) delete 0 end
2364     $fileselect(entry) insert 0 [file tail $defaultName]
2365
2366     if {[info exists fileselect(lastDir)] && ![string length $defaultName]} {
2367         set dir $fileselect(lastDir)
2368     } else {
2369         set dir [file dirname $defaultName]
2370     }
2371     set fileselect(pwd) [pwd]
2372     fileselect.cd $dir
2373     $fileselect(direntry) delete 0 end
2374     $fileselect(direntry) insert 0 [pwd]/
2375
2376     $fileselect(list) delete 0 end
2377     $fileselect(list) insert 0 "Big directory:"
2378     $fileselect(list) insert 1 $dir
2379     $fileselect(list) insert 2 "Press Return for Listing"
2380
2381     fileselect.list.cmd $fileselect(direntry) startup
2382
2383     # set kbd focus to entry widget
2384
2385 #    Exwin_ToplevelFocus $w $fileselect(entry)
2386
2387     # Wait for button hits if no callbacks are defined
2388
2389     if {"$cmd" == "" && "$errorHandler" == ""} {
2390         # wait for the box to be destroyed
2391         update idletask
2392         grab $w
2393         tkwait variable fileselect(result)
2394         grab release $w
2395
2396         set path $fileselect(result)
2397         set fileselect(lastDir) [pwd]
2398         fileselect.cd $fileselect(pwd)
2399         return [string trimright [string trim $path] /]
2400     }
2401     fileselect.cd $fileselect(pwd)
2402     return ""
2403 }
2404
2405 proc fileselect.cd { dir } {
2406     global fileselect
2407     if [catch {cd $dir} err] {
2408         fileselect.yck $dir
2409         cd
2410     }
2411 }
2412 # auxiliary button procedures
2413
2414 proc fileselect.yck { {tag {}} } {
2415     global fileselect
2416     $fileselect(msg) configure -text "Yck! $tag"
2417 }
2418 proc fileselect.ok {} {
2419     global fileselect
2420     $fileselect(msg) configure -text $fileselect(text)
2421 }
2422
2423 proc fileselect.cancel.cmd {w} {
2424     global fileselect
2425     set fileselect(result) {}
2426     destroy $w
2427 }
2428
2429 proc fileselect.list.cmd {w {state normal}} {
2430     global fileselect
2431     set seldir [$fileselect(direntry) get]
2432     if {[catch {glob $seldir} dir]} {
2433         fileselect.yck "glob failed"
2434         return
2435     }
2436     if {[llength $dir] > 1} {
2437         set dir [file dirname $seldir]
2438         set pat [file tail $seldir]
2439     } else {
2440         set pat $fileselect(pattern)
2441     }
2442     fileselect.ok
2443     update idletasks
2444     if [file isdirectory $dir] {
2445         fileselect.getfiles $dir $pat $state
2446         focus $fileselect(entry)
2447     } else {
2448         fileselect.yck "not a dir"
2449     }
2450 }
2451
2452 proc fileselect.ok.cmd {w cmd errorHandler} {
2453     global fileselect
2454     set selname [$fileselect(entry) get]
2455     set seldir [$fileselect(direntry) get]
2456
2457     if [string match /* $selname] {
2458         set selected $selname
2459     } else {
2460         if [string match ~* $selname] {
2461             set selected $selname
2462         } else {
2463             set selected $seldir/$selname
2464         }
2465     }
2466
2467     # some nasty file names may cause "file isdirectory" to return an error
2468     if [catch {file isdirectory $selected} isdir] {
2469         fileselect.yck "isdirectory failed"
2470         return
2471     }
2472     if [catch {glob $selected} globlist] {
2473         if ![file isdirectory [file dirname $selected]] {
2474             fileselect.yck "bad pathname"
2475             return
2476         }
2477         set globlist $selected
2478     }
2479     fileselect.ok
2480     update idletasks
2481
2482     if {[llength $globlist] > 1} {
2483         set dir [file dirname $selected]
2484         set pat [file tail $selected]
2485         fileselect.getfiles $dir $pat
2486         return
2487     } else {
2488         set selected $globlist
2489     }
2490     if [file isdirectory $selected] {
2491         fileselect.getfiles $selected $fileselect(pattern)
2492         $fileselect(entry) delete 0 end
2493         return
2494     }
2495
2496     if {$cmd != {}} {
2497         $cmd $selected
2498     } else {
2499         set fileselect(result) $selected
2500     }
2501     destroy $w
2502 }
2503
2504 proc fileselect.getfiles { dir {pat *} {state normal} } {
2505     global fileselect
2506     $fileselect(msg) configure -text Listing...
2507     update idletasks
2508
2509     set currentDir [pwd]
2510     fileselect.cd $dir
2511     if [catch {set files [lsort [glob -nocomplain $pat]]} err] {
2512         $fileselect(msg) configure -text $err
2513         $fileselect(list) delete 0 end
2514         update idletasks
2515         return
2516     }
2517     switch -- $state {
2518         normal {
2519             # Normal case - show current directory
2520             $fileselect(direntry) delete 0 end
2521             $fileselect(direntry) insert 0 [pwd]/
2522         }
2523         opt {
2524             # Directory already OK (tab related)
2525         }
2526         newdir {
2527             # Changing directory (tab related)
2528             fileselect.cd $currentDir
2529         }
2530         startup {
2531             # Avoid listing huge directories upon startup.
2532             $fileselect(direntry) delete 0 end
2533             $fileselect(direntry) insert 0 [pwd]/
2534             if {[llength $files] > 32} {
2535                 fileselect.ok
2536                 return
2537             }
2538         }
2539     }
2540
2541     # build a reordered list of the files: directories are displayed first
2542     # and marked with a trailing "/"
2543     if [string compare $dir /] {
2544         fileselect.putfiles $files [expr {($pat == "*") ? 1 : 0}]
2545     } else {
2546         fileselect.putfiles $files
2547     }
2548     fileselect.ok
2549 }
2550
2551 proc fileselect.putfiles {files {dotdot 0} } {
2552     global fileselect
2553
2554     $fileselect(list) delete 0 end
2555     if {$dotdot} {
2556         $fileselect(list) insert end "../"
2557     }
2558     foreach i $files {
2559         if {[file isdirectory $i]} {
2560             $fileselect(list) insert end $i/
2561         } else {
2562             $fileselect(list) insert end $i
2563         }
2564     }
2565 }
2566
2567 proc FileExistsDialog { name } {
2568     set w .fileExists
2569     global fileExists
2570     set fileExists(ok) 0
2571     {
2572         message $w.msg -aspect 1000
2573         pack $w.msg -side top -fill both -padx 20 -pady 20
2574         $w.but.quit config -text Cancel -command {FileExistsCancel}
2575         button $w.but.ok -text OK -command {FileExistsOK}
2576         pack $w.but.ok -side left
2577         bind $w.msg <Return> {FileExistsOK}
2578     }
2579     $w.msg config -text "Warning: file exists
2580 $name
2581 OK to overwrite it?"
2582
2583     set fileExists(focus) [focus]
2584     focus $w.msg
2585     grab $w
2586     tkwait variable fileExists(ok)
2587     grab release $w
2588     destroy $w
2589     return $fileExists(ok)
2590 }
2591 proc FileExistsCancel {} {
2592     global fileExists
2593     set fileExists(ok) 0
2594 }
2595 proc FileExistsOK {} {
2596     global fileExists
2597     set fileExists(ok) 1
2598 }
2599
2600 proc fileselect.getfiledir { dir {basedir [pwd]} } {
2601     global fileselect
2602
2603     set path [$fileselect(direntry) get]
2604     set returnList {}
2605
2606     if {$dir != 0} {
2607         if {[string index $path 0] == "~"} {
2608             set path $path/
2609         }
2610     } else {
2611         set path [$fileselect(entry) get]
2612     }
2613     if [catch {set listFile [glob -nocomplain $path*]}] {
2614         return  $returnList
2615     }
2616     foreach el $listFile {
2617         if {$dir != 0} {
2618             if [file isdirectory $el] {
2619                 lappend returnList [file tail $el]
2620             }
2621         } elseif ![file isdirectory $el] {
2622             lappend returnList [file tail $el]
2623         }
2624     }
2625
2626     return $returnList
2627 }
2628
2629 proc fileselect.gethead { list } {
2630     set returnHead ""
2631
2632     for {set i 0} {[string length [lindex $list 0]] > $i}\
2633         {incr i; set returnHead $returnHead$thisChar} {
2634             set thisChar [string index [lindex $list 0] $i]
2635             foreach el $list {
2636                 if {[string length $el] < $i} {
2637                     return $returnHead
2638                 }
2639                 if {$thisChar != [string index $el $i]} {
2640                     return $returnHead
2641                 }
2642             }
2643         }
2644     return $returnHead
2645 }
2646
2647 proc fileselect.expand.tilde { } {
2648     global fileselect
2649
2650     set entry [$fileselect(direntry) get]
2651     set dir [string range $entry 1 [string length $entry]]
2652
2653     if {$dir == ""} {
2654         return
2655     }
2656
2657     set listmatch {}
2658
2659     ## look in /etc/passwd
2660     if [file exists /etc/passwd] {
2661         if [catch {set users [exec cat /etc/passwd | sed s/:.*//]} err] {
2662             puts "Error\#1 $err"
2663             return
2664         }
2665         set list [split $users "\n"]
2666     }
2667     if {[lsearch -exact $list "+"] != -1} {
2668         if [catch {set users [exec ypcat passwd | sed s/:.*//]} err] {
2669             puts "Error\#2 $err"
2670             return
2671         }
2672         set list [concat $list [split $users "\n"]]
2673     }
2674     $fileselect(list) delete 0 end
2675     foreach el $list {
2676         if [string match $dir* $el] {
2677             lappend listmatch $el
2678             $fileselect(list) insert end $el
2679         }
2680     }
2681     set addings [fileselect.gethead $listmatch]
2682     if {$addings == ""} {
2683         return
2684     }
2685     $fileselect(direntry) delete 0 end
2686     if {[llength $listmatch] == 1} {
2687         $fileselect(direntry) insert 0 [file dirname ~$addings/]
2688         fileselect.getfiles [$fileselect(direntry) get]
2689     } else {
2690         $fileselect(direntry) insert 0 ~$addings
2691     }
2692 }
2693
2694 proc fileselect.tab.dircmd { } {
2695     global fileselect
2696
2697     set dir [$fileselect(direntry) get]
2698     if {$dir == ""} {
2699         $fileselect(direntry) delete 0 end
2700             $fileselect(direntry) insert 0 [pwd]
2701         if [string compare [pwd] "/"] {
2702             $fileselect(direntry) insert end /
2703         }
2704         return
2705     }
2706     if [catch {set tmp [file isdirectory [file dirname $dir]]}] {
2707         if {[string index $dir 0] == "~"} {
2708             fileselect.expand.tilde
2709         }
2710         return
2711     }
2712     if {!$tmp} {
2713         return
2714     }
2715     set dirFile [fileselect.getfiledir 1 $dir]
2716     if ![llength $dirFile] {
2717         return
2718     }
2719     if {[llength $dirFile] == 1} {
2720         $fileselect(direntry) delete 0 end
2721         $fileselect(direntry) insert 0 [file dirname $dir]
2722         if [string compare [file dirname $dir] /] {
2723             $fileselect(direntry) insert end /[lindex $dirFile 0]/
2724         } else {
2725             $fileselect(direntry) insert end [lindex $dirFile 0]/
2726         }
2727         fileselect.getfiles [$fileselect(direntry) get] \
2728             "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
2729         return
2730     }
2731     set headFile [fileselect.gethead $dirFile]
2732     $fileselect(direntry) delete 0 end
2733     $fileselect(direntry) insert 0 [file dirname $dir]
2734     if [string compare [file dirname $dir] /] {
2735         $fileselect(direntry) insert end /$headFile
2736     } else {
2737         $fileselect(direntry) insert end $headFile
2738     }
2739     if {$headFile == "" && [file isdirectory $dir]} {
2740         fileselect.getfiles $dir\
2741             "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
2742     } else {
2743         fileselect.getfiles [file dirname $dir]\
2744             "[file tail [$fileselect(direntry) get]]*" newdir
2745     }
2746 }
2747
2748 proc fileselect.tab.filecmd { } {
2749     global fileselect
2750
2751     set dir [$fileselect(direntry) get]
2752     if {$dir == ""} {
2753         set dir [pwd]
2754     }
2755     if {![file isdirectory $dir]} {
2756         error "dir $dir doesn't exist"
2757     }
2758     set listFile [fileselect.getfiledir 0 $dir]
2759     puts $listFile
2760     if ![llength $listFile] {
2761         return
2762     }
2763     if {[llength $listFile] == 1} {
2764         $fileselect(entry) delete 0 end
2765         $fileselect(entry) insert 0 [lindex $listFile 0]
2766         return
2767     }
2768     set headFile [fileselect.gethead $listFile]
2769     $fileselect(entry) delete 0 end
2770     $fileselect(entry) insert 0 $headFile
2771     fileselect.getfiles $dir "[$fileselect(entry) get]$fileselect(pattern)" opt
2772 }
2773
2774 proc Exwin_Toplevel { path name {class Dialog} {dismiss yes}} {
2775     global exwin
2776     if [catch {wm state $path} state] {
2777         set t [Widget_Toplevel $path $name $class]
2778         if ![info exists exwin(toplevels)] {
2779             set exwin(toplevels) [option get . exwinPaths {}]
2780         }
2781         set ix [lsearch $exwin(toplevels) $t]
2782         if {$ix < 0} {
2783             lappend exwin(toplevels) $t
2784         }
2785         if {$dismiss == "yes"} {
2786             set f [Widget_Frame $t but Menubar {top fill}]
2787             Widget_AddBut $f quit "Dismiss" [list Exwin_Dismiss $path]
2788         }
2789         return 1
2790     } else {
2791         if {$state != "normal"} {
2792             catch {
2793                 wm geometry $path $exwin(geometry,$path)
2794 #               Exmh_Debug Exwin_Toplevel $path $exwin(geometry,$path)
2795             }
2796             wm deiconify $path
2797         } else {
2798             catch {raise $path}
2799         }
2800         return 0
2801     }
2802 }
2803
2804 proc Exwin_Dismiss { path {geo ok} } {
2805     global exwin
2806     case $geo {
2807         "ok" {
2808             set exwin(geometry,$path) [wm geometry $path]
2809         }
2810         "nosize" {
2811             set exwin(geometry,$path) [string trimleft [wm geometry $path] 0123456789x]
2812         }
2813         default {
2814             catch {unset exwin(geometry,$path)}
2815         }
2816     }
2817     wm withdraw $path
2818 }
2819
2820 proc Widget_Toplevel { path name {class Dialog} {x {}} {y {}} } {
2821     set self [toplevel $path -class $class]
2822     set usergeo [option get $path position Position]
2823     if {$usergeo != {}} {
2824         if [catch {wm geometry $self $usergeo} err] {
2825 #           Exmh_Debug Widget_Toplevel $self $usergeo => $err
2826         }
2827     } else {
2828         if {($x != {}) && ($y != {})} {
2829 #           Exmh_Debug Event position $self +$x+$y
2830             wm geometry $self +$x+$y
2831         }
2832     }
2833     wm title $self $name
2834     wm group $self .
2835     return $self
2836 }
2837
2838 proc Widget_Frame {par child {class GDB} {where {top expand fill}} args } {
2839     if {$par == "."} {
2840         set self .$child
2841     } else {
2842         set self $par.$child
2843     }
2844     eval {frame $self -class $class} $args
2845     pack append $par $self $where
2846     return $self
2847 }
2848
2849 proc Widget_AddBut {par but txt cmd {where {right padx 1}} } {
2850     # Create a Packed button.  Return the button pathname
2851     set cmd2 [list button $par.$but -text $txt -command $cmd]
2852     if [catch $cmd2 t] {
2853         puts stderr "Widget_AddBut (warning) $t"
2854         eval $cmd2 {-font fixed}
2855     }
2856     pack append $par $par.$but $where
2857     return $par.$but
2858 }
2859 proc Widget_CheckBut {par but txt var {where {right padx 1}} } {
2860     # Create a check button.  Return the button pathname
2861     set cmd [list checkbutton $par.$but -text $txt -variable $var]
2862     if [catch $cmd t] {
2863         puts stderr "Widget_CheckBut (warning) $t"
2864         eval $cmd {-font fixed}
2865     }
2866     pack append $par $par.$but $where
2867     return $par.$but
2868 }
2869
2870 proc Widget_Label { frame {name label} {where {left fill}} args} {
2871     set cmd [list label $frame.$name ]
2872     if [catch [concat $cmd $args] t] {
2873         puts stderr "Widget_Label (warning) $t"
2874         eval $cmd $args {-font fixed}
2875     }
2876     pack append $frame $frame.$name $where
2877     return $frame.$name
2878 }
2879 proc Widget_Entry { frame {name entry} {where {left fill}} args} {
2880     set cmd [list entry $frame.$name ]
2881     if [catch [concat $cmd $args] t] {
2882         puts stderr "Widget_Entry (warning) $t"
2883         eval $cmd $args {-font fixed}
2884     }
2885     pack append $frame $frame.$name $where
2886     return $frame.$name
2887 }
2888
2889 # End of fileselect.tcl.
2890
2891 # Setup the initial windows
2892
2893 create_source_window
2894
2895 if {[tk colormodel .src.text] == "color"} {
2896         set highlight "-background red2 -borderwidth 2 -relief sunk"
2897 } else {
2898         set fg [lindex [.src.text config -foreground] 4]
2899         set bg [lindex [.src.text config -background] 4]
2900         set highlight "-foreground $bg -background $fg -borderwidth 0"
2901 }
2902
2903 create_command_window
2904
2905 # Create a copyright window
2906
2907 update
2908 toplevel .c
2909 wm geometry .c +300+300
2910 wm overrideredirect .c true
2911
2912 message .c.m -text [gdb_cmd "show version"] -aspect 500 -relief raised
2913 pack .c.m
2914 bind .c.m <Leave> {destroy .c}
2915 update
2916
2917 if [file exists ~/.gdbtkinit] {
2918         source ~/.gdbtkinit
2919 }