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
  12 proc test {} {
  13         update_listing {termcap.c foo /etc/termcap 200}
  14 }
  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
 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 configure -state disabled
 346 }
 347
 348 #
 349 # Local procedure:
 350 #
 351 #       decr (var val) - compliment to incr
 352 #
 353 # Description:
 354 #
 355 #
 356 proc decr {var {val 1}} {
 357         upvar $var num
 358         set num [expr $num - $val]
 359         return $num
 360 }
 361
 362 #
 363 # Local procedure:
 364 #
 365 #       pc_to_line (pclist pc) - convert PC to a line number.
 366 #
 367 # Description:
 368 #
 369 #       Convert PC to a line number from PCLIST.  If exact line isn't found,
 370 #       we return the first line that starts before PC.
 371 #
 372 proc pc_to_line {pclist pc} {
 373         set line [lsearch -exact $pclist $pc]
 374
 375         if {$line >= 1} { return $line }
 376
 377         set line 1
 378         foreach linepc [lrange $pclist 1 end] {
 379                 if {$pc < $linepc} { decr line ; return $line }
 380                 incr line
 381         }
 382         return [expr $line - 1]
 383 }
 384
 385 #
 386 # Menu:
 387 #
 388 #       file popup menu - Define the file popup menu.
 389 #
 390 # Description:
 391 #
 392 #       This menu just contains a bunch of buttons that do various things to
 393 #       the line under the cursor.
 394 #
 395 # Items:
 396 #
 397 #       Edit - Run the editor (specified by the environment variable EDITOR) on
 398 #              this file, at the current line.
 399 #       Breakpoint - Set a breakpoint at the current line.  This just shoves
 400 #               a `break' command at GDB with the appropriate file and line
 401 #               number.  Eventually, GDB calls us back (at gdbtk_tcl_breakpoint)
 402 #               to notify us of where the breakpoint needs to show up.
 403 #
 404
 405 menu .file_popup -cursor hand2
 406 .file_popup add command -label "Not yet set" -state disabled
 407 .file_popup add separator
 408 .file_popup add command -label "Edit" -command {exec $editor +$selected_line $selected_file &}
 409 .file_popup add command -label "Set breakpoint" -command {gdb_cmd "break $selected_file:$selected_line"}
 410
 411 #
 412 # Bindings:
 413 #
 414 #       file popup menu - Define the file popup menu bindings.
 415 #
 416 # Description:
 417 #
 418 #       This defines the binding for the file popup menu.  Currently, there is
 419 #       only one, which is activated when Button-1 is released.  This causes
 420 #       the menu to be unposted, releases the grab for the menu, and then
 421 #       unhighlights the line under the cursor.  After that, the selected menu
 422 #       item is invoked.
 423 #
 424
 425 bind .file_popup <Any-ButtonRelease-1> {
 426         global selected_win
 427
 428 # First, remove the menu, and release the pointer
 429
 430         .file_popup unpost
 431         grab release .file_popup
 432
 433 # Unhighlight the selected line
 434
 435         $selected_win tag delete breaktag
 436
 437 # Actually invoke the menubutton here!
 438
 439         tk_invokeMenu %W
 440 }
 441
 442 #
 443 # Local procedure:
 444 #
 445 #       file_popup_menu (win x y xrel yrel) - Popup the file popup menu.
 446 #
 447 # Description:
 448 #
 449 #       This procedure is invoked as a result of a command binding in the
 450 #       listing window.  It does several things:
 451 #               o - It highlights the line under the cursor.
 452 #               o - It pops up the file popup menu which is intended to do
 453 #                   various things to the aforementioned line.
 454 #               o - Grabs the mouse for the file popup menu.
 455 #
 456
 457 # Button 1 has been pressed in a listing window.  Pop up a menu.
 458
 459 proc file_popup_menu {win x y xrel yrel} {
 460         global wins
 461         global win_to_file
 462         global file_to_debug_file
 463         global highlight
 464         global selected_line
 465         global selected_file
 466         global selected_win
 467
 468 # Map TK window name back to file name.
 469
 470         set file $win_to_file($win)
 471
 472         set pos [$win index @$xrel,$yrel]
 473
 474 # Record selected file and line for menu button actions
 475
 476         set selected_file $file_to_debug_file($file)
 477         set selected_line [lindex [split $pos .] 0]
 478         set selected_win $win
 479
 480 # Highlight the selected line
 481
 482         eval $win tag config breaktag $highlight
 483         $win tag add breaktag "$pos linestart" "$pos linestart + 1l"
 484
 485 # Post the menu near the pointer, (and grab it)
 486
 487         .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
 488         .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
 489         grab .file_popup
 490 }
 491
 492 #
 493 # Local procedure:
 494 #
 495 #       listing_window_button_1 (win x y xrel yrel) - Handle button 1 in listing window
 496 #
 497 # Description:
 498 #
 499 #       This procedure is invoked as a result of holding down button 1 in the
 500 #       listing window.  The action taken depends upon where the button was
 501 #       pressed.  If it was in the left margin (the breakpoint column), it
 502 #       sets or clears a breakpoint.  In the main text area, it will pop up a
 503 #       menu.
 504 #
 505
 506 proc listing_window_button_1 {win x y xrel yrel} {
 507         global wins
 508         global win_to_file
 509         global file_to_debug_file
 510         global highlight
 511         global selected_line
 512         global selected_file
 513         global selected_win
 514         global pos_to_breakpoint
 515
 516 # Map TK window name back to file name.
 517
 518         set file $win_to_file($win)
 519
 520         set pos [split [$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 $pos 0]
 526         set selected_col [lindex $pos 1]
 527         set selected_win $win
 528
 529 # If we're in the margin, then toggle the breakpoint
 530
 531         if {$selected_col < 8} {
 532                 set pos_break $selected_file:$selected_line
 533                 set pos $file:$selected_line
 534                 set tmp pos_to_breakpoint($pos)
 535                 if [info exists $tmp] {
 536                         set bpnum [set $tmp]
 537                         gdb_cmd "delete $bpnum"
 538                 } else {
 539                         gdb_cmd "break $pos_break"
 540                 }
 541                 return
 542         }
 543
 544 # Post the menu near the pointer, (and grab it)
 545
 546         .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
 547         .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
 548         grab .file_popup
 549 }
 550
 551 #
 552 # Local procedure:
 553 #
 554 #       asm_window_button_1 (win x y xrel yrel) - Handle button 1 in asm window
 555 #
 556 # Description:
 557 #
 558 #       This procedure is invoked as a result of holding down button 1 in the
 559 #       assembly window.  The action taken depends upon where the button was
 560 #       pressed.  If it was in the left margin (the breakpoint column), it
 561 #       sets or clears a breakpoint.  In the main text area, it will pop up a
 562 #       menu.
 563 #
 564
 565 proc asm_window_button_1 {win x y xrel yrel} {
 566         global wins
 567         global win_to_file
 568         global file_to_debug_file
 569         global highlight
 570         global selected_line
 571         global selected_file
 572         global selected_win
 573         global pos_to_breakpoint
 574         global pclist
 575         global cfunc
 576
 577         set pos [split [$win index @$xrel,$yrel] .]
 578
 579 # Record selected file and line for menu button actions
 580
 581         set selected_line [lindex $pos 0]
 582         set selected_col [lindex $pos 1]
 583         set selected_win $win
 584
 585 # Figure out the PC
 586
 587         set pc [lindex $pclist($cfunc) $selected_line]
 588
 589 # If we're in the margin, then toggle the breakpoint
 590
 591         if {$selected_col < 8} {
 592                 set tmp pos_to_breakpoint($pc)
 593                 if [info exists $tmp] {
 594                         set bpnum [set $tmp]
 595                         gdb_cmd "delete $bpnum"
 596                 } else {
 597                         gdb_cmd "break *$pc"
 598                 }
 599                 return
 600         }
 601
 602 # Post the menu near the pointer, (and grab it)
 603
 604 #       .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
 605 #       .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
 606 #       grab .file_popup
 607 }
 608
 609 #
 610 # Local procedure:
 611 #
 612 #       do_nothing - Does absoultely nothing.
 613 #
 614 # Description:
 615 #
 616 #       This procedure does nothing.  It is used as a placeholder to allow
 617 #       the disabling of bindings that would normally be inherited from the
 618 #       parent widget.  I can't think of any other way to do this.
 619 #
 620
 621 proc do_nothing {} {}
 622
 623 #
 624 # Local procedure:
 625 #
 626 #       create_file_win (filename) - Create a win for FILENAME.
 627 #
 628 # Return value:
 629 #
 630 #       The new text widget.
 631 #
 632 # Description:
 633 #
 634 #       This procedure creates a text widget for FILENAME.  It returns the
 635 #       newly created widget.  First, a text widget is created, and given basic
 636 #       configuration info.  Second, all the bindings are setup.  Third, the
 637 #       file FILENAME is read into the text widget.  Fourth, margins and line
 638 #       numbers are added.
 639 #
 640
 641 proc create_file_win {filename} {
 642         global breakpoint_file
 643         global breakpoint_line
 644
 645 # Replace all the dirty characters in $filename with clean ones, and generate
 646 # a unique name for the text widget.
 647
 648         regsub -all {\.|/} $filename {} temp
 649         set win .text$temp
 650
 651 # Open the file, and read it into the text widget
 652
 653         if [catch "open $filename" fh] {
 654 # File can't be read.  Put error message into .nofile window and return.
 655
 656                 catch {destroy .nofile}
 657                 text .nofile -height 25 -width 80 -relief raised -borderwidth 2 -yscrollcommand textscrollproc -setgrid true -cursor hand2
 658                 .nofile insert 0.0 $fh
 659                 .nofile configure -state disabled
 660                 bind .nofile <1> do_nothing
 661                 bind .nofile <B1-Motion> do_nothing
 662                 return .nofile
 663         }
 664
 665 # Actually create and do basic configuration on the text widget.
 666
 667         text $win -height 25 -width 80 -relief raised -borderwidth 2 -yscrollcommand textscrollproc -setgrid true -cursor hand2
 668
 669 # Setup all the bindings
 670
 671         bind $win <Enter> {focus %W}
 672         bind $win <1> {listing_window_button_1 %W %X %Y %x %y}
 673         bind $win <B1-Motion> do_nothing
 674         bind $win n {gdb_cmd next ; update_ptr}
 675         bind $win s {gdb_cmd step ; update_ptr}
 676         bind $win c {gdb_cmd continue ; update_ptr}
 677         bind $win f {gdb_cmd finish ; update_ptr}
 678         bind $win u {gdb_cmd up ; update_ptr}
 679         bind $win d {gdb_cmd down ; update_ptr}
 680
 681         $win delete 0.0 end
 682         $win insert 0.0 [read $fh]
 683         close $fh
 684
 685 # Add margins (for annotations) and a line number to each line
 686
 687         set numlines [$win index end]
 688         set numlines [lindex [split $numlines .] 0]
 689         for {set i 1} {$i <= $numlines} {incr i} {
 690                 $win insert $i.0 [format "   %4d " $i]
 691                 }
 692
 693 # Scan though the breakpoint data base and install any destined for this file
 694
 695         foreach bpnum [array names breakpoint_file] {
 696                 if {$breakpoint_file($bpnum) == $filename} {
 697                         insert_breakpoint_tag $win $breakpoint_line($bpnum)
 698                         }
 699                 }
 700
 701 # Disable the text widget to prevent user modifications
 702
 703         $win configure -state disabled
 704         return $win
 705 }
 706
 707 #
 708 # Local procedure:
 709 #
 710 #       create_asm_win (funcname pc) - Create an assembly win for FUNCNAME.
 711 #
 712 # Return value:
 713 #
 714 #       The new text widget.
 715 #
 716 # Description:
 717 #
 718 #       This procedure creates a text widget for FUNCNAME.  It returns the
 719 #       newly created widget.  First, a text widget is created, and given basic
 720 #       configuration info.  Second, all the bindings are setup.  Third, the
 721 #       function FUNCNAME is read into the text widget.
 722 #
 723
 724 proc create_asm_win {funcname pc} {
 725         global breakpoint_file
 726         global breakpoint_line
 727         global current_output_win
 728         global pclist
 729
 730 # Replace all the dirty characters in $filename with clean ones, and generate
 731 # a unique name for the text widget.
 732
 733         set win [asm_win_name $funcname]
 734
 735 # Actually create and do basic configuration on the text widget.
 736
 737         text $win -height 25 -width 80 -relief raised -borderwidth 2 \
 738                 -setgrid true -cursor hand2 -yscrollcommand asmscrollproc
 739
 740 # Setup all the bindings
 741
 742         bind $win <Enter> {focus %W}
 743         bind $win <1> {asm_window_button_1 %W %X %Y %x %y}
 744         bind $win <B1-Motion> do_nothing
 745         bind $win n {gdb_cmd nexti ; update_ptr}
 746         bind $win s {gdb_cmd stepi ; update_ptr}
 747         bind $win c {gdb_cmd continue ; update_ptr}
 748         bind $win f {gdb_cmd finish ; update_ptr}
 749         bind $win u {gdb_cmd up ; update_ptr}
 750         bind $win d {gdb_cmd down ; update_ptr}
 751
 752 # Disassemble the code, and read it into the new text widget
 753
 754         set current_output_win $win
 755         gdb_cmd "disassemble $pc"
 756         set current_output_win .command.text
 757
 758         set numlines [$win index end]
 759         set numlines [lindex [split $numlines .] 0]
 760         decr numlines
 761
 762 # Delete the first and last lines, cuz these contain useless info
 763
 764         $win delete 1.0 2.0
 765         $win delete {end - 1 lines} end
 766         decr numlines 2
 767
 768 # Add margins (for annotations) and note the PC for each line
 769
 770         catch "unset pclist($funcname)"
 771         lappend pclist($funcname) Unused
 772         for {set i 1} {$i <= $numlines} {incr i} {
 773                 scan [$win get $i.0 "$i.0 lineend"] "%s " pc
 774                 lappend pclist($funcname) $pc
 775                 $win insert $i.0 "    "
 776                 }
 777
 778
 779 # Scan though the breakpoint data base and install any destined for this file
 780
 781 #       foreach bpnum [array names breakpoint_file] {
 782 #               if {$breakpoint_file($bpnum) == $filename} {
 783 #                       insert_breakpoint_tag $win $breakpoint_line($bpnum)
 784 #                       }
 785 #               }
 786
 787 # Disable the text widget to prevent user modifications
 788
 789         $win configure -state disabled
 790         return $win
 791 }
 792
 793 #
 794 # Local procedure:
 795 #
 796 #       asmscrollproc (WINHEIGHT SCREENHEIGHT SCREENTOP SCREENBOT) - Update the
 797 #       asm window scrollbar.
 798 #
 799 # Description:
 800 #
 801 #       This procedure is called to update the assembler window's scrollbar.
 802 #
 803
 804 proc asmscrollproc {args} {
 805         global asm_screen_height asm_screen_top asm_screen_bot
 806
 807         eval ".asm.scroll set $args"
 808         set asm_screen_height [lindex $args 1]
 809         set asm_screen_top [lindex $args 2]
 810         set asm_screen_bot [lindex $args 3]
 811 }
 812
 813 #
 814 # Local procedure:
 815 #
 816 #       update_listing (linespec) - Update the listing window according to
 817 #                                   LINESPEC.
 818 #
 819 # Description:
 820 #
 821 #       This procedure is called from various places to update the listing
 822 #       window based on LINESPEC.  It is usually invoked with the result of
 823 #       gdb_loc.
 824 #
 825 #       It will move the cursor, and scroll the text widget if necessary.
 826 #       Also, it will switch to another text widget if necessary, and update
 827 #       the label widget too.
 828 #
 829 #       LINESPEC is a list of the form:
 830 #
 831 #       { DEBUG_FILE FUNCNAME FILENAME LINE }, where:
 832 #
 833 #       DEBUG_FILE - is the abbreviated form of the file name.  This is usually
 834 #                    the file name string given to the cc command.  This is
 835 #                    primarily needed for breakpoint commands, and when an
 836 #                    abbreviated for of the filename is desired.
 837 #       FUNCNAME - is the name of the function.
 838 #       FILENAME - is the fully qualified (absolute) file name.  It is usually
 839 #                  the same as $PWD/$DEBUG_FILE, where PWD is the working dir
 840 #                  at the time the cc command was given.  This is used to
 841 #                  actually locate the file to be displayed.
 842 #       LINE - The line number to be displayed.
 843 #
 844 #       Usually, this procedure will just move the cursor one line down to the
 845 #       next line to be executed.  However, if the cursor moves out of range
 846 #       or into another file, it will scroll the text widget so that the line
 847 #       of interest is in the middle of the viewable portion of the widget.
 848 #
 849
 850 proc update_listing {linespec} {
 851         global pointers
 852         global screen_height
 853         global screen_top
 854         global screen_bot
 855         global wins cfile
 856         global current_label
 857         global win_to_file
 858         global file_to_debug_file
 859
 860 # Rip the linespec apart
 861
 862         set line [lindex $linespec 3]
 863         set filename [lindex $linespec 2]
 864         set funcname [lindex $linespec 1]
 865         set debug_file [lindex $linespec 0]
 866
 867 # Sometimes there's no source file for this location
 868
 869         if {$filename == ""} {set filename Blank}
 870
 871 # If we want to switch files, we need to unpack the current text widget, and
 872 # stick in the new one.
 873
 874         if {$filename != $cfile} then {
 875                 pack forget $wins($cfile)
 876                 set cfile $filename
 877
 878 # Create a text widget for this file if necessary
 879
 880                 if ![info exists wins($cfile)] then {
 881                         set wins($cfile) [create_file_win $cfile]
 882                         if {$wins($cfile) != ".nofile"} {
 883                                 set win_to_file($wins($cfile)) $cfile
 884                                 set file_to_debug_file($cfile) $debug_file
 885                                 set pointers($cfile) 1.1
 886                                 }
 887                         }
 888
 889 # Pack the text widget into the listing widget, and scroll to the right place
 890
 891                 pack $wins($cfile) -side left -expand yes -in .listing -fill both -after .label
 892                 $wins($cfile) yview [expr $line - $screen_height / 2]
 893                 }
 894
 895 # Update the label widget in case the filename or function name has changed
 896
 897         if {$current_label != "$filename.$funcname"} then {
 898                 set tail [expr [string last / $filename] + 1]
 899                 .label configure -text "[string range $filename $tail end] : ${funcname}()"
 900                 set current_label $filename.$funcname
 901                 }
 902
 903 # Update the pointer, scrolling the text widget if necessary to keep the
 904 # pointer in an acceptable part of the screen.
 905
 906         if [info exists pointers($cfile)] then {
 907                 $wins($cfile) configure -state normal
 908                 set pointer_pos $pointers($cfile)
 909                 $wins($cfile) configure -state normal
 910                 $wins($cfile) delete $pointer_pos
 911                 $wins($cfile) insert $pointer_pos " "
 912
 913                 set pointer_pos [$wins($cfile) index $line.1]
 914                 set pointers($cfile) $pointer_pos
 915
 916                 $wins($cfile) delete $pointer_pos
 917                 $wins($cfile) insert $pointer_pos "\xbb"
 918
 919                 if {$line < $screen_top + 1
 920                     || $line > $screen_bot} then {
 921                         $wins($cfile) yview [expr $line - $screen_height / 2]
 922                         }
 923
 924                 $wins($cfile) configure -state disabled
 925                 }
 926 }
 927
 928 #
 929 # Local procedure:
 930 #
 931 #       update_ptr - Update the listing window.
 932 #
 933 # Description:
 934 #
 935 #       This routine will update the listing window using the result of
 936 #       gdb_loc.
 937 #
 938
 939 proc update_ptr {} {update_listing [gdb_loc]}
 940
 941 #
 942 # Local procedure:
 943 #
 944 #       asm_command - Open up the assembly window.
 945 #
 946 # Description:
 947 #
 948 #       Create an assembly window if it doesn't exist.
 949 #
 950
 951 proc asm_command {} {
 952         global cfunc
 953
 954         if ![winfo exists .asm] {
 955                 set cfunc *None*
 956                 set win [asm_win_name $cfunc]
 957
 958                 toplevel .asm
 959                 wm minsize .asm 1 1
 960                 wm title .asm Assembly
 961
 962                 label .asm.label -text "*NIL*" -borderwidth 2 -relief raised
 963                 text $win -height 25 -width 80 -relief raised -borderwidth 2 \
 964                         -setgrid true -cursor hand2 \
 965                         -yscrollcommand asmscrollproc
 966                 scrollbar .asm.scroll -orient vertical -command {$win yview}
 967                 frame .asm.buts
 968
 969                 button .asm.stepi -text Stepi \
 970                         -command {gdb_cmd stepi ; update_ptr}
 971                 button .asm.nexti -text Nexti \
 972                         -command {gdb_cmd nexti ; update_ptr}
 973                 button .asm.continue -text Continue \
 974                         -command {gdb_cmd continue ; update_ptr}
 975                 button .asm.finish -text Finish \
 976                         -command {gdb_cmd finish ; update_ptr}
 977                 button .asm.up -text Up -command {gdb_cmd up ; update_ptr}
 978                 button .asm.down -text Down \
 979                         -command {gdb_cmd down ; update_ptr}
 980                 button .asm.bottom -text Bottom \
 981                         -command {gdb_cmd {frame 0} ; update_ptr}
 982                 button .asm.close -text Close -command {destroy .asm}
 983
 984                 pack .asm.label -side top -fill x
 985                 pack .asm.stepi .asm.nexti .asm.continue .asm.finish .asm.up \
 986                      .asm.down .asm.bottom .asm.close -side left -in .asm.buts
 987                 pack .asm.buts -side top -fill x
 988                 pack $win -side left -expand yes -fill both
 989                 pack .asm.scroll -side left -fill y
 990
 991                 update
 992         }
 993 }
 994
 995 #
 996 # Local procedure:
 997 #
 998 #       registers_command - Open up the register display window.
 999 #
1000 # Description:
1001 #
1002 #       Create the register display window, with automatic updates.
1003 #
1004
1005 proc registers_command {} {
1006         global cfunc
1007
1008         if ![winfo exists .reg] {
1009                 toplevel .reg
1010                 wm minsize .reg 1 1
1011                 wm title .reg Registers
1012                 set win .reg.regs
1013
1014                 text $win -height 25 -width 80 -relief raised \
1015                         -borderwidth 2 \
1016                         -setgrid true -cursor hand2
1017
1018                 pack $win -side left -expand yes -fill both
1019         } else {
1020                 destroy .reg
1021         }
1022 }
1023
1024 #
1025 # Local procedure:
1026 #
1027 #       update_registers - Update the registers window.
1028 #
1029 # Description:
1030 #
1031 #       This procedure updates the registers window.
1032 #
1033
1034 proc update_registers {} {
1035         global current_output_win
1036
1037         set win .reg.regs
1038
1039         $win configure -state normal
1040
1041         $win delete 0.0 end
1042
1043         set current_output_win $win
1044         gdb_cmd "info registers"
1045         set current_output_win .command.text
1046
1047         $win yview 1
1048         $win configure -state disabled
1049 }
1050
1051 #
1052 # Local procedure:
1053 #
1054 #       update_assembly - Update the assembly window.
1055 #
1056 # Description:
1057 #
1058 #       This procedure updates the assembly window.
1059 #
1060
1061 proc update_assembly {linespec} {
1062         global asm_pointers
1063         global screen_height
1064         global screen_top
1065         global screen_bot
1066         global wins cfunc
1067         global current_label
1068         global win_to_file
1069         global file_to_debug_file
1070         global current_asm_label
1071         global pclist
1072         global asm_screen_height asm_screen_top asm_screen_bot
1073
1074 # Rip the linespec apart
1075
1076         set pc [lindex $linespec 4]
1077         set line [lindex $linespec 3]
1078         set filename [lindex $linespec 2]
1079         set funcname [lindex $linespec 1]
1080         set debug_file [lindex $linespec 0]
1081
1082         set win [asm_win_name $cfunc]
1083
1084 # Sometimes there's no source file for this location
1085
1086         if {$filename == ""} {set filename Blank}
1087
1088 # If we want to switch funcs, we need to unpack the current text widget, and
1089 # stick in the new one.
1090
1091         if {$funcname != $cfunc } {
1092                 pack forget $win
1093                 set cfunc $funcname
1094
1095                 set win [asm_win_name $cfunc]
1096
1097 # Create a text widget for this func if necessary
1098
1099                 if {![winfo exists $win]} {
1100                         create_asm_win $cfunc $pc
1101                         set asm_pointers($cfunc) 1.1
1102                         set current_asm_label NIL
1103                         }
1104
1105 # Pack the text widget, and scroll to the right place
1106
1107                 pack $win -side left -expand yes -fill both \
1108                         -after .asm.buts
1109                 set line [pc_to_line $pclist($cfunc) $pc]
1110                 $win yview [expr $line - $asm_screen_height / 2]
1111                 }
1112
1113 # Update the label widget in case the filename or function name has changed
1114
1115         if {$current_asm_label != "$pc $funcname"} then {
1116                 .asm.label configure -text "$pc $funcname"
1117                 set current_asm_label "$pc $funcname"
1118                 }
1119
1120 # Update the pointer, scrolling the text widget if necessary to keep the
1121 # pointer in an acceptable part of the screen.
1122
1123         if [info exists asm_pointers($cfunc)] then {
1124                 $win configure -state normal
1125                 set pointer_pos $asm_pointers($cfunc)
1126                 $win configure -state normal
1127                 $win delete $pointer_pos
1128                 $win insert $pointer_pos " "
1129
1130 # Map the PC back to a line in the window
1131
1132                 set line [pc_to_line $pclist($cfunc) $pc]
1133
1134                 if {$line == -1} {
1135                         echo "Can't find PC $pc"
1136                         return
1137                         }
1138
1139                 set pointer_pos [$win index $line.1]
1140                 set asm_pointers($cfunc) $pointer_pos
1141
1142                 $win delete $pointer_pos
1143                 $win insert $pointer_pos "\xbb"
1144
1145                 if {$line < $asm_screen_top + 1
1146                     || $line > $asm_screen_bot} then {
1147                         $win yview [expr $line - $asm_screen_height / 2]
1148                         }
1149
1150 #               echo "Picking line $line"
1151 #               $win yview -pickplace $line
1152
1153                 $win configure -state disabled
1154                 }
1155 }
1156
1157 proc update_ptr {} {
1158         update_listing [gdb_loc]
1159         if [winfo exists .asm] {
1160                 update_assembly [gdb_loc]
1161         }
1162         if [winfo exists .reg] {
1163                 update_registers
1164         }
1165 }
1166
1167 #
1168 # Window:
1169 #
1170 #       listing window - Define the listing window.
1171 #
1172 # Description:
1173 #
1174 #
1175
1176 # Setup listing window
1177
1178 frame .listing
1179
1180 wm minsize . 1 1
1181
1182 label .label -text "*No file*" -borderwidth 2 -relief raised
1183 text $wins($cfile) -height 25 -width 80 -relief raised -borderwidth 2 -yscrollcommand textscrollproc -setgrid true -cursor hand2
1184 scrollbar .scroll -orient vertical -command {$wins($cfile) yview}
1185
1186 if {[tk colormodel .text] == "color"} {
1187         set highlight "-background red2 -borderwidth 2 -relief sunk"
1188 } else {
1189         set fg [lindex [.text config -foreground] 4]
1190         set bg [lindex [.text config -background] 4]
1191         set highlight "-foreground $bg -background $fg -borderwidth 0"
1192 }
1193
1194 proc textscrollproc {args} {global screen_height screen_top screen_bot
1195                             eval ".scroll set $args"
1196                             set screen_height [lindex $args 1]
1197                             set screen_top [lindex $args 2]
1198                             set screen_bot [lindex $args 3]}
1199
1200 $wins($cfile) insert 0.0 "  This page intentionally left blank."
1201 $wins($cfile) configure -state disabled
1202
1203 pack .label -side bottom -fill x -in .listing
1204 pack $wins($cfile) -side left -expand yes -in .listing -fill both
1205 pack .scroll -side left -fill y -in .listing
1206
1207 button .start -text Start -command \
1208         {gdb_cmd {break main}
1209          gdb_cmd {enable delete $bpnum}
1210          gdb_cmd run
1211          update_ptr }
1212 button .step -text Step -command {gdb_cmd step ; update_ptr}
1213 button .next -text Next -command {gdb_cmd next ; update_ptr}
1214 button .continue -text Continue -command {gdb_cmd continue ; update_ptr}
1215 button .finish -text Finish -command {gdb_cmd finish ; update_ptr}
1216 #button .test -text Test -command {echo [info var]}
1217 button .exit -text Exit -command {gdb_cmd quit}
1218 button .up -text Up -command {gdb_cmd up ; update_ptr}
1219 button .down -text Down -command {gdb_cmd down ; update_ptr}
1220 button .bottom -text Bottom -command {gdb_cmd {frame 0} ; update_ptr}
1221 button .asm_but -text Asm -command {asm_command ; update_ptr}
1222 button .registers -text Regs -command {registers_command ; update_ptr}
1223
1224 proc files_command {} {
1225         toplevel .files_window
1226
1227         wm minsize .files_window 1 1
1228 #       wm overrideredirect .files_window true
1229         listbox .files_window.list -geometry 30x20 -setgrid true
1230         button .files_window.close -text Close -command {destroy .files_window}
1231         tk_listboxSingleSelect .files_window.list
1232         eval .files_window.list insert 0 [lsort [gdb_listfiles]]
1233         pack .files_window.list -side top -fill both -expand yes
1234         pack .files_window.close -side bottom -fill x -expand no -anchor s
1235         bind .files_window.list <Any-ButtonRelease-1> {
1236                 set file [%W get [%W curselection]]
1237                 gdb_cmd "list $file:1,0"
1238                 update_listing [gdb_loc $file:1]
1239                 destroy .files_window}
1240 }
1241
1242 button .files -text Files -command files_command
1243
1244 pack .listing -side bottom -fill both -expand yes
1245 #pack .test -side bottom -fill x
1246 pack .start .step .next .continue .finish .up .down .bottom .asm_but \
1247         .registers .files .exit -side left
1248 toplevel .command
1249 wm title .command Command
1250
1251 # Setup command window
1252
1253 label .command.label -text "* Command Buffer *" -borderwidth 2 -relief raised
1254 text .command.text -height 25 -width 80 -relief raised -borderwidth 2 -setgrid true -cursor hand2
1255
1256 pack .command.label -side top -fill x
1257 pack .command.text -side top -expand yes -fill both
1258
1259 set command_line {}
1260
1261 gdb_cmd {set language c}
1262 gdb_cmd {set height 0}
1263 gdb_cmd {set width 0}
1264
1265 bind .command.text <Any-Key> {
1266         global command_line
1267
1268         %W insert end %A
1269         %W yview -pickplace end
1270         append command_line %A
1271         }
1272 bind .command.text <Key-Return> {
1273         global command_line
1274
1275         %W insert end \n
1276         %W yview -pickplace end
1277         gdb_cmd $command_line
1278         set command_line {}
1279         update_ptr
1280         %W insert end "(gdb) "
1281         %W yview -pickplace end
1282         }
1283 bind .command.text <Enter> {focus %W}
1284 bind .command.text <Delete> {delete_char %W}
1285 bind .command.text <BackSpace> {delete_char %W}
1286 proc delete_char {win} {
1287         global command_line
1288
1289         tk_textBackspace $win
1290         $win yview -pickplace insert
1291         set tmp [expr [string length $command_line] - 2]
1292         set command_line [string range $command_line 0 $tmp]
1293 }
1294
1295 wm minsize .command 1 1