gdb/gdbtk.tcl

   1 # GDB GUI setup
   2
   3 set cfile Blank
   4 set wins($cfile) .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 .command.text
  10 set cfunc NIL
  11 option add *Foreground White
  12 option add *Background Blue
  13
  14 proc echo string {puts stdout $string}
  15
  16 if [info exists env(EDITOR)] then {
  17         set editor $env(EDITOR)
  18         } else {
  19         set editor emacs
  20 }
  21
  22 # GDB callbacks
  23 #
  24 #  These functions are called by GDB (from C code) to do various things in
  25 #  TK-land.  All start with the prefix `gdbtk_tcl_' to make them easy to find.
  26 #
  27
  28 #
  29 # GDB Callback:
  30 #
  31 #       gdbtk_tcl_fputs (text) - Output text to the command window
  32 #
  33 # Description:
  34 #
  35 #       GDB calls this to output TEXT to the GDB command window.  The text is
  36 #       placed at the end of the text widget.  Note that output may not occur,
  37 #       due to buffering.  Use gdbtk_tcl_flush to cause an immediate update.
  38 #
  39
  40 proc gdbtk_tcl_fputs {arg} {
  41         global current_output_win
  42
  43         $current_output_win insert end "$arg"
  44         $current_output_win yview -pickplace end
  45 }
  46
  47 #
  48 # GDB Callback:
  49 #
  50 #       gdbtk_tcl_flush () - Flush output to the command window
  51 #
  52 # Description:
  53 #
  54 #       GDB calls this to force all buffered text to the GDB command window.
  55 #
  56
  57 proc gdbtk_tcl_flush {} {
  58         $current_output_win yview -pickplace end
  59         update idletasks
  60 }
  61
  62 #
  63 # GDB Callback:
  64 #
  65 #       gdbtk_tcl_query (message) - Create a yes/no query dialog box
  66 #
  67 # Description:
  68 #
  69 #       GDB calls this to create a yes/no dialog box containing MESSAGE.  GDB
  70 #       is hung while the dialog box is active (ie: no commands will work),
  71 #       however windows can still be refreshed in case of damage or exposure.
  72 #
  73
  74 proc gdbtk_tcl_query {message} {
  75         tk_dialog .query "gdb : query" "$message" {} 1 "No" "Yes"
  76         }
  77
  78 #
  79 # GDB Callback:
  80 #
  81 #       gdbtk_start_variable_annotation (args ...) -
  82 #
  83 # Description:
  84 #
  85 #       Not yet implemented.
  86 #
  87
  88 proc gdbtk_tcl_start_variable_annotation {valaddr ref_type stor_cl cum_expr field type_cast} {
  89         echo "gdbtk_tcl_start_variable_annotation $valaddr $ref_type $stor_cl $cum_expr $field $type_cast"
  90 }
  91
  92 #
  93 # GDB Callback:
  94 #
  95 #       gdbtk_end_variable_annotation (args ...) -
  96 #
  97 # Description:
  98 #
  99 #       Not yet implemented.
 100 #
 101
 102 proc gdbtk_tcl_end_variable_annotation {} {
 103         echo gdbtk_tcl_end_variable_annotation
 104 }
 105
 106 #
 107 # GDB Callback:
 108 #
 109 #       gdbtk_tcl_breakpoint (action bpnum file line) - Notify the TK
 110 #       interface of changes to breakpoints.
 111 #
 112 # Description:
 113 #
 114 #       GDB calls this to notify TK of changes to breakpoints.  ACTION is one
 115 #       of:
 116 #               create          - Notify of breakpoint creation
 117 #               delete          - Notify of breakpoint deletion
 118 #               enable          - Notify of breakpoint enabling
 119 #               disable         - Notify of breakpoint disabling
 120 #
 121 #       All actions take the same set of arguments:  BPNUM is the breakpoint
 122 #       number,  FILE is the source file and LINE is the line number, and PC is
 123 #       the pc of the affected breakpoint.
 124 #
 125
 126 proc gdbtk_tcl_breakpoint {action bpnum file line pc} {
 127         ${action}_breakpoint $bpnum $file $line $pc
 128 }
 129
 130 proc asm_win_name {funcname} {
 131         regsub -all {\.} $funcname _ temp
 132
 133         return .asm.func_${temp}
 134 }
 135
 136 #
 137 # Local procedure:
 138 #
 139 #       create_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
 140 #
 141 # Description:
 142 #
 143 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
 144 #       land of breakpoint creation.  This consists of recording the file and
 145 #       line number in the breakpoint_file and breakpoint_line arrays.  Also,
 146 #       if there is already a window associated with FILE, it is updated with
 147 #       a breakpoint tag.
 148 #
 149
 150 proc create_breakpoint {bpnum file line pc} {
 151         global wins
 152         global breakpoint_file
 153         global breakpoint_line
 154         global pos_to_breakpoint
 155         global pos_to_bpcount
 156         global cfunc
 157         global pclist
 158
 159 # Record breakpoint locations
 160
 161         set breakpoint_file($bpnum) $file
 162         set breakpoint_line($bpnum) $line
 163         set pos_to_breakpoint($file:$line) $bpnum
 164         if ![info exists pos_to_bpcount($file:$line)] {
 165                 set pos_to_bpcount($file:$line) 0
 166         }
 167         incr pos_to_bpcount($file:$line)
 168         set pos_to_breakpoint($pc) $bpnum
 169         if ![info exists pos_to_bpcount($pc)] {
 170                 set pos_to_bpcount($pc) 0
 171         }
 172         incr pos_to_bpcount($pc)
 173
 174 # If there's a window for this file, update it
 175
 176         if [info exists wins($file)] {
 177                 insert_breakpoint_tag $wins($file) $line
 178         }
 179
 180 # If there's an assembly window, update that too
 181
 182         set win [asm_win_name $cfunc]
 183         if [winfo exists $win] {
 184                 insert_breakpoint_tag $win [pc_to_line $pclist($cfunc) $pc]
 185         }
 186 }
 187
 188 #
 189 # Local procedure:
 190 #
 191 #       delete_breakpoint (bpnum file line pc) - Delete breakpoint info from TK land
 192 #
 193 # Description:
 194 #
 195 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
 196 #       land of breakpoint destruction.  This consists of removing the file and
 197 #       line number from the breakpoint_file and breakpoint_line arrays.  Also,
 198 #       if there is already a window associated with FILE, the tags are removed
 199 #       from it.
 200 #
 201
 202 proc delete_breakpoint {bpnum file line pc} {
 203         global wins
 204         global breakpoint_file
 205         global breakpoint_line
 206         global pos_to_breakpoint
 207         global pos_to_bpcount
 208         global cfunc pclist
 209
 210 # Save line number and file for later
 211
 212         set line $breakpoint_line($bpnum)
 213
 214         set file $breakpoint_file($bpnum)
 215
 216 # Reset breakpoint annotation info
 217
 218         if {$pos_to_bpcount($file:$line) > 0} {
 219                 decr pos_to_bpcount($file:$line)
 220
 221                 if {$pos_to_bpcount($file:$line) == 0} {
 222                         catch "unset pos_to_breakpoint($file:$line)"
 223
 224                         unset breakpoint_file($bpnum)
 225                         unset breakpoint_line($bpnum)
 226
 227 # If there's a window for this file, update it
 228
 229                         if [info exists wins($file)] {
 230                                 delete_breakpoint_tag $wins($file) $line
 231                         }
 232                 }
 233         }
 234
 235 # If there's an assembly window, update that too
 236
 237         if {$pos_to_bpcount($pc) > 0} {
 238                 decr pos_to_bpcount($pc)
 239
 240                 if {$pos_to_bpcount($pc) == 0} {
 241                         catch "unset pos_to_breakpoint($pc)"
 242
 243                         set win [asm_win_name $cfunc]
 244                         if [winfo exists $win] {
 245                                 delete_breakpoint_tag $win [pc_to_line $pclist($cfunc) $pc]
 246                         }
 247                 }
 248         }
 249 }
 250
 251 #
 252 # Local procedure:
 253 #
 254 #       enable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
 255 #
 256 # Description:
 257 #
 258 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
 259 #       land of a breakpoint being enabled.  This consists of unstippling the
 260 #       specified breakpoint indicator.
 261 #
 262
 263 proc enable_breakpoint {bpnum file line pc} {
 264         global wins
 265         global cfunc pclist
 266
 267         if [info exists wins($file)] {
 268                 $wins($file) tag configure $line -fgstipple {}
 269         }
 270
 271 # If there's an assembly window, update that too
 272
 273         set win [asm_win_name $cfunc]
 274         if [winfo exists $win] {
 275                 $win tag configure [pc_to_line $pclist($cfunc) $pc] -fgstipple {}
 276         }
 277 }
 278
 279 #
 280 # Local procedure:
 281 #
 282 #       disable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
 283 #
 284 # Description:
 285 #
 286 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
 287 #       land of a breakpoint being disabled.  This consists of stippling the
 288 #       specified breakpoint indicator.
 289 #
 290
 291 proc disable_breakpoint {bpnum file line pc} {
 292         global wins
 293         global cfunc pclist
 294
 295         if [info exists wins($file)] {
 296                 $wins($file) tag configure $line -fgstipple gray50
 297         }
 298
 299 # If there's an assembly window, update that too
 300
 301         set win [asm_win_name $cfunc]
 302         if [winfo exists $win] {
 303                 $win tag configure [pc_to_line $pclist($cfunc) $pc] -fgstipple gray50
 304         }
 305 }
 306
 307 #
 308 # Local procedure:
 309 #
 310 #       insert_breakpoint_tag (win line) - Insert a breakpoint tag in WIN.
 311 #
 312 # Description:
 313 #
 314 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to insert a
 315 #       breakpoint tag into window WIN at line LINE.
 316 #
 317
 318 proc insert_breakpoint_tag {win line} {
 319         $win configure -state normal
 320         $win delete $line.0
 321         $win insert $line.0 "B"
 322         $win tag add $line $line.0
 323         $win tag add delete $line.0 "$line.0 lineend"
 324         $win tag add margin $line.0 "$line.0 lineend"
 325
 326         $win configure -state disabled
 327 }
 328
 329 #
 330 # Local procedure:
 331 #
 332 #       delete_breakpoint_tag (win line) - Remove a breakpoint tag from WIN.
 333 #
 334 # Description:
 335 #
 336 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to remove a
 337 #       breakpoint tag from window WIN at line LINE.
 338 #
 339
 340 proc delete_breakpoint_tag {win line} {
 341         $win configure -state normal
 342         $win delete $line.0
 343         $win insert $line.0 " "
 344         $win tag delete $line
 345         $win tag add delete $line.0 "$line.0 lineend"
 346         $win tag add margin $line.0 "$line.0 lineend"
 347         $win configure -state disabled
 348 }
 349
 350 proc gdbtk_tcl_busy {} {
 351         .start configure -state disabled
 352         .stop configure -state normal
 353         .step configure -state disabled
 354         .next configure -state disabled
 355         .continue configure -state disabled
 356         .finish configure -state disabled
 357         .quit configure -state disabled
 358         .up configure -state disabled
 359         .down configure -state disabled
 360         .bottom configure -state disabled
 361         .asm_but configure -state disabled
 362         .registers configure -state disabled
 363         .asm.stepi configure -state disabled
 364         .asm.nexti configure -state disabled
 365         .asm.continue configure -state disabled
 366         .asm.finish configure -state disabled
 367         .asm.up configure -state disabled
 368         .asm.down configure -state disabled
 369         .asm.bottom configure -state disabled
 370         .asm.close configure -state disabled
 371 }
 372
 373 proc gdbtk_tcl_idle {} {
 374         .start configure -state normal
 375         .stop configure -state disabled
 376         .step configure -state normal
 377         .next configure -state normal
 378         .continue configure -state normal
 379         .finish configure -state normal
 380         .quit configure -state normal
 381         .up configure -state normal
 382         .down configure -state normal
 383         .bottom configure -state normal
 384         .asm_but configure -state normal
 385         .registers 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 < 8} {
 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} {
 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 .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 .nofile window and return.
 746
 747                 catch {destroy .nofile}
 748                 text .nofile -height 25 -width 80 -relief raised -borderwidth 2 -yscrollcommand textscrollproc -setgrid true -cursor hand2
 749                 .nofile insert 0.0 $fh
 750                 .nofile configure -state disabled
 751                 bind .nofile <1> do_nothing
 752                 bind .nofile <B1-Motion> do_nothing
 753                 return .nofile
 754         }
 755
 756 # Actually create and do basic configuration on the text widget.
 757
 758         text $win -height 25 -width 80 -relief raised -borderwidth 2 -yscrollcommand textscrollproc -setgrid true -cursor hand2
 759
 760 # Setup all the bindings
 761
 762         bind $win <Enter> {focus %W}
 763 #       bind $win <1> {listing_window_button_1 %W %X %Y %x %y}
 764         bind $win <1> do_nothing
 765         bind $win <B1-Motion> do_nothing
 766
 767         bind $win n {gdb_cmd next ; update_ptr}
 768         bind $win s {gdb_cmd step ; update_ptr}
 769         bind $win c {gdb_cmd continue ; update_ptr}
 770         bind $win f {gdb_cmd finish ; update_ptr}
 771         bind $win u {gdb_cmd up ; update_ptr}
 772         bind $win d {gdb_cmd down ; update_ptr}
 773
 774         $win delete 0.0 end
 775         $win insert 0.0 [read $fh]
 776         close $fh
 777
 778 # Add margins (for annotations) and a line number to each line
 779
 780         set numlines [$win index end]
 781         set numlines [lindex [split $numlines .] 0]
 782         for {set i 1} {$i <= $numlines} {incr i} {
 783                 $win insert $i.0 [format "   %4d " $i]
 784                 $win tag add margin $i.0 $i.8
 785                 $win tag add source $i.8 "$i.0 lineend"
 786                 }
 787
 788         $win tag bind margin <1> {listing_window_button_1 %W %X %Y %x %y}
 789         $win tag bind source <1> {
 790                 %W mark set anchor "@%x,%y wordstart"
 791                 set last [%W index "@%x,%y wordend"]
 792                 %W tag remove sel 0.0 anchor
 793                 %W tag remove sel $last end
 794                 %W tag add sel anchor $last
 795                 }
 796 #       $win tag bind source <Double-Button-1> {
 797 #               %W mark set anchor "@%x,%y wordstart"
 798 #               set last [%W index "@%x,%y wordend"]
 799 #               %W tag remove sel 0.0 anchor
 800 #               %W tag remove sel $last end
 801 #               %W tag add sel anchor $last
 802 #               echo "Selected [selection get]"
 803 #               }
 804         $win tag bind source <B1-Motion> {
 805                 %W tag remove sel 0.0 anchor
 806                 %W tag remove sel $last end
 807                 %W tag add sel anchor @%x,%y
 808                 }
 809         $win tag bind sel <1> do_nothing
 810         $win tag bind sel <Double-Button-1> {display_expression [selection get]}
 811         $win tag raise sel
 812
 813
 814 # Scan though the breakpoint data base and install any destined for this file
 815
 816         foreach bpnum [array names breakpoint_file] {
 817                 if {$breakpoint_file($bpnum) == $filename} {
 818                         insert_breakpoint_tag $win $breakpoint_line($bpnum)
 819                         }
 820                 }
 821
 822 # Disable the text widget to prevent user modifications
 823
 824         $win configure -state disabled
 825         return $win
 826 }
 827
 828 #
 829 # Local procedure:
 830 #
 831 #       create_asm_win (funcname pc) - Create an assembly win for FUNCNAME.
 832 #
 833 # Return value:
 834 #
 835 #       The new text widget.
 836 #
 837 # Description:
 838 #
 839 #       This procedure creates a text widget for FUNCNAME.  It returns the
 840 #       newly created widget.  First, a text widget is created, and given basic
 841 #       configuration info.  Second, all the bindings are setup.  Third, the
 842 #       function FUNCNAME is read into the text widget.
 843 #
 844
 845 proc create_asm_win {funcname pc} {
 846         global breakpoint_file
 847         global breakpoint_line
 848         global current_output_win
 849         global pclist
 850
 851 # Replace all the dirty characters in $filename with clean ones, and generate
 852 # a unique name for the text widget.
 853
 854         set win [asm_win_name $funcname]
 855
 856 # Actually create and do basic configuration on the text widget.
 857
 858         text $win -height 25 -width 80 -relief raised -borderwidth 2 \
 859                 -setgrid true -cursor hand2 -yscrollcommand asmscrollproc
 860
 861 # Setup all the bindings
 862
 863         bind $win <Enter> {focus %W}
 864         bind $win <1> {asm_window_button_1 %W %X %Y %x %y}
 865         bind $win <B1-Motion> do_nothing
 866         bind $win n {gdb_cmd nexti ; update_ptr}
 867         bind $win s {gdb_cmd stepi ; update_ptr}
 868         bind $win c {gdb_cmd continue ; update_ptr}
 869         bind $win f {gdb_cmd finish ; update_ptr}
 870         bind $win u {gdb_cmd up ; update_ptr}
 871         bind $win d {gdb_cmd down ; update_ptr}
 872
 873 # Disassemble the code, and read it into the new text widget
 874
 875         set current_output_win $win
 876         gdb_cmd "disassemble $pc"
 877         set current_output_win .command.text
 878
 879         set numlines [$win index end]
 880         set numlines [lindex [split $numlines .] 0]
 881         decr numlines
 882
 883 # Delete the first and last lines, cuz these contain useless info
 884
 885         $win delete 1.0 2.0
 886         $win delete {end - 1 lines} end
 887         decr numlines 2
 888
 889 # Add margins (for annotations) and note the PC for each line
 890
 891         catch "unset pclist($funcname)"
 892         lappend pclist($funcname) Unused
 893         for {set i 1} {$i <= $numlines} {incr i} {
 894                 scan [$win get $i.0 "$i.0 lineend"] "%s " pc
 895                 lappend pclist($funcname) $pc
 896                 $win insert $i.0 "    "
 897                 }
 898
 899
 900 # Scan though the breakpoint data base and install any destined for this file
 901
 902 #       foreach bpnum [array names breakpoint_file] {
 903 #               if {$breakpoint_file($bpnum) == $filename} {
 904 #                       insert_breakpoint_tag $win $breakpoint_line($bpnum)
 905 #                       }
 906 #               }
 907
 908 # Disable the text widget to prevent user modifications
 909
 910         $win configure -state disabled
 911         return $win
 912 }
 913
 914 #
 915 # Local procedure:
 916 #
 917 #       asmscrollproc (WINHEIGHT SCREENHEIGHT SCREENTOP SCREENBOT) - Update the
 918 #       asm window scrollbar.
 919 #
 920 # Description:
 921 #
 922 #       This procedure is called to update the assembler window's scrollbar.
 923 #
 924
 925 proc asmscrollproc {args} {
 926         global asm_screen_height asm_screen_top asm_screen_bot
 927
 928         eval ".asm.scroll set $args"
 929         set asm_screen_height [lindex $args 1]
 930         set asm_screen_top [lindex $args 2]
 931         set asm_screen_bot [lindex $args 3]
 932 }
 933
 934 #
 935 # Local procedure:
 936 #
 937 #       update_listing (linespec) - Update the listing window according to
 938 #                                   LINESPEC.
 939 #
 940 # Description:
 941 #
 942 #       This procedure is called from various places to update the listing
 943 #       window based on LINESPEC.  It is usually invoked with the result of
 944 #       gdb_loc.
 945 #
 946 #       It will move the cursor, and scroll the text widget if necessary.
 947 #       Also, it will switch to another text widget if necessary, and update
 948 #       the label widget too.
 949 #
 950 #       LINESPEC is a list of the form:
 951 #
 952 #       { DEBUG_FILE FUNCNAME FILENAME LINE }, where:
 953 #
 954 #       DEBUG_FILE - is the abbreviated form of the file name.  This is usually
 955 #                    the file name string given to the cc command.  This is
 956 #                    primarily needed for breakpoint commands, and when an
 957 #                    abbreviated for of the filename is desired.
 958 #       FUNCNAME - is the name of the function.
 959 #       FILENAME - is the fully qualified (absolute) file name.  It is usually
 960 #                  the same as $PWD/$DEBUG_FILE, where PWD is the working dir
 961 #                  at the time the cc command was given.  This is used to
 962 #                  actually locate the file to be displayed.
 963 #       LINE - The line number to be displayed.
 964 #
 965 #       Usually, this procedure will just move the cursor one line down to the
 966 #       next line to be executed.  However, if the cursor moves out of range
 967 #       or into another file, it will scroll the text widget so that the line
 968 #       of interest is in the middle of the viewable portion of the widget.
 969 #
 970
 971 proc update_listing {linespec} {
 972         global pointers
 973         global screen_height
 974         global screen_top
 975         global screen_bot
 976         global wins cfile
 977         global current_label
 978         global win_to_file
 979         global file_to_debug_file
 980
 981 # Rip the linespec apart
 982
 983         set line [lindex $linespec 3]
 984         set filename [lindex $linespec 2]
 985         set funcname [lindex $linespec 1]
 986         set debug_file [lindex $linespec 0]
 987
 988 # Sometimes there's no source file for this location
 989
 990         if {$filename == ""} {set filename Blank}
 991
 992 # If we want to switch files, we need to unpack the current text widget, and
 993 # stick in the new one.
 994
 995         if {$filename != $cfile} then {
 996                 pack forget $wins($cfile)
 997                 set cfile $filename
 998
 999 # Create a text widget for this file if necessary
1000
1001                 if ![info exists wins($cfile)] then {
1002                         set wins($cfile) [create_file_win $cfile]
1003                         if {$wins($cfile) != ".nofile"} {
1004                                 set win_to_file($wins($cfile)) $cfile
1005                                 set file_to_debug_file($cfile) $debug_file
1006                                 set pointers($cfile) 1.1
1007                                 }
1008                         }
1009
1010 # Pack the text widget into the listing widget, and scroll to the right place
1011
1012                 pack $wins($cfile) -side left -expand yes -in .listing -fill both -after .label
1013                 $wins($cfile) yview [expr $line - $screen_height / 2]
1014                 }
1015
1016 # Update the label widget in case the filename or function name has changed
1017
1018         if {$current_label != "$filename.$funcname"} then {
1019                 set tail [expr [string last / $filename] + 1]
1020                 .label configure -text "[string range $filename $tail end] : ${funcname}()"
1021                 set current_label $filename.$funcname
1022                 }
1023
1024 # Update the pointer, scrolling the text widget if necessary to keep the
1025 # pointer in an acceptable part of the screen.
1026
1027         if [info exists pointers($cfile)] then {
1028                 $wins($cfile) configure -state normal
1029                 set pointer_pos $pointers($cfile)
1030                 $wins($cfile) configure -state normal
1031                 $wins($cfile) delete $pointer_pos
1032                 $wins($cfile) insert $pointer_pos " "
1033
1034                 set pointer_pos [$wins($cfile) index $line.1]
1035                 set pointers($cfile) $pointer_pos
1036
1037                 $wins($cfile) delete $pointer_pos
1038                 $wins($cfile) insert $pointer_pos "\xbb"
1039
1040                 if {$line < $screen_top + 1
1041                     || $line > $screen_bot} then {
1042                         $wins($cfile) yview [expr $line - $screen_height / 2]
1043                         }
1044
1045                 $wins($cfile) configure -state disabled
1046                 }
1047 }
1048
1049 #
1050 # Local procedure:
1051 #
1052 #       update_ptr - Update the listing window.
1053 #
1054 # Description:
1055 #
1056 #       This routine will update the listing window using the result of
1057 #       gdb_loc.
1058 #
1059
1060 proc update_ptr {} {update_listing [gdb_loc]}
1061
1062 #
1063 # Local procedure:
1064 #
1065 #       asm_command - Open up the assembly window.
1066 #
1067 # Description:
1068 #
1069 #       Create an assembly window if it doesn't exist.
1070 #
1071
1072 proc asm_command {} {
1073         global cfunc
1074
1075         if ![winfo exists .asm] {
1076                 set cfunc *None*
1077                 set win [asm_win_name $cfunc]
1078
1079                 toplevel .asm
1080                 wm minsize .asm 1 1
1081                 wm title .asm Assembly
1082
1083                 label .asm.label -text "*NIL*" -borderwidth 2 -relief raised
1084                 text $win -height 25 -width 80 -relief raised -borderwidth 2 \
1085                         -setgrid true -cursor hand2 \
1086                         -yscrollcommand asmscrollproc
1087                 scrollbar .asm.scroll -orient vertical \
1088                         -command {[asm_win_name $cfunc] yview}
1089                 frame .asm.buts
1090
1091                 button .asm.stepi -text Stepi \
1092                         -command {gdb_cmd stepi ; update_ptr}
1093                 button .asm.nexti -text Nexti \
1094                         -command {gdb_cmd nexti ; update_ptr}
1095                 button .asm.continue -text Continue \
1096                         -command {gdb_cmd continue ; update_ptr}
1097                 button .asm.finish -text Finish \
1098                         -command {gdb_cmd finish ; update_ptr}
1099                 button .asm.up -text Up -command {gdb_cmd up ; update_ptr}
1100                 button .asm.down -text Down \
1101                         -command {gdb_cmd down ; update_ptr}
1102                 button .asm.bottom -text Bottom \
1103                         -command {gdb_cmd {frame 0} ; update_ptr}
1104                 button .asm.close -text Close -command {destroy .asm}
1105
1106                 pack .asm.label -side top -fill x
1107                 pack .asm.stepi .asm.nexti .asm.continue .asm.finish .asm.up \
1108                      .asm.down .asm.bottom .asm.close -side left -in .asm.buts
1109                 pack .asm.buts -side top -fill x
1110                 pack $win -side left -expand yes -fill both
1111                 pack .asm.scroll -side left -fill y
1112
1113                 update
1114         }
1115 }
1116
1117 #
1118 # Local procedure:
1119 #
1120 #       registers_command - Open up the register display window.
1121 #
1122 # Description:
1123 #
1124 #       Create the register display window, with automatic updates.
1125 #
1126
1127 proc registers_command {} {
1128         global cfunc
1129
1130         if ![winfo exists .reg] {
1131                 toplevel .reg
1132                 wm minsize .reg 1 1
1133                 wm title .reg Registers
1134                 set win .reg.regs
1135
1136                 text $win -height 41 -width 45 -relief raised \
1137                         -borderwidth 2 \
1138                         -setgrid true -cursor hand2
1139
1140                 pack $win -side left -expand yes -fill both
1141         } else {
1142                 destroy .reg
1143         }
1144 }
1145
1146 #
1147 # Local procedure:
1148 #
1149 #       update_registers - Update the registers window.
1150 #
1151 # Description:
1152 #
1153 #       This procedure updates the registers window.
1154 #
1155
1156 proc update_registers {} {
1157         global current_output_win
1158
1159         set win .reg.regs
1160
1161         $win configure -state normal
1162
1163         $win delete 0.0 end
1164
1165         set current_output_win $win
1166         gdb_cmd "info registers"
1167         set current_output_win .command.text
1168
1169         $win yview 0
1170         $win configure -state disabled
1171 }
1172
1173 #
1174 # Local procedure:
1175 #
1176 #       update_assembly - Update the assembly window.
1177 #
1178 # Description:
1179 #
1180 #       This procedure updates the assembly window.
1181 #
1182
1183 proc update_assembly {linespec} {
1184         global asm_pointers
1185         global screen_height
1186         global screen_top
1187         global screen_bot
1188         global wins cfunc
1189         global current_label
1190         global win_to_file
1191         global file_to_debug_file
1192         global current_asm_label
1193         global pclist
1194         global asm_screen_height asm_screen_top asm_screen_bot
1195
1196 # Rip the linespec apart
1197
1198         set pc [lindex $linespec 4]
1199         set line [lindex $linespec 3]
1200         set filename [lindex $linespec 2]
1201         set funcname [lindex $linespec 1]
1202         set debug_file [lindex $linespec 0]
1203
1204         set win [asm_win_name $cfunc]
1205
1206 # Sometimes there's no source file for this location
1207
1208         if {$filename == ""} {set filename Blank}
1209
1210 # If we want to switch funcs, we need to unpack the current text widget, and
1211 # stick in the new one.
1212
1213         if {$funcname != $cfunc } {
1214                 pack forget $win
1215                 set cfunc $funcname
1216
1217                 set win [asm_win_name $cfunc]
1218
1219 # Create a text widget for this func if necessary
1220
1221                 if {![winfo exists $win]} {
1222                         create_asm_win $cfunc $pc
1223                         set asm_pointers($cfunc) 1.1
1224                         set current_asm_label NIL
1225                         }
1226
1227 # Pack the text widget, and scroll to the right place
1228
1229                 pack $win -side left -expand yes -fill both \
1230                         -after .asm.buts
1231                 set line [pc_to_line $pclist($cfunc) $pc]
1232                 $win yview [expr $line - $asm_screen_height / 2]
1233                 }
1234
1235 # Update the label widget in case the filename or function name has changed
1236
1237         if {$current_asm_label != "$pc $funcname"} then {
1238                 .asm.label configure -text "$pc $funcname"
1239                 set current_asm_label "$pc $funcname"
1240                 }
1241
1242 # Update the pointer, scrolling the text widget if necessary to keep the
1243 # pointer in an acceptable part of the screen.
1244
1245         if [info exists asm_pointers($cfunc)] then {
1246                 $win configure -state normal
1247                 set pointer_pos $asm_pointers($cfunc)
1248                 $win configure -state normal
1249                 $win delete $pointer_pos
1250                 $win insert $pointer_pos " "
1251
1252 # Map the PC back to a line in the window
1253
1254                 set line [pc_to_line $pclist($cfunc) $pc]
1255
1256                 if {$line == -1} {
1257                         echo "Can't find PC $pc"
1258                         return
1259                         }
1260
1261                 set pointer_pos [$win index $line.1]
1262                 set asm_pointers($cfunc) $pointer_pos
1263
1264                 $win delete $pointer_pos
1265                 $win insert $pointer_pos "\xbb"
1266
1267                 if {$line < $asm_screen_top + 1
1268                     || $line > $asm_screen_bot} then {
1269                         $win yview [expr $line - $asm_screen_height / 2]
1270                         }
1271
1272 #               echo "Picking line $line"
1273 #               $win yview -pickplace $line
1274
1275                 $win configure -state disabled
1276                 }
1277 }
1278
1279 proc update_ptr {} {
1280         update_listing [gdb_loc]
1281         if [winfo exists .asm] {
1282                 update_assembly [gdb_loc]
1283         }
1284         if [winfo exists .reg] {
1285                 update_registers
1286         }
1287 }
1288
1289 #
1290 # Window:
1291 #
1292 #       listing window - Define the listing window.
1293 #
1294 # Description:
1295 #
1296 #
1297
1298 # Setup listing window
1299
1300 frame .listing
1301
1302 wm minsize . 1 1
1303
1304 label .label -text "*No file*" -borderwidth 2 -relief raised
1305 text $wins($cfile) -height 25 -width 80 -relief raised -borderwidth 2 -yscrollcommand textscrollproc -setgrid true -cursor hand2
1306 scrollbar .scroll -orient vertical -command {$wins($cfile) yview}
1307
1308 if {[tk colormodel .text] == "color"} {
1309         set highlight "-background red2 -borderwidth 2 -relief sunk"
1310 } else {
1311         set fg [lindex [.text config -foreground] 4]
1312         set bg [lindex [.text config -background] 4]
1313         set highlight "-foreground $bg -background $fg -borderwidth 0"
1314 }
1315
1316 proc textscrollproc {args} {global screen_height screen_top screen_bot
1317                             eval ".scroll set $args"
1318                             set screen_height [lindex $args 1]
1319                             set screen_top [lindex $args 2]
1320                             set screen_bot [lindex $args 3]}
1321
1322 $wins($cfile) insert 0.0 "  This page intentionally left blank."
1323 $wins($cfile) configure -state disabled
1324
1325 pack .label -side bottom -fill x -in .listing
1326 pack $wins($cfile) -side left -expand yes -in .listing -fill both
1327 pack .scroll -side left -fill y -in .listing
1328
1329 button .start -text Start -command \
1330         {gdb_cmd {break main}
1331          gdb_cmd {enable delete $bpnum}
1332          gdb_cmd run
1333          update_ptr }
1334 button .stop -text Stop -fg red -activeforeground red -state disabled -command gdb_stop
1335 button .step -text Step -command {gdb_cmd step ; update_ptr}
1336 button .next -text Next -command {gdb_cmd next ; update_ptr}
1337 button .continue -text Continue -command {gdb_cmd continue ; update_ptr}
1338 button .finish -text Finish -command {gdb_cmd finish ; update_ptr}
1339 #button .test -text Test -command {echo [info var]}
1340 button .quit -text Quit -command {gdb_cmd quit}
1341 button .up -text Up -command {gdb_cmd up ; update_ptr}
1342 button .down -text Down -command {gdb_cmd down ; update_ptr}
1343 button .bottom -text Bottom -command {gdb_cmd {frame 0} ; update_ptr}
1344 button .asm_but -text Asm -command {asm_command ; update_ptr}
1345 button .registers -text Regs -command {registers_command ; update_ptr}
1346
1347 proc files_command {} {
1348         toplevel .files_window
1349
1350         wm minsize .files_window 1 1
1351 #       wm overrideredirect .files_window true
1352         listbox .files_window.list -geometry 30x20 -setgrid true
1353         button .files_window.close -text Close -command {destroy .files_window}
1354         tk_listboxSingleSelect .files_window.list
1355         eval .files_window.list insert 0 [lsort [gdb_listfiles]]
1356         pack .files_window.list -side top -fill both -expand yes
1357         pack .files_window.close -side bottom -fill x -expand no -anchor s
1358         bind .files_window.list <Any-ButtonRelease-1> {
1359                 set file [%W get [%W curselection]]
1360                 gdb_cmd "list $file:1,0"
1361                 update_listing [gdb_loc $file:1]
1362                 destroy .files_window}
1363 }
1364
1365 button .files -text Files -command files_command
1366
1367 pack .listing -side bottom -fill both -expand yes
1368 #pack .test -side bottom -fill x
1369 pack .start .stop .step .next .continue .finish .up .down .bottom .asm_but \
1370         .registers .files .quit -side left
1371 toplevel .command
1372 wm title .command Command
1373
1374 # Setup command window
1375
1376 label .command.label -text "* Command Buffer *" -borderwidth 2 -relief raised
1377 text .command.text -height 25 -width 80 -relief raised -borderwidth 2 -setgrid true -cursor hand2 -yscrollcommand {.command.scroll set}
1378 scrollbar .command.scroll -orient vertical -command {.command.text yview}
1379
1380 pack .command.label -side top -fill x
1381 pack .command.text -side left -expand yes -fill both
1382 pack .command.scroll -side right -fill y
1383
1384 set command_line {}
1385
1386 gdb_cmd {set language c}
1387 gdb_cmd {set height 0}
1388 gdb_cmd {set width 0}
1389
1390 bind .command.text <Enter> {focus %W}
1391 bind .command.text <Delete> {delete_char %W}
1392 bind .command.text <BackSpace> {delete_char %W}
1393 bind .command.text <Control-u> {delete_line %W}
1394 bind .command.text <Any-Key> {
1395         global command_line
1396
1397         %W insert end %A
1398         %W yview -pickplace end
1399         append command_line %A
1400         }
1401 bind .command.text <Key-Return> {
1402         global command_line
1403
1404         %W insert end \n
1405         %W yview -pickplace end
1406         gdb_cmd $command_line
1407         set command_line {}
1408         update_ptr
1409         %W insert end "(gdb) "
1410         %W yview -pickplace end
1411         }
1412
1413 proc delete_char {win} {
1414         global command_line
1415
1416         tk_textBackspace $win
1417         $win yview -pickplace insert
1418         set tmp [expr [string length $command_line] - 2]
1419         set command_line [string range $command_line 0 $tmp]
1420 }
1421
1422 proc delete_line {win} {
1423         global command_line
1424
1425         $win delete {end linestart + 6 chars} end
1426         $win yview -pickplace insert
1427         set command_line {}
1428 }
1429
1430 wm minsize .command 1 1