gdb/gdbtk.tcl

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