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