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 absolutely 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 #       not_implemented_yet - warn that a feature is unavailable
 696 #
 697 # Description:
 698 #
 699 #       This procedure warns that something doesn't actually work yet.
 700 #
 701
 702 proc not_implemented_yet {message} {
 703         tk_dialog .unimpl "gdb : unimpl" \
 704                 "$message: not implemented in the interface yet" \
 705                 {} 1 "OK"
 706 }
 707
 708 ##
 709 # Local procedure:
 710 #
 711 #       create_expr_win - Create expression display window
 712 #
 713 # Description:
 714 #
 715 #       Create the expression display window.
 716 #
 717
 718 proc create_expr_win {} {
 719         toplevel .expr
 720         wm minsize .expr 1 1
 721         wm title .expr Expression
 722         canvas .expr.c -yscrollcommand {.expr.scroll set} -cursor hand2 \
 723                 -borderwidth 2 -relief groove
 724         scrollbar .expr.scroll -orient vertical -command {.expr.c yview}
 725         entry .expr.entry -borderwidth 2 -relief groove
 726
 727         pack .expr.entry -side bottom -fill x
 728         pack .expr.c -side left -fill both -expand yes
 729         pack .expr.scroll -side right -fill y
 730
 731         .expr.c create text 100 0 -text "Text string"
 732         .expr.c create rectangle 245 195 255 205 -outline black -fill white
 733 }
 734
 735 #
 736 # Local procedure:
 737 #
 738 #       display_expression (expression) - Display EXPRESSION in display window
 739 #
 740 # Description:
 741 #
 742 #       Display EXPRESSION and its value in the expression display window.
 743 #
 744
 745 proc display_expression {expression} {
 746         if ![winfo exists .expr] {create_expr_win}
 747
 748
 749 }
 750
 751 #
 752 # Local procedure:
 753 #
 754 #       create_file_win (filename) - Create a win for FILENAME.
 755 #
 756 # Return value:
 757 #
 758 #       The new text widget.
 759 #
 760 # Description:
 761 #
 762 #       This procedure creates a text widget for FILENAME.  It returns the
 763 #       newly created widget.  First, a text widget is created, and given basic
 764 #       configuration info.  Second, all the bindings are setup.  Third, the
 765 #       file FILENAME is read into the text widget.  Fourth, margins and line
 766 #       numbers are added.
 767 #
 768
 769 proc create_file_win {filename debug_file} {
 770         global breakpoint_file
 771         global breakpoint_line
 772         global line_numbers
 773
 774 # Replace all the dirty characters in $filename with clean ones, and generate
 775 # a unique name for the text widget.
 776
 777         regsub -all {\.} $filename {} temp
 778         set win .src.text$temp
 779
 780 # Open the file, and read it into the text widget
 781
 782         if [catch "open $filename" fh] {
 783 # File can't be read.  Put error message into .src.nofile window and return.
 784
 785                 catch {destroy .src.nofile}
 786                 text .src.nofile -height 25 -width 88 -relief raised \
 787                         -borderwidth 2 -yscrollcommand textscrollproc \
 788                         -setgrid true -cursor hand2
 789                 .src.nofile insert 0.0 $fh
 790                 .src.nofile configure -state disabled
 791                 bind .src.nofile <1> do_nothing
 792                 bind .src.nofile <B1-Motion> do_nothing
 793                 return .src.nofile
 794         }
 795
 796 # Actually create and do basic configuration on the text widget.
 797
 798         text $win -height 25 -width 88 -relief raised -borderwidth 2 \
 799                 -yscrollcommand textscrollproc -setgrid true -cursor hand2
 800
 801 # Setup all the bindings
 802
 803         bind $win <Enter> {focus %W}
 804 #       bind $win <1> {listing_window_button_1 %W %X %Y %x %y}
 805         bind $win <1> do_nothing
 806         bind $win <B1-Motion> do_nothing
 807
 808         bind $win n {catch {gdb_cmd next} ; update_ptr}
 809         bind $win s {catch {gdb_cmd step} ; update_ptr}
 810         bind $win c {catch {gdb_cmd continue} ; update_ptr}
 811         bind $win f {catch {gdb_cmd finish} ; update_ptr}
 812         bind $win u {catch {gdb_cmd up} ; update_ptr}
 813         bind $win d {catch {gdb_cmd down} ; update_ptr}
 814
 815         $win delete 0.0 end
 816         $win insert 0.0 [read $fh]
 817         close $fh
 818
 819 # Add margins (for annotations) and a line number to each line (if requested)
 820
 821         set numlines [$win index end]
 822         set numlines [lindex [split $numlines .] 0]
 823         if $line_numbers {
 824                 for {set i 1} {$i <= $numlines} {incr i} {
 825                         $win insert $i.0 [format "   %4d " $i]
 826                         $win tag add source $i.8 "$i.0 lineend"
 827                         }
 828         } else {
 829                 for {set i 1} {$i <= $numlines} {incr i} {
 830                         $win insert $i.0 "        "
 831                         $win tag add source $i.8 "$i.0 lineend"
 832                         }
 833         }
 834
 835 # Add the breakdots
 836
 837         foreach i [gdb_sourcelines $debug_file] {
 838                 $win delete $i.0
 839                 $win insert $i.0 "\xa4"
 840                 $win tag add margin $i.0 $i.8
 841                 }
 842
 843         $win tag bind margin <1> {listing_window_button_1 %W %X %Y %x %y}
 844         $win tag bind source <1> {
 845                 %W mark set anchor "@%x,%y wordstart"
 846                 set last [%W index "@%x,%y wordend"]
 847                 %W tag remove sel 0.0 anchor
 848                 %W tag remove sel $last end
 849                 %W tag add sel anchor $last
 850                 }
 851 #       $win tag bind source <Double-Button-1> {
 852 #               %W mark set anchor "@%x,%y wordstart"
 853 #               set last [%W index "@%x,%y wordend"]
 854 #               %W tag remove sel 0.0 anchor
 855 #               %W tag remove sel $last end
 856 #               %W tag add sel anchor $last
 857 #               echo "Selected [selection get]"
 858 #               }
 859         $win tag bind source <B1-Motion> {
 860                 %W tag remove sel 0.0 anchor
 861                 %W tag remove sel $last end
 862                 %W tag add sel anchor @%x,%y
 863                 }
 864         $win tag bind sel <1> do_nothing
 865         $win tag bind sel <Double-Button-1> {display_expression [selection get]}
 866         $win tag raise sel
 867
 868
 869 # Scan though the breakpoint data base and install any destined for this file
 870
 871         foreach bpnum [array names breakpoint_file] {
 872                 if {$breakpoint_file($bpnum) == $filename} {
 873                         insert_breakpoint_tag $win $breakpoint_line($bpnum)
 874                         }
 875                 }
 876
 877 # Disable the text widget to prevent user modifications
 878
 879         $win configure -state disabled
 880         return $win
 881 }
 882
 883 #
 884 # Local procedure:
 885 #
 886 #       create_asm_win (funcname pc) - Create an assembly win for FUNCNAME.
 887 #
 888 # Return value:
 889 #
 890 #       The new text widget.
 891 #
 892 # Description:
 893 #
 894 #       This procedure creates a text widget for FUNCNAME.  It returns the
 895 #       newly created widget.  First, a text widget is created, and given basic
 896 #       configuration info.  Second, all the bindings are setup.  Third, the
 897 #       function FUNCNAME is read into the text widget.
 898 #
 899
 900 proc create_asm_win {funcname pc} {
 901         global breakpoint_file
 902         global breakpoint_line
 903         global current_output_win
 904         global pclist
 905
 906 # Replace all the dirty characters in $filename with clean ones, and generate
 907 # a unique name for the text widget.
 908
 909         set win [asm_win_name $funcname]
 910
 911 # Actually create and do basic configuration on the text widget.
 912
 913         text $win -height 25 -width 88 -relief raised -borderwidth 2 \
 914                 -setgrid true -cursor hand2 -yscrollcommand asmscrollproc
 915
 916 # Setup all the bindings
 917
 918         bind $win <Enter> {focus %W}
 919         bind $win <1> {asm_window_button_1 %W %X %Y %x %y}
 920         bind $win <B1-Motion> do_nothing
 921         bind $win n {catch {gdb_cmd nexti} ; update_ptr}
 922         bind $win s {catch {gdb_cmd stepi} ; update_ptr}
 923         bind $win c {catch {gdb_cmd continue} ; update_ptr}
 924         bind $win f {catch {gdb_cmd finish} ; update_ptr}
 925         bind $win u {catch {gdb_cmd up} ; update_ptr}
 926         bind $win d {catch {gdb_cmd down} ; update_ptr}
 927
 928 # Disassemble the code, and read it into the new text widget
 929
 930         set temp $current_output_win
 931         set current_output_win $win
 932         gdb_cmd "disassemble $pc"
 933         set current_output_win $temp
 934
 935         set numlines [$win index end]
 936         set numlines [lindex [split $numlines .] 0]
 937         decr numlines
 938
 939 # Delete the first and last lines, cuz these contain useless info
 940
 941         $win delete 1.0 2.0
 942         $win delete {end - 1 lines} end
 943         decr numlines 2
 944
 945 # Add margins (for annotations) and note the PC for each line
 946
 947         catch "unset pclist($funcname)"
 948         lappend pclist($funcname) Unused
 949         for {set i 1} {$i <= $numlines} {incr i} {
 950                 scan [$win get $i.0 "$i.0 lineend"] "%s " pc
 951                 lappend pclist($funcname) $pc
 952                 $win insert $i.0 "    "
 953                 }
 954
 955
 956 # Scan though the breakpoint data base and install any destined for this file
 957
 958 #       foreach bpnum [array names breakpoint_file] {
 959 #               if {$breakpoint_file($bpnum) == $filename} {
 960 #                       insert_breakpoint_tag $win $breakpoint_line($bpnum)
 961 #                       }
 962 #               }
 963
 964 # Disable the text widget to prevent user modifications
 965
 966         $win configure -state disabled
 967         return $win
 968 }
 969
 970 #
 971 # Local procedure:
 972 #
 973 #       asmscrollproc (WINHEIGHT SCREENHEIGHT SCREENTOP SCREENBOT) - Update the
 974 #       asm window scrollbar.
 975 #
 976 # Description:
 977 #
 978 #       This procedure is called to update the assembler window's scrollbar.
 979 #
 980
 981 proc asmscrollproc {args} {
 982         global asm_screen_height asm_screen_top asm_screen_bot
 983
 984         eval ".asm.scroll set $args"
 985         set asm_screen_height [lindex $args 1]
 986         set asm_screen_top [lindex $args 2]
 987         set asm_screen_bot [lindex $args 3]
 988 }
 989
 990 #
 991 # Local procedure:
 992 #
 993 #       update_listing (linespec) - Update the listing window according to
 994 #                                   LINESPEC.
 995 #
 996 # Description:
 997 #
 998 #       This procedure is called from various places to update the listing
 999 #       window based on LINESPEC.  It is usually invoked with the result of
1000 #       gdb_loc.
1001 #
1002 #       It will move the cursor, and scroll the text widget if necessary.
1003 #       Also, it will switch to another text widget if necessary, and update
1004 #       the label widget too.
1005 #
1006 #       LINESPEC is a list of the form:
1007 #
1008 #       { DEBUG_FILE FUNCNAME FILENAME LINE }, where:
1009 #
1010 #       DEBUG_FILE - is the abbreviated form of the file name.  This is usually
1011 #                    the file name string given to the cc command.  This is
1012 #                    primarily needed for breakpoint commands, and when an
1013 #                    abbreviated for of the filename is desired.
1014 #       FUNCNAME - is the name of the function.
1015 #       FILENAME - is the fully qualified (absolute) file name.  It is usually
1016 #                  the same as $PWD/$DEBUG_FILE, where PWD is the working dir
1017 #                  at the time the cc command was given.  This is used to
1018 #                  actually locate the file to be displayed.
1019 #       LINE - The line number to be displayed.
1020 #
1021 #       Usually, this procedure will just move the cursor one line down to the
1022 #       next line to be executed.  However, if the cursor moves out of range
1023 #       or into another file, it will scroll the text widget so that the line
1024 #       of interest is in the middle of the viewable portion of the widget.
1025 #
1026
1027 proc update_listing {linespec} {
1028         global pointers
1029         global screen_height
1030         global screen_top
1031         global screen_bot
1032         global wins cfile
1033         global current_label
1034         global win_to_file
1035         global file_to_debug_file
1036         global .src.label
1037
1038 # Rip the linespec apart
1039
1040         set line [lindex $linespec 3]
1041         set filename [lindex $linespec 2]
1042         set funcname [lindex $linespec 1]
1043         set debug_file [lindex $linespec 0]
1044
1045 # Sometimes there's no source file for this location
1046
1047         if {$filename == ""} {set filename Blank}
1048
1049 # If we want to switch files, we need to unpack the current text widget, and
1050 # stick in the new one.
1051
1052         if {$filename != $cfile} then {
1053                 pack forget $wins($cfile)
1054                 set cfile $filename
1055
1056 # Create a text widget for this file if necessary
1057
1058                 if ![info exists wins($cfile)] then {
1059                         set wins($cfile) [create_file_win $cfile $debug_file]
1060                         if {$wins($cfile) != ".src.nofile"} {
1061                                 set win_to_file($wins($cfile)) $cfile
1062                                 set file_to_debug_file($cfile) $debug_file
1063                                 set pointers($cfile) 1.1
1064                                 }
1065                         }
1066
1067 # Pack the text widget into the listing widget, and scroll to the right place
1068
1069                 pack $wins($cfile) -side left -expand yes -in .src.info \
1070                         -fill both -after .src.scroll
1071
1072 # Make the scrollbar point at the new text widget
1073
1074                 .src.scroll configure -command "$wins($cfile) yview"
1075
1076                 $wins($cfile) yview [expr $line - $screen_height / 2]
1077                 }
1078
1079 # Update the label widget in case the filename or function name has changed
1080
1081         if {$current_label != "$filename.$funcname"} then {
1082                 set tail [expr [string last / $filename] + 1]
1083                 set .src.label "[string range $filename $tail end] : ${funcname}()"
1084 #               .src.label configure -text "[string range $filename $tail end] : ${funcname}()"
1085                 set current_label $filename.$funcname
1086                 }
1087
1088 # Update the pointer, scrolling the text widget if necessary to keep the
1089 # pointer in an acceptable part of the screen.
1090
1091         if [info exists pointers($cfile)] then {
1092                 $wins($cfile) configure -state normal
1093                 set pointer_pos $pointers($cfile)
1094                 $wins($cfile) configure -state normal
1095                 $wins($cfile) delete $pointer_pos "$pointer_pos + 2 char"
1096                 $wins($cfile) insert $pointer_pos "  "
1097
1098                 set pointer_pos [$wins($cfile) index $line.1]
1099                 set pointers($cfile) $pointer_pos
1100
1101                 $wins($cfile) delete $pointer_pos "$pointer_pos + 2 char"
1102                 $wins($cfile) insert $pointer_pos "->"
1103
1104                 if {$line < $screen_top + 1
1105                     || $line > $screen_bot} then {
1106                         $wins($cfile) yview [expr $line - $screen_height / 2]
1107                         }
1108
1109                 $wins($cfile) configure -state disabled
1110                 }
1111 }
1112
1113 #
1114 # Local procedure:
1115 #
1116 #       create_asm_window - Open up the assembly window.
1117 #
1118 # Description:
1119 #
1120 #       Create an assembly window if it doesn't exist.
1121 #
1122
1123 proc create_asm_window {} {
1124         global cfunc
1125
1126         if ![winfo exists .asm] {
1127                 set cfunc *None*
1128                 set win [asm_win_name $cfunc]
1129
1130                 build_framework .asm Assembly "*NIL*"
1131
1132                 .asm.text configure -yscrollcommand asmscrollproc
1133
1134                 frame .asm.row1
1135                 frame .asm.row2
1136
1137                 button .asm.stepi -width 6 -text Stepi \
1138                         -command {catch {gdb_cmd stepi} ; update_ptr}
1139                 button .asm.nexti -width 6 -text Nexti \
1140                         -command {catch {gdb_cmd nexti} ; update_ptr}
1141                 button .asm.continue -width 6 -text Cont \
1142                         -command {catch {gdb_cmd continue} ; update_ptr}
1143                 button .asm.finish -width 6 -text Finish \
1144                         -command {catch {gdb_cmd finish} ; update_ptr}
1145                 button .asm.up -width 6 -text Up -command {catch {gdb_cmd up} ; update_ptr}
1146                 button .asm.down -width 6 -text Down \
1147                         -command {catch {gdb_cmd down} ; update_ptr}
1148                 button .asm.bottom -width 6 -text Bottom \
1149                         -command {catch {gdb_cmd {frame 0}} ; update_ptr}
1150
1151                 pack .asm.stepi .asm.continue .asm.up .asm.bottom -side left -padx 3 -pady 5 -in .asm.row1
1152                 pack .asm.nexti .asm.finish .asm.down -side left -padx 3 -pady 5 -in .asm.row2
1153
1154                 pack .asm.row2 .asm.row1 -side bottom -anchor w -before .asm.info
1155
1156                 update
1157
1158                 update_assembly [gdb_loc]
1159         }
1160 }
1161
1162 proc reg_config_menu {} {
1163         catch {destroy .reg.config}
1164         toplevel .reg.config
1165         wm geometry .reg.config +300+300
1166         wm title .reg.config "Register configuration"
1167         wm iconname .reg.config "Reg config"
1168         set regnames [gdb_regnames]
1169         set num_regs [llength $regnames]
1170
1171         frame .reg.config.buts
1172
1173         button .reg.config.done -text " Done " -command "
1174                 recompute_reg_display_list $num_regs
1175                 populate_reg_window
1176                 update_registers all
1177                 destroy .reg.config "
1178
1179         button .reg.config.update -text Update -command "
1180                 recompute_reg_display_list $num_regs
1181                 populate_reg_window
1182                 update_registers all "
1183
1184         pack .reg.config.buts -side bottom -fill x
1185
1186         pack .reg.config.done -side left -fill x -expand yes -in .reg.config.buts
1187         pack .reg.config.update -side right -fill x -expand yes -in .reg.config.buts
1188
1189 # Since there can be lots of registers, we build the window with no more than
1190 # 32 rows, and as many columns as needed.
1191
1192 # First, figure out how many columns we need and create that many column frame
1193 # widgets
1194
1195         set ncols [expr ($num_regs + 31) / 32]
1196
1197         for {set col 0} {$col < $ncols} {incr col} {
1198                 frame .reg.config.col$col
1199                 pack .reg.config.col$col -side left -anchor n
1200         }
1201
1202 # Now, create the checkbutton widgets and pack them in the appropriate columns
1203
1204         set col 0
1205         set row 0
1206         for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
1207                 set regname [lindex $regnames $regnum]
1208                 checkbutton .reg.config.col$col.$row -text $regname -pady 0 \
1209                         -variable regena($regnum) -relief flat -anchor w -bd 1
1210
1211                 pack .reg.config.col$col.$row -side top -fill both
1212
1213                 incr row
1214                 if {$row >= 32} {
1215                         incr col
1216                         set row 0
1217                 }
1218         }
1219 }
1220
1221 #
1222 # Local procedure:
1223 #
1224 #       create_registers_window - Open up the register display window.
1225 #
1226 # Description:
1227 #
1228 #       Create the register display window, with automatic updates.
1229 #
1230
1231 proc create_registers_window {} {
1232         global reg_format
1233
1234         if [winfo exists .reg] return
1235
1236 # Create an initial register display list consisting of all registers
1237
1238         if ![info exists reg_format] {
1239                 global reg_display_list
1240                 global changed_reg_list
1241                 global regena
1242
1243                 set reg_format {}
1244                 set num_regs [llength [gdb_regnames]]
1245                 for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
1246                         set regena($regnum) 1
1247                 }
1248                 recompute_reg_display_list $num_regs
1249                 set changed_reg_list $reg_display_list
1250         }
1251
1252         build_framework .reg Registers
1253
1254 # First, delete all the old menu entries
1255
1256         .reg.menubar.view.menu delete 0 last
1257
1258 # Hex menu item
1259         .reg.menubar.view.menu add radiobutton -variable reg_format \
1260                 -label Hex -value x -command {update_registers all}
1261
1262 # Decimal menu item
1263         .reg.menubar.view.menu add radiobutton -variable reg_format \
1264                 -label Decimal -value d -command {update_registers all}
1265
1266 # Octal menu item
1267         .reg.menubar.view.menu add radiobutton -variable reg_format \
1268                 -label Octal -value o -command {update_registers all}
1269
1270 # Natural menu item
1271         .reg.menubar.view.menu add radiobutton -variable reg_format \
1272                 -label Natural -value {} -command {update_registers all}
1273
1274 # Config menu item
1275         .reg.menubar.view.menu add separator
1276
1277         .reg.menubar.view.menu add command -label Config -command {
1278                 reg_config_menu }
1279
1280         destroy .reg.label
1281
1282 # Install the reg names
1283
1284         populate_reg_window
1285         update_registers all
1286 }
1287
1288 # Convert regena into a list of the enabled $regnums
1289
1290 proc recompute_reg_display_list {num_regs} {
1291         global reg_display_list
1292         global regmap
1293         global regena
1294
1295         catch {unset reg_display_list}
1296
1297         set line 1
1298         for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
1299
1300                 if {[set regena($regnum)] != 0} {
1301                         lappend reg_display_list $regnum
1302                         set regmap($regnum) $line
1303                         incr line
1304                 }
1305         }
1306 }
1307
1308 # Fill out the register window with the names of the regs specified in
1309 # reg_display_list.
1310
1311 proc populate_reg_window {} {
1312         global max_regname_width
1313         global reg_display_list
1314
1315         .reg.text configure -state normal
1316
1317         .reg.text delete 0.0 end
1318
1319         set regnames [eval gdb_regnames $reg_display_list]
1320
1321 # Figure out the longest register name
1322
1323         set max_regname_width 0
1324
1325         foreach reg $regnames {
1326                 set len [string length $reg]
1327                 if {$len > $max_regname_width} {set max_regname_width $len}
1328         }
1329
1330         set width [expr $max_regname_width + 15]
1331
1332         set height [llength $regnames]
1333
1334         if {$height > 60} {set height 60}
1335
1336         .reg.text configure -height $height -width $width
1337
1338         foreach reg $regnames {
1339                 .reg.text insert end [format "%-*s \n" $max_regname_width ${reg}]
1340         }
1341
1342         .reg.text yview 0
1343         .reg.text configure -state disabled
1344 }
1345
1346 #
1347 # Local procedure:
1348 #
1349 #       update_registers - Update the registers window.
1350 #
1351 # Description:
1352 #
1353 #       This procedure updates the registers window.
1354 #
1355
1356 proc update_registers {which} {
1357         global max_regname_width
1358         global reg_format
1359         global reg_display_list
1360         global changed_reg_list
1361         global highlight
1362         global regmap
1363
1364         set margin [expr $max_regname_width + 1]
1365         set win .reg.text
1366         set winwidth [lindex [$win configure -width] 4]
1367         set valwidth [expr $winwidth - $margin]
1368
1369         $win configure -state normal
1370
1371         if {$which == "all"} {
1372                 set lineindex 1
1373                 foreach regnum $reg_display_list {
1374                         set regval [gdb_fetch_registers $reg_format $regnum]
1375                         set regval [format "%-*s" $valwidth $regval]
1376                         $win delete $lineindex.$margin "$lineindex.0 lineend"
1377                         $win insert $lineindex.$margin $regval
1378                         incr lineindex
1379                 }
1380                 $win configure -state disabled
1381                 return
1382         }
1383
1384 # Unhighlight the old values
1385
1386         foreach regnum $changed_reg_list {
1387                 $win tag delete $win.$regnum
1388         }
1389
1390 # Now, highlight the changed values of the interesting registers
1391
1392         set changed_reg_list [eval gdb_changed_register_list $reg_display_list]
1393
1394         set lineindex 1
1395         foreach regnum $changed_reg_list {
1396                 set regval [gdb_fetch_registers $reg_format $regnum]
1397                 set regval [format "%-*s" $valwidth $regval]
1398
1399                 set lineindex $regmap($regnum)
1400                 $win delete $lineindex.$margin "$lineindex.0 lineend"
1401                 $win insert $lineindex.$margin $regval
1402                 $win tag add $win.$regnum $lineindex.0 "$lineindex.0 lineend"
1403                 eval $win tag configure $win.$regnum $highlight
1404         }
1405
1406         $win configure -state disabled
1407 }
1408
1409 #
1410 # Local procedure:
1411 #
1412 #       update_assembly - Update the assembly window.
1413 #
1414 # Description:
1415 #
1416 #       This procedure updates the assembly window.
1417 #
1418
1419 proc update_assembly {linespec} {
1420         global asm_pointers
1421         global screen_height
1422         global screen_top
1423         global screen_bot
1424         global wins cfunc
1425         global current_label
1426         global win_to_file
1427         global file_to_debug_file
1428         global current_asm_label
1429         global pclist
1430         global asm_screen_height asm_screen_top asm_screen_bot
1431         global .asm.label
1432
1433 # Rip the linespec apart
1434
1435         set pc [lindex $linespec 4]
1436         set line [lindex $linespec 3]
1437         set filename [lindex $linespec 2]
1438         set funcname [lindex $linespec 1]
1439         set debug_file [lindex $linespec 0]
1440
1441         set win [asm_win_name $cfunc]
1442
1443 # Sometimes there's no source file for this location
1444
1445         if {$filename == ""} {set filename Blank}
1446
1447 # If we want to switch funcs, we need to unpack the current text widget, and
1448 # stick in the new one.
1449
1450         if {$funcname != $cfunc } {
1451                 set oldwin $win
1452                 set cfunc $funcname
1453
1454                 set win [asm_win_name $cfunc]
1455
1456 # Create a text widget for this func if necessary
1457
1458                 if {![winfo exists $win]} {
1459                         create_asm_win $cfunc $pc
1460                         set asm_pointers($cfunc) 1.1
1461                         set current_asm_label NIL
1462                         }
1463
1464 # Pack the text widget, and scroll to the right place
1465
1466                 pack forget $oldwin
1467                 pack $win -side left -expand yes -fill both \
1468                         -after .asm.scroll
1469                 .asm.scroll configure -command "$win yview"
1470                 set line [pc_to_line $pclist($cfunc) $pc]
1471                 update
1472                 $win yview [expr $line - $asm_screen_height / 2]
1473                 }
1474
1475 # Update the label widget in case the filename or function name has changed
1476
1477         if {$current_asm_label != "$pc $funcname"} then {
1478                 set .asm.label "$pc $funcname"
1479                 set current_asm_label "$pc $funcname"
1480                 }
1481
1482 # Update the pointer, scrolling the text widget if necessary to keep the
1483 # pointer in an acceptable part of the screen.
1484
1485         if [info exists asm_pointers($cfunc)] then {
1486                 $win configure -state normal
1487                 set pointer_pos $asm_pointers($cfunc)
1488                 $win configure -state normal
1489                 $win delete $pointer_pos "$pointer_pos + 2 char"
1490                 $win insert $pointer_pos "  "
1491
1492 # Map the PC back to a line in the window
1493
1494                 set line [pc_to_line $pclist($cfunc) $pc]
1495
1496                 if {$line == -1} {
1497                         echo "Can't find PC $pc"
1498                         return
1499                         }
1500
1501                 set pointer_pos [$win index $line.1]
1502                 set asm_pointers($cfunc) $pointer_pos
1503
1504                 $win delete $pointer_pos "$pointer_pos + 2 char"
1505                 $win insert $pointer_pos "->"
1506
1507                 if {$line < $asm_screen_top + 1
1508                     || $line > $asm_screen_bot} then {
1509                         $win yview [expr $line - $asm_screen_height / 2]
1510                         }
1511
1512                 $win configure -state disabled
1513                 }
1514 }
1515
1516 #
1517 # Local procedure:
1518 #
1519 #       update_ptr - Update the listing window.
1520 #
1521 # Description:
1522 #
1523 #       This routine will update the listing window using the result of
1524 #       gdb_loc.
1525 #
1526
1527 proc update_ptr {} {
1528         update_listing [gdb_loc]
1529         if [winfo exists .asm] {
1530                 update_assembly [gdb_loc]
1531         }
1532         if [winfo exists .reg] {
1533                 update_registers changed
1534         }
1535 }
1536
1537 # Make toplevel window disappear
1538
1539 wm withdraw .
1540
1541 proc files_command {} {
1542         toplevel .files_window
1543
1544         wm minsize .files_window 1 1
1545 #       wm overrideredirect .files_window true
1546         listbox .files_window.list -geometry 30x20 -setgrid true
1547         button .files_window.close -text Close -command {destroy .files_window}
1548         tk_listboxSingleSelect .files_window.list
1549         eval .files_window.list insert 0 [lsort [gdb_listfiles]]
1550         pack .files_window.list -side top -fill both -expand yes
1551         pack .files_window.close -side bottom -fill x -expand no -anchor s
1552         bind .files_window.list <Any-ButtonRelease-1> {
1553                 set file [%W get [%W curselection]]
1554                 gdb_cmd "list $file:1,0"
1555                 update_listing [gdb_loc $file:1]
1556                 destroy .files_window}
1557 }
1558
1559 button .files -text Files -command files_command
1560
1561 # Setup command window
1562
1563 proc build_framework {win {title GDBtk} {label {}}} {
1564         global ${win}.label
1565
1566         toplevel ${win}
1567         wm title ${win} $title
1568         wm minsize ${win} 1 1
1569
1570         frame ${win}.menubar
1571
1572         menubutton ${win}.menubar.file -padx 12 -text File \
1573                 -menu ${win}.menubar.file.menu -underline 0
1574
1575         menu ${win}.menubar.file.menu
1576         ${win}.menubar.file.menu add command -label File... \
1577                 -command {
1578                   set filename [FSBox "File" "a.out"]
1579                   gdb_cmd "file $filename"
1580                   update_ptr
1581               }
1582         ${win}.menubar.file.menu add command -label Target... \
1583                 -command { not_implemented_yet "target" }
1584         ${win}.menubar.file.menu add command -label Edit \
1585                 -command {exec $editor +[expr ($screen_top + $screen_bot)/2] $cfile &}
1586         ${win}.menubar.file.menu add separator
1587         ${win}.menubar.file.menu add command -label "Exec File..." \
1588                 -command {
1589                   set filename [FSBox "Exec File" "a.out"]
1590                   gdb_cmd "exec-file $filename"
1591                   update_ptr
1592               }
1593         ${win}.menubar.file.menu add command -label "Symbol File..." \
1594                 -command {
1595                   set filename [FSBox "Symbol File" "a.out"]
1596                   gdb_cmd "symbol-file $filename"
1597                   update_ptr
1598               }
1599         ${win}.menubar.file.menu add command -label "Add Symbol File..." \
1600                 -command { not_implemented_yet "menu item, add symbol file" }
1601         ${win}.menubar.file.menu add command -label "Core File..." \
1602                 -command {
1603                   set filename [FSBox "Core File" "core"]
1604                   gdb_cmd "core-file $filename"
1605                   update_ptr
1606               }
1607         ${win}.menubar.file.menu add separator
1608         ${win}.menubar.file.menu add command -label Close \
1609                 -command "destroy ${win}"
1610         ${win}.menubar.file.menu add separator
1611         ${win}.menubar.file.menu add command -label Quit \
1612                 -command { catch { gdb_cmd quit } }
1613
1614         menubutton ${win}.menubar.commands -padx 12 -text Commands \
1615                 -menu ${win}.menubar.commands.menu -underline 0
1616
1617         menu ${win}.menubar.commands.menu
1618         ${win}.menubar.commands.menu add command -label Run \
1619                 -command { catch  {gdb_cmd run } ; update_ptr }
1620         ${win}.menubar.commands.menu add command -label Step \
1621                 -command { catch { gdb_cmd step } ; update_ptr }
1622         ${win}.menubar.commands.menu add command -label Next \
1623                 -command { catch { gdb_cmd next } ; update_ptr }
1624         ${win}.menubar.commands.menu add command -label Continue \
1625                 -command { catch { gdb_cmd continue } ; update_ptr }
1626         ${win}.menubar.commands.menu add separator
1627         ${win}.menubar.commands.menu add command -label Stepi \
1628                 -command { catch { gdb_cmd stepi } ; update_ptr }
1629         ${win}.menubar.commands.menu add command -label Nexti \
1630                 -command { catch { gdb_cmd nexti } ; update_ptr }
1631
1632         menubutton ${win}.menubar.view -padx 12 -text View \
1633                 -menu ${win}.menubar.view.menu -underline 0
1634
1635         menu ${win}.menubar.view.menu
1636         ${win}.menubar.view.menu add command -label Hex \
1637                 -command {echo Hex}
1638         ${win}.menubar.view.menu add command -label Decimal \
1639                 -command {echo Decimal}
1640         ${win}.menubar.view.menu add command -label Octal \
1641                 -command {echo Octal}
1642
1643         menubutton ${win}.menubar.window -padx 12 -text Window \
1644                 -menu ${win}.menubar.window.menu -underline 0
1645
1646         menu ${win}.menubar.window.menu
1647         ${win}.menubar.window.menu add command -label Command \
1648                 -command {echo Command}
1649         ${win}.menubar.window.menu add separator
1650         ${win}.menubar.window.menu add command -label Source \
1651                 -command {echo Source}
1652         ${win}.menubar.window.menu add command -label Assembly \
1653                 -command {create_asm_window ; update_ptr}
1654         ${win}.menubar.window.menu add separator
1655         ${win}.menubar.window.menu add command -label Registers \
1656                 -command {create_registers_window ; update_ptr}
1657         ${win}.menubar.window.menu add command -label Stack \
1658                 -command { not_implemented_yet "stack window" }
1659         ${win}.menubar.window.menu add separator
1660         ${win}.menubar.window.menu add command -label Files \
1661                 -command { not_implemented_yet "files window" }
1662         ${win}.menubar.window.menu add separator
1663         ${win}.menubar.window.menu add command -label Breakpoints \
1664                 -command { not_implemented_yet "breakpoints window" }
1665         ${win}.menubar.window.menu add command -label Signals \
1666                 -command { not_implemented_yet "signals window" }
1667         ${win}.menubar.window.menu add command -label Variables \
1668                 -command { not_implemented_yet "variables window" }
1669
1670         menubutton ${win}.menubar.help -padx 12 -text Help \
1671                 -menu ${win}.menubar.help.menu -underline 0
1672
1673         menu ${win}.menubar.help.menu
1674         ${win}.menubar.help.menu add command -label "with GDBtk" \
1675                 -command {echo "with GDBtk"}
1676         ${win}.menubar.help.menu add command -label "with this window" \
1677                 -command {echo "with this window"}
1678         ${win}.menubar.help.menu add command -label "Report bug" \
1679                 -command {exec send-pr}
1680
1681         tk_menuBar ${win}.menubar \
1682                 ${win}.menubar.file \
1683                 ${win}.menubar.commands \
1684                 ${win}.menubar.view \
1685                 ${win}.menubar.window \
1686                 ${win}.menubar.help
1687         pack    ${win}.menubar.file \
1688                 ${win}.menubar.commands \
1689                 ${win}.menubar.view \
1690                 ${win}.menubar.window -side left
1691         pack    ${win}.menubar.help -side right
1692
1693         frame ${win}.info
1694         text ${win}.text -height 25 -width 80 -relief raised -borderwidth 2 \
1695                 -setgrid true -cursor hand2 -yscrollcommand "${win}.scroll set"
1696
1697         set ${win}.label $label
1698         label ${win}.label -textvariable ${win}.label -borderwidth 2 -relief raised
1699
1700         scrollbar ${win}.scroll -orient vertical -command "${win}.text yview"
1701
1702         pack ${win}.label -side bottom -fill x -in ${win}.info
1703         pack ${win}.scroll -side right -fill y -in ${win}.info
1704         pack ${win}.text -side left -expand yes -fill both -in ${win}.info
1705
1706         pack ${win}.menubar -side top -fill x
1707         pack ${win}.info -side top -fill both -expand yes
1708 }
1709
1710 proc create_source_window {} {
1711         global wins
1712         global cfile
1713
1714         build_framework .src Source "*No file*"
1715
1716 # First, delete all the old view menu entries
1717
1718         .src.menubar.view.menu delete 0 last
1719
1720 # Source file selection
1721         .src.menubar.view.menu add command -label "Select source file" \
1722                 -command files_command
1723
1724 # Line numbers enable/disable menu item
1725         .src.menubar.view.menu add checkbutton -variable line_numbers \
1726                 -label "Line numbers" -onvalue 1 -offvalue 0 -command {
1727                 foreach source [array names wins] {
1728                         if {$source == "Blank"} continue
1729                         destroy $wins($source)
1730                         unset wins($source)
1731                         }
1732                 set cfile Blank
1733                 update_listing [gdb_loc]
1734                 }
1735
1736         frame .src.row1
1737         frame .src.row2
1738
1739         button .src.start -width 6 -text Start -command \
1740                 {catch {gdb_cmd {break main}}
1741                  catch {gdb_cmd {enable delete $bpnum}}
1742                  catch {gdb_cmd run}
1743                  update_ptr }
1744         button .src.stop -width 6 -text Stop -fg red -activeforeground red \
1745                 -state disabled -command gdb_stop
1746         button .src.step -width 6 -text Step \
1747                 -command {catch {gdb_cmd step} ; update_ptr}
1748         button .src.next -width 6 -text Next \
1749                 -command {catch {gdb_cmd next} ; update_ptr}
1750         button .src.continue -width 6 -text Cont \
1751                 -command {catch {gdb_cmd continue} ; update_ptr}
1752         button .src.finish -width 6 -text Finish \
1753                 -command {catch {gdb_cmd finish} ; update_ptr}
1754         button .src.up -width 6 -text Up \
1755                 -command {catch {gdb_cmd up} ; update_ptr}
1756         button .src.down -width 6 -text Down \
1757                 -command {catch {gdb_cmd down} ; update_ptr}
1758         button .src.bottom -width 6 -text Bottom \
1759                 -command {catch {gdb_cmd {frame 0}} ; update_ptr}
1760
1761         pack .src.start .src.step .src.continue .src.up .src.bottom \
1762                 -side left -padx 3 -pady 5 -in .src.row1
1763         pack .src.stop .src.next .src.finish .src.down -side left -padx 3 \
1764                 -pady 5 -in .src.row2
1765
1766         pack .src.row2 .src.row1 -side bottom -anchor w -before .src.info
1767
1768         $wins($cfile) insert 0.0 "  This page intentionally left blank."
1769         $wins($cfile) configure -width 88 -state disabled \
1770                 -yscrollcommand textscrollproc
1771
1772         proc textscrollproc {args} {global screen_height screen_top screen_bot
1773                                     eval ".src.scroll set $args"
1774                                     set screen_height [lindex $args 1]
1775                                     set screen_top [lindex $args 2]
1776                                     set screen_bot [lindex $args 3]}
1777 }
1778
1779 proc create_command_window {} {
1780         global command_line
1781
1782         build_framework .cmd Command "* Command Buffer *"
1783
1784         set command_line {}
1785
1786         gdb_cmd {set language c}
1787         gdb_cmd {set height 0}
1788         gdb_cmd {set width 0}
1789
1790         bind .cmd.text <Enter> {focus %W}
1791         bind .cmd.text <Delete> {delete_char %W}
1792         bind .cmd.text <BackSpace> {delete_char %W}
1793         bind .cmd.text <Control-u> {delete_line %W}
1794         bind .cmd.text <Any-Key> {
1795                 global command_line
1796
1797                 %W insert end %A
1798                 %W yview -pickplace end
1799                 append command_line %A
1800                 }
1801         bind .cmd.text <Key-Return> {
1802                 global command_line
1803
1804                 %W insert end \n
1805                 %W yview -pickplace end
1806                 catch "gdb_cmd [list $command_line]"
1807                 set command_line {}
1808                 update_ptr
1809                 %W insert end "(gdb) "
1810                 %W yview -pickplace end
1811                 }
1812
1813         proc delete_char {win} {
1814                 global command_line
1815
1816                 tk_textBackspace $win
1817                 $win yview -pickplace insert
1818                 set tmp [expr [string length $command_line] - 2]
1819                 set command_line [string range $command_line 0 $tmp]
1820         }
1821
1822         proc delete_line {win} {
1823                 global command_line
1824
1825                 $win delete {end linestart + 6 chars} end
1826                 $win yview -pickplace insert
1827                 set command_line {}
1828         }
1829 }
1830
1831 #
1832 # fileselect.tcl --
1833 # simple file selector.
1834 #
1835 # Mario Jorge Silva                               msilva@cs.Berkeley.EDU
1836 # University of California Berkeley                 Ph:    +1(510)642-8248
1837 # Computer Science Division, 571 Evans Hall         Fax:   +1(510)642-5775
1838 # Berkeley CA 94720
1839 #
1840 #
1841 # Copyright 1993 Regents of the University of California
1842 # Permission to use, copy, modify, and distribute this
1843 # software and its documentation for any purpose and without
1844 # fee is hereby granted, provided that this copyright
1845 # notice appears in all copies.  The University of California
1846 # makes no representations about the suitability of this
1847 # software for any purpose.  It is provided "as is" without
1848 # express or implied warranty.
1849 #
1850
1851
1852 # names starting with "fileselect" are reserved by this module
1853 # no other names used.
1854 # Hack - FSBox is defined instead of fileselect for backwards compatibility
1855
1856
1857 # this is the proc that creates the file selector box
1858 # purpose - comment string
1859 # defaultName - initial value for name
1860 # cmd - command to eval upon OK
1861 # errorHandler - command to eval upon Cancel
1862 # If neither cmd or errorHandler are specified, the return value
1863 # of the FSBox procedure is the selected file name.
1864
1865 proc FSBox {{purpose "Select file:"} {defaultName ""} {cmd ""} {errorHandler
1866 ""}} {
1867     global fileselect
1868     set w .fileSelect
1869     if [Exwin_Toplevel $w "Select File" FileSelect] {
1870         # path independent names for the widgets
1871
1872         set fileselect(list) $w.file.sframe.list
1873         set fileselect(scroll) $w.file.sframe.scroll
1874         set fileselect(direntry) $w.file.f1.direntry
1875         set fileselect(entry) $w.file.f2.entry
1876         set fileselect(ok) $w.but.ok
1877         set fileselect(cancel) $w.but.cancel
1878         set fileselect(msg) $w.label
1879
1880         set fileselect(result) ""       ;# value to return if no callback procedures
1881
1882         # widgets
1883         Widget_Label $w label {top fillx pady 10 padx 20} -anchor w -width 24
1884         Widget_Frame $w file Dialog {left expand fill} -bd 10
1885
1886         Widget_Frame $w.file f1 Exmh {top fillx}
1887         Widget_Label $w.file.f1 label {left} -text "Dir"
1888         Widget_Entry $w.file.f1 direntry {right fillx expand}  -width 30
1889
1890         Widget_Frame $w.file sframe
1891
1892         scrollbar $w.file.sframe.yscroll -relief sunken \
1893                 -command [list $w.file.sframe.list yview]
1894         listbox $w.file.sframe.list -relief sunken \
1895                 -yscroll [list $w.file.sframe.yscroll set] -setgrid 1
1896         pack append $w.file.sframe \
1897                 $w.file.sframe.yscroll {right filly} \
1898                 $w.file.sframe.list {left expand fill}
1899
1900         Widget_Frame $w.file f2 Exmh {top fillx}
1901         Widget_Label $w.file.f2 label {left} -text Name
1902         Widget_Entry $w.file.f2 entry {right fillx expand}
1903
1904         # buttons
1905         $w.but.quit configure -text Cancel \
1906                 -command [list fileselect.cancel.cmd $w]
1907
1908         Widget_AddBut $w.but ok OK \
1909                 [list fileselect.ok.cmd $w $cmd $errorHandler] {left padx 1}
1910
1911         Widget_AddBut $w.but list List \
1912                 [list fileselect.list.cmd $w] {left padx 1}
1913         Widget_CheckBut $w.but listall "List all" fileselect(pattern)
1914         $w.but.listall configure -onvalue "{*,.*}" -offvalue "*" \
1915             -command {fileselect.list.cmd $fileselect(direntry)}
1916         $w.but.listall deselect
1917
1918         # Set up bindings for the browser.
1919         foreach ww [list $w $fileselect(entry)] {
1920             bind $ww <Return> [list $fileselect(ok) invoke]
1921             bind $ww <Control-c> [list $fileselect(cancel) invoke]
1922         }
1923         bind $fileselect(direntry) <Return> [list fileselect.list.cmd %W]
1924         bind $fileselect(direntry) <Tab> [list fileselect.tab.dircmd]
1925         bind $fileselect(entry) <Tab> [list fileselect.tab.filecmd]
1926
1927         tk_listboxSingleSelect $fileselect(list)
1928
1929
1930         bind $fileselect(list) <Button-1> {
1931             # puts stderr "button 1 release"
1932             %W select from [%W nearest %y]
1933             $fileselect(entry) delete 0 end
1934             $fileselect(entry) insert 0 [%W get [%W nearest %y]]
1935         }
1936
1937         bind $fileselect(list) <Key> {
1938             %W select from [%W nearest %y]
1939             $fileselect(entry) delete 0 end
1940             $fileselect(entry) insert 0 [%W get [%W nearest %y]]
1941         }
1942
1943         bind $fileselect(list) <Double-ButtonPress-1> {
1944             # puts stderr "double button 1"
1945             %W select from [%W nearest %y]
1946             $fileselect(entry) delete 0 end
1947             $fileselect(entry) insert 0 [%W get [%W nearest %y]]
1948             $fileselect(ok) invoke
1949         }
1950
1951         bind $fileselect(list) <Return> {
1952             %W select from [%W nearest %y]
1953             $fileselect(entry) delete 0 end
1954             $fileselect(entry) insert 0 [%W get [%W nearest %y]]
1955             $fileselect(ok) invoke
1956         }
1957     }
1958     set fileselect(text) $purpose
1959     $fileselect(msg) configure -text $purpose
1960     $fileselect(entry) delete 0 end
1961     $fileselect(entry) insert 0 [file tail $defaultName]
1962
1963     if {[info exists fileselect(lastDir)] && ![string length $defaultName]} {
1964         set dir $fileselect(lastDir)
1965     } else {
1966         set dir [file dirname $defaultName]
1967     }
1968     set fileselect(pwd) [pwd]
1969     fileselect.cd $dir
1970     $fileselect(direntry) delete 0 end
1971     $fileselect(direntry) insert 0 [pwd]/
1972
1973     $fileselect(list) delete 0 end
1974     $fileselect(list) insert 0 "Big directory:"
1975     $fileselect(list) insert 1 $dir
1976     $fileselect(list) insert 2 "Press Return for Listing"
1977
1978     fileselect.list.cmd $fileselect(direntry) startup
1979
1980     # set kbd focus to entry widget
1981
1982 #    Exwin_ToplevelFocus $w $fileselect(entry)
1983
1984     # Wait for button hits if no callbacks are defined
1985
1986     if {"$cmd" == "" && "$errorHandler" == ""} {
1987         # wait for the box to be destroyed
1988         update idletask
1989         grab $w
1990         tkwait variable fileselect(result)
1991         grab release $w
1992
1993         set path $fileselect(result)
1994         set fileselect(lastDir) [pwd]
1995         fileselect.cd $fileselect(pwd)
1996         return [string trimright [string trim $path] /]
1997     }
1998     fileselect.cd $fileselect(pwd)
1999     return ""
2000 }
2001
2002 proc fileselect.cd { dir } {
2003     global fileselect
2004     if [catch {cd $dir} err] {
2005         fileselect.yck $dir
2006         cd
2007     }
2008 }
2009 # auxiliary button procedures
2010
2011 proc fileselect.yck { {tag {}} } {
2012     global fileselect
2013     $fileselect(msg) configure -text "Yck! $tag"
2014 }
2015 proc fileselect.ok {} {
2016     global fileselect
2017     $fileselect(msg) configure -text $fileselect(text)
2018 }
2019
2020 proc fileselect.cancel.cmd {w} {
2021     global fileselect
2022     set fileselect(result) {}
2023 }
2024
2025 proc fileselect.list.cmd {w {state normal}} {
2026     global fileselect
2027     set seldir [$fileselect(direntry) get]
2028     if {[catch {glob $seldir} dir]} {
2029         fileselect.yck "glob failed"
2030         return
2031     }
2032     if {[llength $dir] > 1} {
2033         set dir [file dirname $seldir]
2034         set pat [file tail $seldir]
2035     } else {
2036         set pat $fileselect(pattern)
2037     }
2038     fileselect.ok
2039     update idletasks
2040     if [file isdirectory $dir] {
2041         fileselect.getfiles $dir $pat $state
2042         focus $fileselect(entry)
2043     } else {
2044         fileselect.yck "not a dir"
2045     }
2046 }
2047
2048 proc fileselect.ok.cmd {w cmd errorHandler} {
2049     global fileselect
2050     set selname [$fileselect(entry) get]
2051     set seldir [$fileselect(direntry) get]
2052
2053     if [string match /* $selname] {
2054         set selected $selname
2055     } else {
2056         if [string match ~* $selname] {
2057             set selected $selname
2058         } else {
2059             set selected $seldir/$selname
2060         }
2061     }
2062
2063     # some nasty file names may cause "file isdirectory" to return an error
2064     if [catch {file isdirectory $selected} isdir] {
2065         fileselect.yck "isdirectory failed"
2066         return
2067     }
2068     if [catch {glob $selected} globlist] {
2069         if ![file isdirectory [file dirname $selected]] {
2070             fileselect.yck "bad pathname"
2071             return
2072         }
2073         set globlist $selected
2074     }
2075     fileselect.ok
2076     update idletasks
2077
2078     if {[llength $globlist] > 1} {
2079         set dir [file dirname $selected]
2080         set pat [file tail $selected]
2081         fileselect.getfiles $dir $pat
2082         return
2083     } else {
2084         set selected $globlist
2085     }
2086     if [file isdirectory $selected] {
2087         fileselect.getfiles $selected $fileselect(pattern)
2088         $fileselect(entry) delete 0 end
2089         return
2090     }
2091
2092     if {$cmd != {}} {
2093         $cmd $selected
2094     } else {
2095         set fileselect(result) $selected
2096     }
2097 }
2098
2099 proc fileselect.getfiles { dir {pat *} {state normal} } {
2100     global fileselect
2101     $fileselect(msg) configure -text Listing...
2102     update idletasks
2103
2104     set currentDir [pwd]
2105     fileselect.cd $dir
2106     if [catch {set files [lsort [glob -nocomplain $pat]]} err] {
2107         $fileselect(msg) configure -text $err
2108         $fileselect(list) delete 0 end
2109         update idletasks
2110         return
2111     }
2112     switch -- $state {
2113         normal {
2114             # Normal case - show current directory
2115             $fileselect(direntry) delete 0 end
2116             $fileselect(direntry) insert 0 [pwd]/
2117         }
2118         opt {
2119             # Directory already OK (tab related)
2120         }
2121         newdir {
2122             # Changing directory (tab related)
2123             fileselect.cd $currentDir
2124         }
2125         startup {
2126             # Avoid listing huge directories upon startup.
2127             $fileselect(direntry) delete 0 end
2128             $fileselect(direntry) insert 0 [pwd]/
2129             if {[llength $files] > 32} {
2130                 fileselect.ok
2131                 return
2132             }
2133         }
2134     }
2135
2136     # build a reordered list of the files: directories are displayed first
2137     # and marked with a trailing "/"
2138     if [string compare $dir /] {
2139         fileselect.putfiles $files [expr {($pat == "*") ? 1 : 0}]
2140     } else {
2141         fileselect.putfiles $files
2142     }
2143     fileselect.ok
2144 }
2145
2146 proc fileselect.putfiles {files {dotdot 0} } {
2147     global fileselect
2148
2149     $fileselect(list) delete 0 end
2150     if {$dotdot} {
2151         $fileselect(list) insert end "../"
2152     }
2153     foreach i $files {
2154         if {[file isdirectory $i]} {
2155             $fileselect(list) insert end $i/
2156         } else {
2157             $fileselect(list) insert end $i
2158         }
2159     }
2160 }
2161
2162 proc FileExistsDialog { name } {
2163     set w .fileExists
2164     global fileExists
2165     set fileExists(ok) 0
2166     {
2167         message $w.msg -aspect 1000
2168         pack $w.msg -side top -fill both -padx 20 -pady 20
2169         $w.but.quit config -text Cancel -command {FileExistsCancel}
2170         button $w.but.ok -text OK -command {FileExistsOK}
2171         pack $w.but.ok -side left
2172         bind $w.msg <Return> {FileExistsOK}
2173     }
2174     $w.msg config -text "Warning: file exists
2175 $name
2176 OK to overwrite it?"
2177
2178     set fileExists(focus) [focus]
2179     focus $w.msg
2180     grab $w
2181     tkwait variable fileExists(ok)
2182     grab release $w
2183     return $fileExists(ok)
2184 }
2185 proc FileExistsCancel {} {
2186     global fileExists
2187     set fileExists(ok) 0
2188 }
2189 proc FileExistsOK {} {
2190     global fileExists
2191     set fileExists(ok) 1
2192 }
2193
2194 proc fileselect.getfiledir { dir {basedir [pwd]} } {
2195     global fileselect
2196
2197     set path [$fileselect(direntry) get]
2198     set returnList {}
2199
2200     if {$dir != 0} {
2201         if {[string index $path 0] == "~"} {
2202             set path $path/
2203         }
2204     } else {
2205         set path [$fileselect(entry) get]
2206     }
2207     if [catch {set listFile [glob -nocomplain $path*]}] {
2208         return  $returnList
2209     }
2210     foreach el $listFile {
2211         if {$dir != 0} {
2212             if [file isdirectory $el] {
2213                 lappend returnList [file tail $el]
2214             }
2215         } elseif ![file isdirectory $el] {
2216             lappend returnList [file tail $el]
2217         }
2218     }
2219
2220     return $returnList
2221 }
2222
2223 proc fileselect.gethead { list } {
2224     set returnHead ""
2225
2226     for {set i 0} {[string length [lindex $list 0]] > $i}\
2227         {incr i; set returnHead $returnHead$thisChar} {
2228             set thisChar [string index [lindex $list 0] $i]
2229             foreach el $list {
2230                 if {[string length $el] < $i} {
2231                     return $returnHead
2232                 }
2233                 if {$thisChar != [string index $el $i]} {
2234                     return $returnHead
2235                 }
2236             }
2237         }
2238     return $returnHead
2239 }
2240
2241 proc fileselect.expand.tilde { } {
2242     global fileselect
2243
2244     set entry [$fileselect(direntry) get]
2245     set dir [string range $entry 1 [string length $entry]]
2246
2247     if {$dir == ""} {
2248         return
2249     }
2250
2251     set listmatch {}
2252
2253     ## look in /etc/passwd
2254     if [file exists /etc/passwd] {
2255         if [catch {set users [exec cat /etc/passwd | sed s/:.*//]} err] {
2256             puts "Error\#1 $err"
2257             return
2258         }
2259         set list [split $users "\n"]
2260     }
2261     if {[lsearch -exact $list "+"] != -1} {
2262         if [catch {set users [exec ypcat passwd | sed s/:.*//]} err] {
2263             puts "Error\#2 $err"
2264             return
2265         }
2266         set list [concat $list [split $users "\n"]]
2267     }
2268     $fileselect(list) delete 0 end
2269     foreach el $list {
2270         if [string match $dir* $el] {
2271             lappend listmatch $el
2272             $fileselect(list) insert end $el
2273         }
2274     }
2275     set addings [fileselect.gethead $listmatch]
2276     if {$addings == ""} {
2277         return
2278     }
2279     $fileselect(direntry) delete 0 end
2280     if {[llength $listmatch] == 1} {
2281         $fileselect(direntry) insert 0 [file dirname ~$addings/]
2282         fileselect.getfiles [$fileselect(direntry) get]
2283     } else {
2284         $fileselect(direntry) insert 0 ~$addings
2285     }
2286 }
2287
2288 proc fileselect.tab.dircmd { } {
2289     global fileselect
2290
2291     set dir [$fileselect(direntry) get]
2292     if {$dir == ""} {
2293         $fileselect(direntry) delete 0 end
2294             $fileselect(direntry) insert 0 [pwd]
2295         if [string compare [pwd] "/"] {
2296             $fileselect(direntry) insert end /
2297         }
2298         return
2299     }
2300     if [catch {set tmp [file isdirectory [file dirname $dir]]}] {
2301         if {[string index $dir 0] == "~"} {
2302             fileselect.expand.tilde
2303         }
2304         return
2305     }
2306     if {!$tmp} {
2307         return
2308     }
2309     set dirFile [fileselect.getfiledir 1 $dir]
2310     if ![llength $dirFile] {
2311         return
2312     }
2313     if {[llength $dirFile] == 1} {
2314         $fileselect(direntry) delete 0 end
2315         $fileselect(direntry) insert 0 [file dirname $dir]
2316         if [string compare [file dirname $dir] /] {
2317             $fileselect(direntry) insert end /[lindex $dirFile 0]/
2318         } else {
2319             $fileselect(direntry) insert end [lindex $dirFile 0]/
2320         }
2321         fileselect.getfiles [$fileselect(direntry) get] \
2322             "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
2323         return
2324     }
2325     set headFile [fileselect.gethead $dirFile]
2326     $fileselect(direntry) delete 0 end
2327     $fileselect(direntry) insert 0 [file dirname $dir]
2328     if [string compare [file dirname $dir] /] {
2329         $fileselect(direntry) insert end /$headFile
2330     } else {
2331         $fileselect(direntry) insert end $headFile
2332     }
2333     if {$headFile == "" && [file isdirectory $dir]} {
2334         fileselect.getfiles $dir\
2335             "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
2336     } else {
2337         fileselect.getfiles [file dirname $dir]\
2338             "[file tail [$fileselect(direntry) get]]*" newdir
2339     }
2340 }
2341
2342 proc fileselect.tab.filecmd { } {
2343     global fileselect
2344
2345     set dir [$fileselect(direntry) get]
2346     if {$dir == ""} {
2347         set dir [pwd]
2348     }
2349     if {![file isdirectory $dir]} {
2350         error "dir $dir doesn't exist"
2351     }
2352     set listFile [fileselect.getfiledir 0 $dir]
2353     puts $listFile
2354     if ![llength $listFile] {
2355         return
2356     }
2357     if {[llength $listFile] == 1} {
2358         $fileselect(entry) delete 0 end
2359         $fileselect(entry) insert 0 [lindex $listFile 0]
2360         return
2361     }
2362     set headFile [fileselect.gethead $listFile]
2363     $fileselect(entry) delete 0 end
2364     $fileselect(entry) insert 0 $headFile
2365     fileselect.getfiles $dir "[$fileselect(entry) get]$fileselect(pattern)" opt
2366 }
2367
2368 proc Exwin_Toplevel { path name {class Dialog} {dismiss yes}} {
2369     global exwin
2370     if [catch {wm state $path} state] {
2371         set t [Widget_Toplevel $path $name $class]
2372         if ![info exists exwin(toplevels)] {
2373             set exwin(toplevels) [option get . exwinPaths {}]
2374         }
2375         set ix [lsearch $exwin(toplevels) $t]
2376         if {$ix < 0} {
2377             lappend exwin(toplevels) $t
2378         }
2379         if {$dismiss == "yes"} {
2380             set f [Widget_Frame $t but Menubar {top fill}]
2381             Widget_AddBut $f quit "Dismiss" [list Exwin_Dismiss $path]
2382         }
2383         return 1
2384     } else {
2385         if {$state != "normal"} {
2386             catch {
2387                 wm geometry $path $exwin(geometry,$path)
2388 #               Exmh_Debug Exwin_Toplevel $path $exwin(geometry,$path)
2389             }
2390             wm deiconify $path
2391         } else {
2392             catch {raise $path}
2393         }
2394         return 0
2395     }
2396 }
2397
2398 proc Exwin_Dismiss { path {geo ok} } {
2399     global exwin
2400     case $geo {
2401         "ok" {
2402             set exwin(geometry,$path) [wm geometry $path]
2403         }
2404         "nosize" {
2405             set exwin(geometry,$path) [string trimleft [wm geometry $path] 0123456789x]
2406         }
2407         default {
2408             catch {unset exwin(geometry,$path)}
2409         }
2410     }
2411     wm withdraw $path
2412 }
2413
2414 proc Widget_Toplevel { path name {class Dialog} {x {}} {y {}} } {
2415     set self [toplevel $path -class $class]
2416     set usergeo [option get $path position Position]
2417     if {$usergeo != {}} {
2418         if [catch {wm geometry $self $usergeo} err] {
2419 #           Exmh_Debug Widget_Toplevel $self $usergeo => $err
2420         }
2421     } else {
2422         if {($x != {}) && ($y != {})} {
2423 #           Exmh_Debug Event position $self +$x+$y
2424             wm geometry $self +$x+$y
2425         }
2426     }
2427     wm title $self $name
2428     wm group $self .
2429     return $self
2430 }
2431
2432 proc Widget_Frame {par child {class GDB} {where {top expand fill}} args } {
2433     if {$par == "."} {
2434         set self .$child
2435     } else {
2436         set self $par.$child
2437     }
2438     eval {frame $self -class $class} $args
2439     pack append $par $self $where
2440     return $self
2441 }
2442
2443 proc Widget_AddBut {par but txt cmd {where {right padx 1}} } {
2444     # Create a Packed button.  Return the button pathname
2445     set cmd2 [list button $par.$but -text $txt -command $cmd]
2446     if [catch $cmd2 t] {
2447         puts stderr "Widget_AddBut (warning) $t"
2448         eval $cmd2 {-font fixed}
2449     }
2450     pack append $par $par.$but $where
2451     return $par.$but
2452 }
2453 proc Widget_CheckBut {par but txt var {where {right padx 1}} } {
2454     # Create a check button.  Return the button pathname
2455     set cmd [list checkbutton $par.$but -text $txt -variable $var]
2456     if [catch $cmd t] {
2457         puts stderr "Widget_CheckBut (warning) $t"
2458         eval $cmd {-font fixed}
2459     }
2460     pack append $par $par.$but $where
2461     return $par.$but
2462 }
2463
2464 proc Widget_Label { frame {name label} {where {left fill}} args} {
2465     set cmd [list label $frame.$name ]
2466     if [catch [concat $cmd $args] t] {
2467         puts stderr "Widget_Label (warning) $t"
2468         eval $cmd $args {-font fixed}
2469     }
2470     pack append $frame $frame.$name $where
2471     return $frame.$name
2472 }
2473 proc Widget_Entry { frame {name entry} {where {left fill}} args} {
2474     set cmd [list entry $frame.$name ]
2475     if [catch [concat $cmd $args] t] {
2476         puts stderr "Widget_Entry (warning) $t"
2477         eval $cmd $args {-font fixed}
2478     }
2479     pack append $frame $frame.$name $where
2480     return $frame.$name
2481 }
2482
2483 # End of fileselect.tcl.
2484
2485 # Setup the initial windows
2486
2487 create_source_window
2488
2489 if {[tk colormodel .src.text] == "color"} {
2490         set highlight "-background red2 -borderwidth 2 -relief sunk"
2491 } else {
2492         set fg [lindex [.src.text config -foreground] 4]
2493         set bg [lindex [.src.text config -background] 4]
2494         set highlight "-foreground $bg -background $fg -borderwidth 0"
2495 }
2496
2497 create_command_window
2498 update