gdb/gdbtk.tcl

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