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