gdb/gdbtk.tcl

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