gdb/gdbtk.tcl

   1 # GDB GUI setup
   2
   3 set cfile Blank
   4 set wins($cfile) .src.text
   5 set current_label {}
   6 set screen_height 0
   7 set screen_top 0
   8 set screen_bot 0
   9 set current_output_win .cmd.text
  10 set cfunc NIL
  11 #option add *Foreground Black
  12 #option add *Background White
  13 #option add *Font -*-*-medium-r-normal--18-*-*-*-m-*-*-1
  14 tk colormodel . monochrome
  15
  16 proc echo string {puts stdout $string}
  17
  18 if [info exists env(EDITOR)] then {
  19         set editor $env(EDITOR)
  20         } else {
  21         set editor emacs
  22 }
  23
  24 # GDB callbacks
  25 #
  26 #  These functions are called by GDB (from C code) to do various things in
  27 #  TK-land.  All start with the prefix `gdbtk_tcl_' to make them easy to find.
  28 #
  29
  30 #
  31 # GDB Callback:
  32 #
  33 #       gdbtk_tcl_fputs (text) - Output text to the command window
  34 #
  35 # Description:
  36 #
  37 #       GDB calls this to output TEXT to the GDB command window.  The text is
  38 #       placed at the end of the text widget.  Note that output may not occur,
  39 #       due to buffering.  Use gdbtk_tcl_flush to cause an immediate update.
  40 #
  41
  42 proc gdbtk_tcl_fputs {arg} {
  43         global current_output_win
  44
  45         $current_output_win insert end "$arg"
  46         $current_output_win yview -pickplace end
  47 }
  48
  49 #
  50 # GDB Callback:
  51 #
  52 #       gdbtk_tcl_flush () - Flush output to the command window
  53 #
  54 # Description:
  55 #
  56 #       GDB calls this to force all buffered text to the GDB command window.
  57 #
  58
  59 proc gdbtk_tcl_flush {} {
  60         $current_output_win yview -pickplace end
  61         update idletasks
  62 }
  63
  64 #
  65 # GDB Callback:
  66 #
  67 #       gdbtk_tcl_query (message) - Create a yes/no query dialog box
  68 #
  69 # Description:
  70 #
  71 #       GDB calls this to create a yes/no dialog box containing MESSAGE.  GDB
  72 #       is hung while the dialog box is active (ie: no commands will work),
  73 #       however windows can still be refreshed in case of damage or exposure.
  74 #
  75
  76 proc gdbtk_tcl_query {message} {
  77         tk_dialog .query "gdb : query" "$message" {} 1 "No" "Yes"
  78         }
  79
  80 #
  81 # GDB Callback:
  82 #
  83 #       gdbtk_start_variable_annotation (args ...) -
  84 #
  85 # Description:
  86 #
  87 #       Not yet implemented.
  88 #
  89
  90 proc gdbtk_tcl_start_variable_annotation {valaddr ref_type stor_cl cum_expr field type_cast} {
  91         echo "gdbtk_tcl_start_variable_annotation $valaddr $ref_type $stor_cl $cum_expr $field $type_cast"
  92 }
  93
  94 #
  95 # GDB Callback:
  96 #
  97 #       gdbtk_end_variable_annotation (args ...) -
  98 #
  99 # Description:
 100 #
 101 #       Not yet implemented.
 102 #
 103
 104 proc gdbtk_tcl_end_variable_annotation {} {
 105         echo gdbtk_tcl_end_variable_annotation
 106 }
 107
 108 #
 109 # GDB Callback:
 110 #
 111 #       gdbtk_tcl_breakpoint (action bpnum file line) - Notify the TK
 112 #       interface of changes to breakpoints.
 113 #
 114 # Description:
 115 #
 116 #       GDB calls this to notify TK of changes to breakpoints.  ACTION is one
 117 #       of:
 118 #               create          - Notify of breakpoint creation
 119 #               delete          - Notify of breakpoint deletion
 120 #               enable          - Notify of breakpoint enabling
 121 #               disable         - Notify of breakpoint disabling
 122 #
 123 #       All actions take the same set of arguments:  BPNUM is the breakpoint
 124 #       number,  FILE is the source file and LINE is the line number, and PC is
 125 #       the pc of the affected breakpoint.
 126 #
 127
 128 proc gdbtk_tcl_breakpoint {action bpnum file line pc} {
 129         ${action}_breakpoint $bpnum $file $line $pc
 130 }
 131
 132 proc asm_win_name {funcname} {
 133         regsub -all {\.} $funcname _ temp
 134
 135         return .asm.func_${temp}
 136 }
 137
 138 #
 139 # Local procedure:
 140 #
 141 #       create_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
 142 #
 143 # Description:
 144 #
 145 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
 146 #       land of breakpoint creation.  This consists of recording the file and
 147 #       line number in the breakpoint_file and breakpoint_line arrays.  Also,
 148 #       if there is already a window associated with FILE, it is updated with
 149 #       a breakpoint tag.
 150 #
 151
 152 proc create_breakpoint {bpnum file line pc} {
 153         global wins
 154         global breakpoint_file
 155         global breakpoint_line
 156         global pos_to_breakpoint
 157         global pos_to_bpcount
 158         global cfunc
 159         global pclist
 160
 161 # Record breakpoint locations
 162
 163         set breakpoint_file($bpnum) $file
 164         set breakpoint_line($bpnum) $line
 165         set pos_to_breakpoint($file:$line) $bpnum
 166         if ![info exists pos_to_bpcount($file:$line)] {
 167                 set pos_to_bpcount($file:$line) 0
 168         }
 169         incr pos_to_bpcount($file:$line)
 170         set pos_to_breakpoint($pc) $bpnum
 171         if ![info exists pos_to_bpcount($pc)] {
 172                 set pos_to_bpcount($pc) 0
 173         }
 174         incr pos_to_bpcount($pc)
 175
 176 # If there's a window for this file, update it
 177
 178         if [info exists wins($file)] {
 179                 insert_breakpoint_tag $wins($file) $line
 180         }
 181
 182 # If there's an assembly window, update that too
 183
 184         set win [asm_win_name $cfunc]
 185         if [winfo exists $win] {
 186                 insert_breakpoint_tag $win [pc_to_line $pclist($cfunc) $pc]
 187         }
 188 }
 189
 190 #
 191 # Local procedure:
 192 #
 193 #       delete_breakpoint (bpnum file line pc) - Delete breakpoint info from TK land
 194 #
 195 # Description:
 196 #
 197 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
 198 #       land of breakpoint destruction.  This consists of removing the file and
 199 #       line number from the breakpoint_file and breakpoint_line arrays.  Also,
 200 #       if there is already a window associated with FILE, the tags are removed
 201 #       from it.
 202 #
 203
 204 proc delete_breakpoint {bpnum file line pc} {
 205         global wins
 206         global breakpoint_file
 207         global breakpoint_line
 208         global pos_to_breakpoint
 209         global pos_to_bpcount
 210         global cfunc pclist
 211
 212 # Save line number and file for later
 213
 214         set line $breakpoint_line($bpnum)
 215
 216         set file $breakpoint_file($bpnum)
 217
 218 # Reset breakpoint annotation info
 219
 220         if {$pos_to_bpcount($file:$line) > 0} {
 221                 decr pos_to_bpcount($file:$line)
 222
 223                 if {$pos_to_bpcount($file:$line) == 0} {
 224                         catch "unset pos_to_breakpoint($file:$line)"
 225
 226                         unset breakpoint_file($bpnum)
 227                         unset breakpoint_line($bpnum)
 228
 229 # If there's a window for this file, update it
 230
 231                         if [info exists wins($file)] {
 232                                 delete_breakpoint_tag $wins($file) $line
 233                         }
 234                 }
 235         }
 236
 237 # If there's an assembly window, update that too
 238
 239         if {$pos_to_bpcount($pc) > 0} {
 240                 decr pos_to_bpcount($pc)
 241
 242                 if {$pos_to_bpcount($pc) == 0} {
 243                         catch "unset pos_to_breakpoint($pc)"
 244
 245                         set win [asm_win_name $cfunc]
 246                         if [winfo exists $win] {
 247                                 delete_breakpoint_tag $win [pc_to_line $pclist($cfunc) $pc]
 248                         }
 249                 }
 250         }
 251 }
 252
 253 #
 254 # Local procedure:
 255 #
 256 #       enable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
 257 #
 258 # Description:
 259 #
 260 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
 261 #       land of a breakpoint being enabled.  This consists of unstippling the
 262 #       specified breakpoint indicator.
 263 #
 264
 265 proc enable_breakpoint {bpnum file line pc} {
 266         global wins
 267         global cfunc pclist
 268
 269         if [info exists wins($file)] {
 270                 $wins($file) tag configure $line -fgstipple {}
 271         }
 272
 273 # If there's an assembly window, update that too
 274
 275         set win [asm_win_name $cfunc]
 276         if [winfo exists $win] {
 277                 $win tag configure [pc_to_line $pclist($cfunc) $pc] -fgstipple {}
 278         }
 279 }
 280
 281 #
 282 # Local procedure:
 283 #
 284 #       disable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
 285 #
 286 # Description:
 287 #
 288 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
 289 #       land of a breakpoint being disabled.  This consists of stippling the
 290 #       specified breakpoint indicator.
 291 #
 292
 293 proc disable_breakpoint {bpnum file line pc} {
 294         global wins
 295         global cfunc pclist
 296
 297         if [info exists wins($file)] {
 298                 $wins($file) tag configure $line -fgstipple gray50
 299         }
 300
 301 # If there's an assembly window, update that too
 302
 303         set win [asm_win_name $cfunc]
 304         if [winfo exists $win] {
 305                 $win tag configure [pc_to_line $pclist($cfunc) $pc] -fgstipple gray50
 306         }
 307 }
 308
 309 #
 310 # Local procedure:
 311 #
 312 #       insert_breakpoint_tag (win line) - Insert a breakpoint tag in WIN.
 313 #
 314 # Description:
 315 #
 316 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to insert a
 317 #       breakpoint tag into window WIN at line LINE.
 318 #
 319
 320 proc insert_breakpoint_tag {win line} {
 321         $win configure -state normal
 322         $win delete $line.0
 323         $win insert $line.0 "B"
 324         $win tag add $line $line.0
 325         $win tag add delete $line.0 "$line.0 lineend"
 326         $win tag add margin $line.0 "$line.0 lineend"
 327
 328         $win configure -state disabled
 329 }
 330
 331 #
 332 # Local procedure:
 333 #
 334 #       delete_breakpoint_tag (win line) - Remove a breakpoint tag from WIN.
 335 #
 336 # Description:
 337 #
 338 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to remove a
 339 #       breakpoint tag from window WIN at line LINE.
 340 #
 341
 342 proc delete_breakpoint_tag {win line} {
 343         $win configure -state normal
 344         $win delete $line.0
 345         if {[string range $win 0 3] == ".src"} then {
 346                 $win insert $line.0 "\xa4"
 347         } else {
 348                 $win insert $line.0 " "
 349         }
 350         $win tag delete $line
 351         $win tag add delete $line.0 "$line.0 lineend"
 352         $win tag add margin $line.0 "$line.0 lineend"
 353         $win configure -state disabled
 354 }
 355
 356 proc gdbtk_tcl_busy {} {
 357         .src.start configure -state disabled
 358         .src.stop configure -state normal
 359         .src.step configure -state disabled
 360         .src.next configure -state disabled
 361         .src.continue configure -state disabled
 362         .src.finish configure -state disabled
 363         .src.up configure -state disabled
 364         .src.down configure -state disabled
 365         .src.bottom configure -state disabled
 366         .asm.stepi configure -state disabled
 367         .asm.nexti configure -state disabled
 368         .asm.continue configure -state disabled
 369         .asm.finish configure -state disabled
 370         .asm.up configure -state disabled
 371         .asm.down configure -state disabled
 372         .asm.bottom configure -state disabled
 373         .asm.close configure -state disabled
 374 }
 375
 376 proc gdbtk_tcl_idle {} {
 377         .src.start configure -state normal
 378         .src.stop configure -state disabled
 379         .src.step configure -state normal
 380         .src.next configure -state normal
 381         .src.continue configure -state normal
 382         .src.finish configure -state normal
 383         .src.up configure -state normal
 384         .src.down configure -state normal
 385         .src.bottom configure -state normal
 386         .asm.stepi configure -state normal
 387         .asm.nexti configure -state normal
 388         .asm.continue configure -state normal
 389         .asm.finish configure -state normal
 390         .asm.up configure -state normal
 391         .asm.down configure -state normal
 392         .asm.bottom configure -state normal
 393         .asm.close configure -state normal
 394 }
 395
 396 #
 397 # Local procedure:
 398 #
 399 #       decr (var val) - compliment to incr
 400 #
 401 # Description:
 402 #
 403 #
 404 proc decr {var {val 1}} {
 405         upvar $var num
 406         set num [expr $num - $val]
 407         return $num
 408 }
 409
 410 #
 411 # Local procedure:
 412 #
 413 #       pc_to_line (pclist pc) - convert PC to a line number.
 414 #
 415 # Description:
 416 #
 417 #       Convert PC to a line number from PCLIST.  If exact line isn't found,
 418 #       we return the first line that starts before PC.
 419 #
 420 proc pc_to_line {pclist pc} {
 421         set line [lsearch -exact $pclist $pc]
 422
 423         if {$line >= 1} { return $line }
 424
 425         set line 1
 426         foreach linepc [lrange $pclist 1 end] {
 427                 if {$pc < $linepc} { decr line ; return $line }
 428                 incr line
 429         }
 430         return [expr $line - 1]
 431 }
 432
 433 #
 434 # Menu:
 435 #
 436 #       file popup menu - Define the file popup menu.
 437 #
 438 # Description:
 439 #
 440 #       This menu just contains a bunch of buttons that do various things to
 441 #       the line under the cursor.
 442 #
 443 # Items:
 444 #
 445 #       Edit - Run the editor (specified by the environment variable EDITOR) on
 446 #              this file, at the current line.
 447 #       Breakpoint - Set a breakpoint at the current line.  This just shoves
 448 #               a `break' command at GDB with the appropriate file and line
 449 #               number.  Eventually, GDB calls us back (at gdbtk_tcl_breakpoint)
 450 #               to notify us of where the breakpoint needs to show up.
 451 #
 452
 453 menu .file_popup -cursor hand2
 454 .file_popup add command -label "Not yet set" -state disabled
 455 .file_popup add separator
 456 .file_popup add command -label "Edit" -command {exec $editor +$selected_line $selected_file &}
 457 .file_popup add command -label "Set breakpoint" -command {gdb_cmd "break $selected_file:$selected_line"}
 458
 459 #
 460 # Bindings:
 461 #
 462 #       file popup menu - Define the file popup menu bindings.
 463 #
 464 # Description:
 465 #
 466 #       This defines the binding for the file popup menu.  Currently, there is
 467 #       only one, which is activated when Button-1 is released.  This causes
 468 #       the menu to be unposted, releases the grab for the menu, and then
 469 #       unhighlights the line under the cursor.  After that, the selected menu
 470 #       item is invoked.
 471 #
 472
 473 bind .file_popup <Any-ButtonRelease-1> {
 474         global selected_win
 475
 476 # First, remove the menu, and release the pointer
 477
 478         .file_popup unpost
 479         grab release .file_popup
 480
 481 # Unhighlight the selected line
 482
 483         $selected_win tag delete breaktag
 484
 485 # Actually invoke the menubutton here!
 486
 487         tk_invokeMenu %W
 488 }
 489
 490 #
 491 # Local procedure:
 492 #
 493 #       file_popup_menu (win x y xrel yrel) - Popup the file popup menu.
 494 #
 495 # Description:
 496 #
 497 #       This procedure is invoked as a result of a command binding in the
 498 #       listing window.  It does several things:
 499 #               o - It highlights the line under the cursor.
 500 #               o - It pops up the file popup menu which is intended to do
 501 #                   various things to the aforementioned line.
 502 #               o - Grabs the mouse for the file popup menu.
 503 #
 504
 505 # Button 1 has been pressed in a listing window.  Pop up a menu.
 506
 507 proc file_popup_menu {win x y xrel yrel} {
 508         global wins
 509         global win_to_file
 510         global file_to_debug_file
 511         global highlight
 512         global selected_line
 513         global selected_file
 514         global selected_win
 515
 516 # Map TK window name back to file name.
 517
 518         set file $win_to_file($win)
 519
 520         set pos [$win index @$xrel,$yrel]
 521
 522 # Record selected file and line for menu button actions
 523
 524         set selected_file $file_to_debug_file($file)
 525         set selected_line [lindex [split $pos .] 0]
 526         set selected_win $win
 527
 528 # Highlight the selected line
 529
 530         eval $win tag config breaktag $highlight
 531         $win tag add breaktag "$pos linestart" "$pos linestart + 1l"
 532
 533 # Post the menu near the pointer, (and grab it)
 534
 535         .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
 536         .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
 537         grab .file_popup
 538 }
 539
 540 #
 541 # Local procedure:
 542 #
 543 #       listing_window_button_1 (win x y xrel yrel) - Handle button 1 in listing window
 544 #
 545 # Description:
 546 #
 547 #       This procedure is invoked as a result of holding down button 1 in the
 548 #       listing window.  The action taken depends upon where the button was
 549 #       pressed.  If it was in the left margin (the breakpoint column), it
 550 #       sets or clears a breakpoint.  In the main text area, it will pop up a
 551 #       menu.
 552 #
 553
 554 proc listing_window_button_1 {win x y xrel yrel} {
 555         global wins
 556         global win_to_file
 557         global file_to_debug_file
 558         global highlight
 559         global selected_line
 560         global selected_file
 561         global selected_win
 562         global pos_to_breakpoint
 563
 564 # Map TK window name back to file name.
 565
 566         set file $win_to_file($win)
 567
 568         set pos [split [$win index @$xrel,$yrel] .]
 569
 570 # Record selected file and line for menu button actions
 571
 572         set selected_file $file_to_debug_file($file)
 573         set selected_line [lindex $pos 0]
 574         set selected_col [lindex $pos 1]
 575         set selected_win $win
 576
 577 # If we're in the margin, then toggle the breakpoint
 578
 579         if {$selected_col < 8} {
 580                 set pos_break $selected_file:$selected_line
 581                 set pos $file:$selected_line
 582                 set tmp pos_to_breakpoint($pos)
 583                 if [info exists $tmp] {
 584                         set bpnum [set $tmp]
 585                         gdb_cmd "delete $bpnum"
 586                 } else {
 587                         gdb_cmd "break $pos_break"
 588                 }
 589                 return
 590         }
 591
 592 # Post the menu near the pointer, (and grab it)
 593
 594         .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
 595         .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
 596         grab .file_popup
 597 }
 598
 599 #
 600 # Local procedure:
 601 #
 602 #       asm_window_button_1 (win x y xrel yrel) - Handle button 1 in asm window
 603 #
 604 # Description:
 605 #
 606 #       This procedure is invoked as a result of holding down button 1 in the
 607 #       assembly window.  The action taken depends upon where the button was
 608 #       pressed.  If it was in the left margin (the breakpoint column), it
 609 #       sets or clears a breakpoint.  In the main text area, it will pop up a
 610 #       menu.
 611 #
 612
 613 proc asm_window_button_1 {win x y xrel yrel} {
 614         global wins
 615         global win_to_file
 616         global file_to_debug_file
 617         global highlight
 618         global selected_line
 619         global selected_file
 620         global selected_win
 621         global pos_to_breakpoint
 622         global pclist
 623         global cfunc
 624
 625         set pos [split [$win index @$xrel,$yrel] .]
 626
 627 # Record selected file and line for menu button actions
 628
 629         set selected_line [lindex $pos 0]
 630         set selected_col [lindex $pos 1]
 631         set selected_win $win
 632
 633 # Figure out the PC
 634
 635         set pc [lindex $pclist($cfunc) $selected_line]
 636
 637 # If we're in the margin, then toggle the breakpoint
 638
 639         if {$selected_col < 11} {
 640                 set tmp pos_to_breakpoint($pc)
 641                 if [info exists $tmp] {
 642                         set bpnum [set $tmp]
 643                         gdb_cmd "delete $bpnum"
 644                 } else {
 645                         gdb_cmd "break *$pc"
 646                 }
 647                 return
 648         }
 649
 650 # Post the menu near the pointer, (and grab it)
 651
 652 #       .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
 653 #       .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
 654 #       grab .file_popup
 655 }
 656
 657 #
 658 # Local procedure:
 659 #
 660 #       do_nothing - Does absoultely nothing.
 661 #
 662 # Description:
 663 #
 664 #       This procedure does nothing.  It is used as a placeholder to allow
 665 #       the disabling of bindings that would normally be inherited from the
 666 #       parent widget.  I can't think of any other way to do this.
 667 #
 668
 669 proc do_nothing {} {}
 670
 671 #
 672 # Local procedure:
 673 #
 674 #       create_expr_win - Creat expression display window
 675 #
 676 # Description:
 677 #
 678 #       Create the expression display window.
 679 #
 680
 681 proc create_expr_win {} {
 682         toplevel .expr
 683         wm minsize .expr 1 1
 684         wm title .expr Expression
 685         canvas .expr.c -yscrollcommand {.expr.scroll set} -cursor hand2 \
 686                 -borderwidth 2 -relief groove
 687         scrollbar .expr.scroll -orient vertical -command {.expr.c yview}
 688         entry .expr.entry -borderwidth 2 -relief groove
 689
 690         pack .expr.entry -side bottom -fill x
 691         pack .expr.c -side left -fill both -expand yes
 692         pack .expr.scroll -side right -fill y
 693
 694         .expr.c create text 100 0 -text "Text string"
 695         .expr.c create rectangle 245 195 255 205 -outline black -fill white
 696 }
 697
 698 #
 699 # Local procedure:
 700 #
 701 #       display_expression (expression) - Display EXPRESSION in display window
 702 #
 703 # Description:
 704 #
 705 #       Display EXPRESSION and it's value in the expression display window.
 706 #
 707
 708 proc display_expression {expression} {
 709         if ![winfo exists .expr] {create_expr_win}
 710
 711
 712 }
 713
 714 #
 715 # Local procedure:
 716 #
 717 #       create_file_win (filename) - Create a win for FILENAME.
 718 #
 719 # Return value:
 720 #
 721 #       The new text widget.
 722 #
 723 # Description:
 724 #
 725 #       This procedure creates a text widget for FILENAME.  It returns the
 726 #       newly created widget.  First, a text widget is created, and given basic
 727 #       configuration info.  Second, all the bindings are setup.  Third, the
 728 #       file FILENAME is read into the text widget.  Fourth, margins and line
 729 #       numbers are added.
 730 #
 731
 732 proc create_file_win {filename debug_file} {
 733         global breakpoint_file
 734         global breakpoint_line
 735
 736 # Replace all the dirty characters in $filename with clean ones, and generate
 737 # a unique name for the text widget.
 738
 739         regsub -all {\.} $filename {} temp
 740         set win .src.text$temp
 741
 742 # Open the file, and read it into the text widget
 743
 744         if [catch "open $filename" fh] {
 745 # File can't be read.  Put error message into .src.nofile window and return.
 746
 747                 catch {destroy .src.nofile}
 748                 text .src.nofile -height 25 -width 88 -relief raised \
 749                         -borderwidth 2 -yscrollcommand textscrollproc \
 750                         -setgrid true -cursor hand2
 751                 .src.nofile insert 0.0 $fh
 752                 .src.nofile configure -state disabled
 753                 bind .src.nofile <1> do_nothing
 754                 bind .src.nofile <B1-Motion> do_nothing
 755                 return .src.nofile
 756         }
 757
 758 # Actually create and do basic configuration on the text widget.
 759
 760         text $win -height 25 -width 88 -relief raised -borderwidth 2 \
 761                 -yscrollcommand textscrollproc -setgrid true -cursor hand2
 762
 763 # Setup all the bindings
 764
 765         bind $win <Enter> {focus %W}
 766 #       bind $win <1> {listing_window_button_1 %W %X %Y %x %y}
 767         bind $win <1> do_nothing
 768         bind $win <B1-Motion> do_nothing
 769
 770         bind $win n {gdb_cmd next ; update_ptr}
 771         bind $win s {gdb_cmd step ; update_ptr}
 772         bind $win c {gdb_cmd continue ; update_ptr}
 773         bind $win f {gdb_cmd finish ; update_ptr}
 774         bind $win u {gdb_cmd up ; update_ptr}
 775         bind $win d {gdb_cmd down ; update_ptr}
 776
 777         $win delete 0.0 end
 778         $win insert 0.0 [read $fh]
 779         close $fh
 780
 781 # Add margins (for annotations) and a line number to each line
 782
 783         set numlines [$win index end]
 784         set numlines [lindex [split $numlines .] 0]
 785         for {set i 1} {$i <= $numlines} {incr i} {
 786                 $win insert $i.0 [format "   %4d " $i]
 787                 $win tag add source $i.8 "$i.0 lineend"
 788                 }
 789
 790 # Add the breakdots
 791
 792         foreach i [gdb_sourcelines $debug_file] {
 793                 $win delete $i.0
 794                 $win insert $i.0 "\xa4"
 795                 $win tag add margin $i.0 $i.8
 796                 }
 797
 798         $win tag bind margin <1> {listing_window_button_1 %W %X %Y %x %y}
 799         $win tag bind source <1> {
 800                 %W mark set anchor "@%x,%y wordstart"
 801                 set last [%W index "@%x,%y wordend"]
 802                 %W tag remove sel 0.0 anchor
 803                 %W tag remove sel $last end
 804                 %W tag add sel anchor $last
 805                 }
 806 #       $win tag bind source <Double-Button-1> {
 807 #               %W mark set anchor "@%x,%y wordstart"
 808 #               set last [%W index "@%x,%y wordend"]
 809 #               %W tag remove sel 0.0 anchor
 810 #               %W tag remove sel $last end
 811 #               %W tag add sel anchor $last
 812 #               echo "Selected [selection get]"
 813 #               }
 814         $win tag bind source <B1-Motion> {
 815                 %W tag remove sel 0.0 anchor
 816                 %W tag remove sel $last end
 817                 %W tag add sel anchor @%x,%y
 818                 }
 819         $win tag bind sel <1> do_nothing
 820         $win tag bind sel <Double-Button-1> {display_expression [selection get]}
 821         $win tag raise sel
 822
 823
 824 # Scan though the breakpoint data base and install any destined for this file
 825
 826         foreach bpnum [array names breakpoint_file] {
 827                 if {$breakpoint_file($bpnum) == $filename} {
 828                         insert_breakpoint_tag $win $breakpoint_line($bpnum)
 829                         }
 830                 }
 831
 832 # Disable the text widget to prevent user modifications
 833
 834         $win configure -state disabled
 835         return $win
 836 }
 837
 838 #
 839 # Local procedure:
 840 #
 841 #       create_asm_win (funcname pc) - Create an assembly win for FUNCNAME.
 842 #
 843 # Return value:
 844 #
 845 #       The new text widget.
 846 #
 847 # Description:
 848 #
 849 #       This procedure creates a text widget for FUNCNAME.  It returns the
 850 #       newly created widget.  First, a text widget is created, and given basic
 851 #       configuration info.  Second, all the bindings are setup.  Third, the
 852 #       function FUNCNAME is read into the text widget.
 853 #
 854
 855 proc create_asm_win {funcname pc} {
 856         global breakpoint_file
 857         global breakpoint_line
 858         global current_output_win
 859         global pclist
 860
 861 # Replace all the dirty characters in $filename with clean ones, and generate
 862 # a unique name for the text widget.
 863
 864         set win [asm_win_name $funcname]
 865
 866 # Actually create and do basic configuration on the text widget.
 867
 868         text $win -height 25 -width 88 -relief raised -borderwidth 2 \
 869                 -setgrid true -cursor hand2 -yscrollcommand asmscrollproc
 870
 871 # Setup all the bindings
 872
 873         bind $win <Enter> {focus %W}
 874         bind $win <1> {asm_window_button_1 %W %X %Y %x %y}
 875         bind $win <B1-Motion> do_nothing
 876         bind $win n {gdb_cmd nexti ; update_ptr}
 877         bind $win s {gdb_cmd stepi ; update_ptr}
 878         bind $win c {gdb_cmd continue ; update_ptr}
 879         bind $win f {gdb_cmd finish ; update_ptr}
 880         bind $win u {gdb_cmd up ; update_ptr}
 881         bind $win d {gdb_cmd down ; update_ptr}
 882
 883 # Disassemble the code, and read it into the new text widget
 884
 885         set temp $current_output_win
 886         set current_output_win $win
 887         gdb_cmd "disassemble $pc"
 888         set current_output_win $temp
 889
 890         set numlines [$win index end]
 891         set numlines [lindex [split $numlines .] 0]
 892         decr numlines
 893
 894 # Delete the first and last lines, cuz these contain useless info
 895
 896         $win delete 1.0 2.0
 897         $win delete {end - 1 lines} end
 898         decr numlines 2
 899
 900 # Add margins (for annotations) and note the PC for each line
 901
 902         catch "unset pclist($funcname)"
 903         lappend pclist($funcname) Unused
 904         for {set i 1} {$i <= $numlines} {incr i} {
 905                 scan [$win get $i.0 "$i.0 lineend"] "%s " pc
 906                 lappend pclist($funcname) $pc
 907                 $win insert $i.0 "    "
 908                 }
 909
 910
 911 # Scan though the breakpoint data base and install any destined for this file
 912
 913 #       foreach bpnum [array names breakpoint_file] {
 914 #               if {$breakpoint_file($bpnum) == $filename} {
 915 #                       insert_breakpoint_tag $win $breakpoint_line($bpnum)
 916 #                       }
 917 #               }
 918
 919 # Disable the text widget to prevent user modifications
 920
 921         $win configure -state disabled
 922         return $win
 923 }
 924
 925 #
 926 # Local procedure:
 927 #
 928 #       asmscrollproc (WINHEIGHT SCREENHEIGHT SCREENTOP SCREENBOT) - Update the
 929 #       asm window scrollbar.
 930 #
 931 # Description:
 932 #
 933 #       This procedure is called to update the assembler window's scrollbar.
 934 #
 935
 936 proc asmscrollproc {args} {
 937         global asm_screen_height asm_screen_top asm_screen_bot
 938
 939         eval ".asm.scroll set $args"
 940         set asm_screen_height [lindex $args 1]
 941         set asm_screen_top [lindex $args 2]
 942         set asm_screen_bot [lindex $args 3]
 943 }
 944
 945 #
 946 # Local procedure:
 947 #
 948 #       update_listing (linespec) - Update the listing window according to
 949 #                                   LINESPEC.
 950 #
 951 # Description:
 952 #
 953 #       This procedure is called from various places to update the listing
 954 #       window based on LINESPEC.  It is usually invoked with the result of
 955 #       gdb_loc.
 956 #
 957 #       It will move the cursor, and scroll the text widget if necessary.
 958 #       Also, it will switch to another text widget if necessary, and update
 959 #       the label widget too.
 960 #
 961 #       LINESPEC is a list of the form:
 962 #
 963 #       { DEBUG_FILE FUNCNAME FILENAME LINE }, where:
 964 #
 965 #       DEBUG_FILE - is the abbreviated form of the file name.  This is usually
 966 #                    the file name string given to the cc command.  This is
 967 #                    primarily needed for breakpoint commands, and when an
 968 #                    abbreviated for of the filename is desired.
 969 #       FUNCNAME - is the name of the function.
 970 #       FILENAME - is the fully qualified (absolute) file name.  It is usually
 971 #                  the same as $PWD/$DEBUG_FILE, where PWD is the working dir
 972 #                  at the time the cc command was given.  This is used to
 973 #                  actually locate the file to be displayed.
 974 #       LINE - The line number to be displayed.
 975 #
 976 #       Usually, this procedure will just move the cursor one line down to the
 977 #       next line to be executed.  However, if the cursor moves out of range
 978 #       or into another file, it will scroll the text widget so that the line
 979 #       of interest is in the middle of the viewable portion of the widget.
 980 #
 981
 982 proc update_listing {linespec} {
 983         global pointers
 984         global screen_height
 985         global screen_top
 986         global screen_bot
 987         global wins cfile
 988         global current_label
 989         global win_to_file
 990         global file_to_debug_file
 991         global .src.label
 992
 993 # Rip the linespec apart
 994
 995         set line [lindex $linespec 3]
 996         set filename [lindex $linespec 2]
 997         set funcname [lindex $linespec 1]
 998         set debug_file [lindex $linespec 0]
 999
1000 # Sometimes there's no source file for this location
1001
1002         if {$filename == ""} {set filename Blank}
1003
1004 # If we want to switch files, we need to unpack the current text widget, and
1005 # stick in the new one.
1006
1007         if {$filename != $cfile} then {
1008                 pack forget $wins($cfile)
1009                 set cfile $filename
1010
1011 # Create a text widget for this file if necessary
1012
1013                 if ![info exists wins($cfile)] then {
1014                         set wins($cfile) [create_file_win $cfile $debug_file]
1015                         if {$wins($cfile) != ".src.nofile"} {
1016                                 set win_to_file($wins($cfile)) $cfile
1017                                 set file_to_debug_file($cfile) $debug_file
1018                                 set pointers($cfile) 1.1
1019                                 }
1020                         }
1021
1022 # Pack the text widget into the listing widget, and scroll to the right place
1023
1024                 pack $wins($cfile) -side left -expand yes -in .src.info \
1025                         -fill both -after .src.scroll
1026
1027 # Make the scrollbar point at the new text widget
1028
1029                 .src.scroll configure -command "$wins($cfile) yview"
1030
1031                 $wins($cfile) yview [expr $line - $screen_height / 2]
1032                 }
1033
1034 # Update the label widget in case the filename or function name has changed
1035
1036         if {$current_label != "$filename.$funcname"} then {
1037                 set tail [expr [string last / $filename] + 1]
1038                 set .src.label "[string range $filename $tail end] : ${funcname}()"
1039 #               .src.label configure -text "[string range $filename $tail end] : ${funcname}()"
1040                 set current_label $filename.$funcname
1041                 }
1042
1043 # Update the pointer, scrolling the text widget if necessary to keep the
1044 # pointer in an acceptable part of the screen.
1045
1046         if [info exists pointers($cfile)] then {
1047                 $wins($cfile) configure -state normal
1048                 set pointer_pos $pointers($cfile)
1049                 $wins($cfile) configure -state normal
1050                 $wins($cfile) delete $pointer_pos "$pointer_pos + 2 char"
1051                 $wins($cfile) insert $pointer_pos "  "
1052
1053                 set pointer_pos [$wins($cfile) index $line.1]
1054                 set pointers($cfile) $pointer_pos
1055
1056                 $wins($cfile) delete $pointer_pos "$pointer_pos + 2 char"
1057                 $wins($cfile) insert $pointer_pos "->"
1058
1059                 if {$line < $screen_top + 1
1060                     || $line > $screen_bot} then {
1061                         $wins($cfile) yview [expr $line - $screen_height / 2]
1062                         }
1063
1064                 $wins($cfile) configure -state disabled
1065                 }
1066 }
1067
1068 #
1069 # Local procedure:
1070 #
1071 #       create_asm_window - Open up the assembly window.
1072 #
1073 # Description:
1074 #
1075 #       Create an assembly window if it doesn't exist.
1076 #
1077
1078 proc create_asm_window {} {
1079         global cfunc
1080
1081         if ![winfo exists .asm] {
1082                 set cfunc *None*
1083                 set win [asm_win_name $cfunc]
1084
1085                 build_framework .asm Assembly "*NIL*"
1086
1087                 .asm.text configure -yscrollcommand asmscrollproc
1088
1089                 frame .asm.row1
1090                 frame .asm.row2
1091
1092                 button .asm.stepi -width 6 -text Stepi \
1093                         -command {gdb_cmd stepi ; update_ptr}
1094                 button .asm.nexti -width 6 -text Nexti \
1095                         -command {gdb_cmd nexti ; update_ptr}
1096                 button .asm.continue -width 6 -text Cont \
1097                         -command {gdb_cmd continue ; update_ptr}
1098                 button .asm.finish -width 6 -text Finish \
1099                         -command {gdb_cmd finish ; update_ptr}
1100                 button .asm.up -width 6 -text Up -command {gdb_cmd up ; update_ptr}
1101                 button .asm.down -width 6 -text Down \
1102                         -command {gdb_cmd down ; update_ptr}
1103                 button .asm.bottom -width 6 -text Bottom \
1104                         -command {gdb_cmd {frame 0} ; update_ptr}
1105
1106                 pack .asm.stepi .asm.continue .asm.up .asm.bottom -side left -padx 3 -pady 5 -in .asm.row1
1107                 pack .asm.nexti .asm.finish .asm.down -side left -padx 3 -pady 5 -in .asm.row2
1108
1109                 pack .asm.row1 .asm.row2 -side top -anchor w
1110
1111                 update
1112
1113                 pack forget .asm.text
1114
1115                 update_assembly [gdb_loc]
1116         }
1117 }
1118
1119 proc reg_config_menu {} {
1120         global reg_format
1121
1122         catch {destroy .reg.config}
1123         toplevel .reg.config
1124         wm geometry .reg.config +300+300
1125         wm title .reg.config "Register configuration"
1126         wm iconname .reg.config "Reg config"
1127         set regnames [gdb_regnames]
1128         set num_regs [llength $regnames]
1129
1130         button .reg.config.done -text Done -command {destroy .reg.config}
1131
1132         pack .reg.config.done -side bottom -fill x
1133
1134 # Since there can be lots of registers, we build the window with no more than
1135 # 32 rows, and as many columns as needed.
1136
1137 # First, figure out how many columns we need and create that many column frame
1138 # widgets
1139
1140         set ncols [expr ($num_regs + 31) / 32]
1141
1142         for {set col 0} {$col < $ncols} {incr col} {
1143                 frame .reg.config.col$col
1144                 pack .reg.config.col$col -side left -anchor n
1145         }
1146
1147 # Now, create the checkbutton widgets and pack them in the appropriate columns
1148
1149         set col 0
1150         set row 0
1151         for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
1152                 set regname [lindex $regnames $regnum]
1153                 checkbutton .reg.config.col$col.$row -text $regname -pady 0 \
1154                         -variable regena($regnum) -relief flat -anchor w -bd 1 \
1155                         -command "recompute_reg_display_list $num_regs
1156                                   populate_reg_window
1157                                   update_registers all"
1158
1159                 pack .reg.config.col$col.$row -side top -fill both
1160
1161                 incr row
1162                 if {$row >= 32} {
1163                         incr col
1164                         set row 0
1165                 }
1166         }
1167 }
1168
1169 #
1170 # Local procedure:
1171 #
1172 #       create_registers_window - Open up the register display window.
1173 #
1174 # Description:
1175 #
1176 #       Create the register display window, with automatic updates.
1177 #
1178
1179 proc create_registers_window {} {
1180         global reg_format
1181
1182         if [winfo exists .reg] return
1183
1184 # Create an initial register display list consisting of all registers
1185
1186         if ![info exists reg_format] {
1187                 global reg_display_list
1188                 global changed_reg_list
1189                 global regena
1190
1191                 set reg_format {}
1192                 set num_regs [llength [gdb_regnames]]
1193                 for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
1194                         set regena($regnum) 1
1195                 }
1196                 recompute_reg_display_list $num_regs
1197                 set changed_reg_list $reg_display_list
1198         }
1199
1200         build_framework .reg Registers
1201
1202         .reg.menubar.view.menu add command -label Natural
1203         .reg.menubar.view.menu add command -label Config -command {
1204                 reg_config_menu }
1205
1206 # Hex menu item
1207         .reg.menubar.view.menu entryconfigure 0 -command {
1208                 global reg_format
1209
1210                 set reg_format x
1211                 update_registers all
1212         }
1213 # Decimal menu item
1214         .reg.menubar.view.menu entryconfigure 1 -command {
1215                 global reg_format
1216
1217                 set reg_format d
1218                 update_registers all
1219         }
1220 # Octal menu item
1221         .reg.menubar.view.menu entryconfigure 2 -command {
1222                 global reg_format
1223
1224                 set reg_format o
1225                 update_registers all
1226         }
1227 # Natural menu item
1228         .reg.menubar.view.menu entryconfigure 3 -command {
1229                 global reg_format
1230
1231                 set reg_format {}
1232                 update_registers all
1233         }
1234
1235         destroy .reg.label
1236
1237 # Install the reg names
1238
1239         populate_reg_window
1240 }
1241
1242 # Convert regena into a list of the enabled $regnums
1243
1244 proc recompute_reg_display_list {num_regs} {
1245         global reg_display_list
1246         global regmap
1247         global regena
1248
1249         catch {unset reg_display_list}
1250
1251         set line 1
1252         for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
1253
1254                 if {[set regena($regnum)] != 0} {
1255                         lappend reg_display_list $regnum
1256                         set regmap($regnum) $line
1257                         incr line
1258                 }
1259         }
1260 }
1261
1262 # Fill out the register window with the names of the regs specified in
1263 # reg_display_list.
1264
1265 proc populate_reg_window {} {
1266         global max_regname_width
1267         global reg_display_list
1268
1269         .reg.text configure -state normal
1270
1271         .reg.text delete 0.0 end
1272
1273         set regnames [eval gdb_regnames $reg_display_list]
1274
1275 # Figure out the longest register name
1276
1277         set max_regname_width 0
1278
1279         foreach reg $regnames {
1280                 set len [string length $reg]
1281                 if {$len > $max_regname_width} {set max_regname_width $len}
1282         }
1283
1284         set width [expr $max_regname_width + 15]
1285
1286         set height [llength $regnames]
1287
1288         if {$height > 60} {set height 60}
1289
1290         .reg.text configure -height $height -width $width
1291
1292         foreach reg $regnames {
1293                 .reg.text insert end [format "%-*s \n" $max_regname_width ${reg}]
1294         }
1295
1296         .reg.text yview 0
1297         .reg.text configure -state disabled
1298 }
1299
1300 #
1301 # Local procedure:
1302 #
1303 #       update_registers - Update the registers window.
1304 #
1305 # Description:
1306 #
1307 #       This procedure updates the registers window.
1308 #
1309
1310 proc update_registers {which} {
1311         global max_regname_width
1312         global reg_format
1313         global reg_display_list
1314         global changed_reg_list
1315         global highlight
1316         global regmap
1317
1318         set margin [expr $max_regname_width + 1]
1319         set win .reg.text
1320         set winwidth [lindex [$win configure -width] 4]
1321         set valwidth [expr $winwidth - $margin]
1322
1323         $win configure -state normal
1324
1325         if {$which == "all"} {
1326                 set lineindex 1
1327                 foreach regnum $reg_display_list {
1328                         set regval [gdb_fetch_registers $reg_format $regnum]
1329                         set regval [format "%-*s" $valwidth $regval]
1330                         $win delete $lineindex.$margin "$lineindex.0 lineend"
1331                         $win insert $lineindex.$margin $regval
1332                         incr lineindex
1333                 }
1334                 $win configure -state disabled
1335                 return
1336         }
1337
1338 # Unhighlight the old values
1339
1340         foreach regnum $changed_reg_list {
1341                 $win tag delete $win.$regnum
1342         }
1343
1344 # Now, highlight the changed values of the interesting registers
1345
1346         set changed_reg_list [eval gdb_changed_register_list $reg_display_list]
1347
1348         set lineindex 1
1349         foreach regnum $changed_reg_list {
1350                 set regval [gdb_fetch_registers $reg_format $regnum]
1351                 set regval [format "%-*s" $valwidth $regval]
1352
1353                 set lineindex $regmap($regnum)
1354                 $win delete $lineindex.$margin "$lineindex.0 lineend"
1355                 $win insert $lineindex.$margin $regval
1356                 $win tag add $win.$regnum $lineindex.0 "$lineindex.0 lineend"
1357                 eval $win tag configure $win.$regnum $highlight
1358         }
1359
1360         $win configure -state disabled
1361 }
1362
1363 #
1364 # Local procedure:
1365 #
1366 #       update_assembly - Update the assembly window.
1367 #
1368 # Description:
1369 #
1370 #       This procedure updates the assembly window.
1371 #
1372
1373 proc update_assembly {linespec} {
1374         global asm_pointers
1375         global screen_height
1376         global screen_top
1377         global screen_bot
1378         global wins cfunc
1379         global current_label
1380         global win_to_file
1381         global file_to_debug_file
1382         global current_asm_label
1383         global pclist
1384         global asm_screen_height asm_screen_top asm_screen_bot
1385         global .asm.label
1386
1387 # Rip the linespec apart
1388
1389         set pc [lindex $linespec 4]
1390         set line [lindex $linespec 3]
1391         set filename [lindex $linespec 2]
1392         set funcname [lindex $linespec 1]
1393         set debug_file [lindex $linespec 0]
1394
1395         set win [asm_win_name $cfunc]
1396
1397 # Sometimes there's no source file for this location
1398
1399         if {$filename == ""} {set filename Blank}
1400
1401 # If we want to switch funcs, we need to unpack the current text widget, and
1402 # stick in the new one.
1403
1404         if {$funcname != $cfunc } {
1405                 pack forget $win
1406                 set cfunc $funcname
1407
1408                 set win [asm_win_name $cfunc]
1409
1410 # Create a text widget for this func if necessary
1411
1412                 if {![winfo exists $win]} {
1413                         create_asm_win $cfunc $pc
1414                         set asm_pointers($cfunc) 1.1
1415                         set current_asm_label NIL
1416                         }
1417
1418 # Pack the text widget, and scroll to the right place
1419
1420                 pack $win -side left -expand yes -fill both \
1421                         -after .asm.scroll
1422                 .asm.scroll configure -command "$win yview"
1423                 set line [pc_to_line $pclist($cfunc) $pc]
1424                 $win yview [expr $line - $asm_screen_height / 2]
1425                 }
1426
1427 # Update the label widget in case the filename or function name has changed
1428
1429         if {$current_asm_label != "$pc $funcname"} then {
1430                 set .asm.label "$pc $funcname"
1431 #               .asm.label configure -text "$pc $funcname"
1432                 set current_asm_label "$pc $funcname"
1433                 }
1434
1435 # Update the pointer, scrolling the text widget if necessary to keep the
1436 # pointer in an acceptable part of the screen.
1437
1438         if [info exists asm_pointers($cfunc)] then {
1439                 $win configure -state normal
1440                 set pointer_pos $asm_pointers($cfunc)
1441                 $win configure -state normal
1442                 $win delete $pointer_pos "$pointer_pos + 2 char"
1443                 $win insert $pointer_pos "  "
1444
1445 # Map the PC back to a line in the window
1446
1447                 set line [pc_to_line $pclist($cfunc) $pc]
1448
1449                 if {$line == -1} {
1450                         echo "Can't find PC $pc"
1451                         return
1452                         }
1453
1454                 set pointer_pos [$win index $line.1]
1455                 set asm_pointers($cfunc) $pointer_pos
1456
1457                 $win delete $pointer_pos "$pointer_pos + 2 char"
1458                 $win insert $pointer_pos "->"
1459
1460                 if {$line < $asm_screen_top + 1
1461                     || $line > $asm_screen_bot} then {
1462                         $win yview [expr $line - $asm_screen_height / 2]
1463                         }
1464
1465 #               echo "Picking line $line"
1466 #               $win yview -pickplace $line
1467
1468                 $win configure -state disabled
1469                 }
1470 }
1471
1472 #
1473 # Local procedure:
1474 #
1475 #       update_ptr - Update the listing window.
1476 #
1477 # Description:
1478 #
1479 #       This routine will update the listing window using the result of
1480 #       gdb_loc.
1481 #
1482
1483 proc update_ptr {} {
1484         update_listing [gdb_loc]
1485         if [winfo exists .asm] {
1486                 update_assembly [gdb_loc]
1487         }
1488         if [winfo exists .reg] {
1489                 update_registers changed
1490         }
1491 }
1492
1493 # Make toplevel window disappear
1494
1495 wm withdraw .
1496
1497 proc files_command {} {
1498         toplevel .files_window
1499
1500         wm minsize .files_window 1 1
1501 #       wm overrideredirect .files_window true
1502         listbox .files_window.list -geometry 30x20 -setgrid true
1503         button .files_window.close -text Close -command {destroy .files_window}
1504         tk_listboxSingleSelect .files_window.list
1505         eval .files_window.list insert 0 [lsort [gdb_listfiles]]
1506         pack .files_window.list -side top -fill both -expand yes
1507         pack .files_window.close -side bottom -fill x -expand no -anchor s
1508         bind .files_window.list <Any-ButtonRelease-1> {
1509                 set file [%W get [%W curselection]]
1510                 gdb_cmd "list $file:1,0"
1511                 update_listing [gdb_loc $file:1]
1512                 destroy .files_window}
1513 }
1514
1515 button .files -text Files -command files_command
1516
1517 # Setup command window
1518
1519 proc build_framework {win {title GDBtk} {label {}}} {
1520         global ${win}.label
1521
1522         toplevel ${win}
1523         wm title ${win} $title
1524         wm minsize ${win} 1 1
1525
1526         frame ${win}.menubar
1527
1528         menubutton ${win}.menubar.file -padx 12 -text File \
1529                 -menu ${win}.menubar.file.menu -underline 0
1530
1531         menu ${win}.menubar.file.menu
1532         ${win}.menubar.file.menu add command -label Edit \
1533                 -command {exec $editor +[expr ($screen_top + $screen_bot)/2] $cfile &}
1534         ${win}.menubar.file.menu add command -label Close \
1535                 -command "destroy ${win}"
1536         ${win}.menubar.file.menu add command -label Quit \
1537                 -command {gdb_cmd quit}
1538
1539         menubutton ${win}.menubar.view -padx 12 -text View \
1540                 -menu ${win}.menubar.view.menu -underline 0
1541
1542         menu ${win}.menubar.view.menu
1543         ${win}.menubar.view.menu add command -label Hex -command {echo Hex}
1544         ${win}.menubar.view.menu add command -label Decimal \
1545                 -command {echo Decimal}
1546         ${win}.menubar.view.menu add command -label Octal -command {echo Octal}
1547
1548         menubutton ${win}.menubar.window -padx 12 -text Window \
1549                 -menu ${win}.menubar.window.menu -underline 0
1550
1551         menu ${win}.menubar.window.menu
1552         ${win}.menubar.window.menu add command -label Source \
1553                 -command {echo Source}
1554         ${win}.menubar.window.menu add command -label Command \
1555                 -command {echo Command}
1556         ${win}.menubar.window.menu add command -label Assembly \
1557                 -command {create_asm_window ; update_ptr}
1558         ${win}.menubar.window.menu add command -label Register \
1559                 -command {create_registers_window ; update_ptr}
1560
1561         menubutton ${win}.menubar.help -padx 12 -text Help \
1562                 -menu ${win}.menubar.help.menu -underline 0
1563
1564         menu ${win}.menubar.help.menu
1565         ${win}.menubar.help.menu add command -label "with GDBtk" \
1566                 -command {echo "with GDBtk"}
1567         ${win}.menubar.help.menu add command -label "with this window" \
1568                 -command {echo "with this window"}
1569         ${win}.menubar.help.menu add command -label "Report bug" \
1570                 -command {exec send-pr}
1571
1572         tk_menuBar ${win}.menubar ${win}.menubar.file ${win}.menubar.view \
1573                 ${win}.menubar.window ${win}.menubar.help
1574         pack ${win}.menubar.file ${win}.menubar.view ${win}.menubar.window \
1575                 -side left
1576         pack ${win}.menubar.help -side right
1577
1578         frame ${win}.info
1579         text ${win}.text -height 25 -width 80 -relief raised -borderwidth 2 \
1580                 -setgrid true -cursor hand2 -yscrollcommand "${win}.scroll set"
1581
1582         set ${win}.label $label
1583         label ${win}.label -textvariable ${win}.label -borderwidth 2 -relief raised
1584
1585         scrollbar ${win}.scroll -orient vertical -command "${win}.text yview"
1586
1587         pack ${win}.label -side bottom -fill x -in ${win}.info
1588         pack ${win}.scroll -side right -fill y -in ${win}.info
1589         pack ${win}.text -side left -expand yes -fill both -in ${win}.info
1590
1591         pack ${win}.menubar -side top -fill x
1592         pack ${win}.info -side top -fill both -expand yes
1593 }
1594
1595 proc create_source_window {} {
1596         global wins
1597         global cfile
1598
1599         build_framework .src Source "*No file*"
1600
1601         frame .src.row1
1602         frame .src.row2
1603
1604         button .src.start -width 6 -text Start -command \
1605                 {gdb_cmd {break main}
1606                  gdb_cmd {enable delete $bpnum}
1607                  gdb_cmd run
1608                  update_ptr }
1609         button .src.stop -width 6 -text Stop -fg red -activeforeground red \
1610                 -state disabled -command gdb_stop
1611         button .src.step -width 6 -text Step \
1612                 -command {gdb_cmd step ; update_ptr}
1613         button .src.next -width 6 -text Next \
1614                 -command {gdb_cmd next ; update_ptr}
1615         button .src.continue -width 6 -text Cont \
1616                 -command {gdb_cmd continue ; update_ptr}
1617         button .src.finish -width 6 -text Finish \
1618                 -command {gdb_cmd finish ; update_ptr}
1619         button .src.up -width 6 -text Up -command {gdb_cmd up ; update_ptr}
1620         button .src.down -width 6 -text Down \
1621                 -command {gdb_cmd down ; update_ptr}
1622         button .src.bottom -width 6 -text Bottom \
1623                 -command {gdb_cmd {frame 0} ; update_ptr}
1624
1625         pack .src.start .src.step .src.continue .src.up .src.bottom \
1626                 -side left -padx 3 -pady 5 -in .src.row1
1627         pack .src.stop .src.next .src.finish .src.down -side left -padx 3 \
1628                 -pady 5 -in .src.row2
1629
1630         pack .src.row1 .src.row2 -side top -anchor w
1631
1632         $wins($cfile) insert 0.0 "  This page intentionally left blank."
1633         $wins($cfile) configure -width 88 -state disabled \
1634                 -yscrollcommand textscrollproc
1635
1636         proc textscrollproc {args} {global screen_height screen_top screen_bot
1637                                     eval ".src.scroll set $args"
1638                                     set screen_height [lindex $args 1]
1639                                     set screen_top [lindex $args 2]
1640                                     set screen_bot [lindex $args 3]}
1641 }
1642
1643 proc create_command_window {} {
1644         global command_line
1645
1646         build_framework .cmd Command "* Command Buffer *"
1647
1648         set command_line {}
1649
1650         gdb_cmd {set language c}
1651         gdb_cmd {set height 0}
1652         gdb_cmd {set width 0}
1653
1654         bind .cmd.text <Enter> {focus %W}
1655         bind .cmd.text <Delete> {delete_char %W}
1656         bind .cmd.text <BackSpace> {delete_char %W}
1657         bind .cmd.text <Control-u> {delete_line %W}
1658         bind .cmd.text <Any-Key> {
1659                 global command_line
1660
1661                 %W insert end %A
1662                 %W yview -pickplace end
1663                 append command_line %A
1664                 }
1665         bind .cmd.text <Key-Return> {
1666                 global command_line
1667
1668                 %W insert end \n
1669                 %W yview -pickplace end
1670                 gdb_cmd $command_line
1671                 set command_line {}
1672                 update_ptr
1673                 %W insert end "(gdb) "
1674                 %W yview -pickplace end
1675                 }
1676
1677         proc delete_char {win} {
1678                 global command_line
1679
1680                 tk_textBackspace $win
1681                 $win yview -pickplace insert
1682                 set tmp [expr [string length $command_line] - 2]
1683                 set command_line [string range $command_line 0 $tmp]
1684         }
1685
1686         proc delete_line {win} {
1687                 global command_line
1688
1689                 $win delete {end linestart + 6 chars} end
1690                 $win yview -pickplace insert
1691                 set command_line {}
1692         }
1693 }
1694
1695 # Setup the initial windows
1696
1697 create_source_window
1698
1699 if {[tk colormodel .src.text] == "color"} {
1700         set highlight "-background red2 -borderwidth 2 -relief sunk"
1701 } else {
1702         set fg [lindex [.src.text config -foreground] 4]
1703         set bg [lindex [.src.text config -background] 4]
1704         set highlight "-foreground $bg -background $fg -borderwidth 0"
1705 }
1706
1707 create_command_window
1708 update