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