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