gdb/gdbtk.tcl

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