gdb/gdbtk.tcl

   1 # GDB GUI setup for GDB, the GNU debugger.
   2 # Copyright 1994, 1995, 1996
   3 # Free Software Foundation, Inc.
   4
   5 # Written by Stu Grossman <grossman@cygnus.com> of Cygnus Support.
   6
   7 # This file is part of GDB.
   8
   9 # This program is free software; you can redistribute it and/or modify
  10 # it under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation; either version 2 of the License, or
  12 # (at your option) any later version.
  13
  14 # This program is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 # GNU General Public License for more details.
  18
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program; if not, write to the Free Software
  21 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  22
  23 set cfile Blank
  24 set wins($cfile) .src.text
  25 set current_label {}
  26 set cfunc NIL
  27 set line_numbers 1
  28 set breakpoint_file(-1) {[garbage]}
  29 set disassemble_with_source nosource
  30 set expr_update_list(0) 0
  31 set gdb_prompt "(gdb) "
  32
  33 set debug_interface 0
  34
  35 #option add *Foreground Black
  36 #option add *Background White
  37 #option add *Font -*-*-medium-r-normal--18-*-*-*-m-*-*-1
  38
  39 proc echo string {puts stdout $string}
  40
  41 # Assign elements from LIST to variables named in ARGS.  FIXME replace
  42 # with TclX version someday.
  43 proc lassign {list args} {
  44   set len [expr {[llength $args] - 1}]
  45   while {$len >= 0} {
  46     upvar [lindex $args $len] local
  47     set local [lindex $list $len]
  48     decr len
  49   }
  50 }
  51
  52 #
  53 # Local procedure:
  54 #
  55 #       decr (var val) - compliment to incr
  56 #
  57 # Description:
  58 #
  59 #
  60 proc decr {var {val 1}} {
  61   upvar $var num
  62   set num [expr {$num - $val}]
  63   return $num
  64 }
  65
  66 #
  67 # Center a window on the screen.
  68 #
  69 proc center_window toplevel {
  70   # Withdraw and update, to ensure geometry computations are finished.
  71   wm withdraw $toplevel
  72   update idletasks
  73
  74   set x [expr {[winfo screenwidth $toplevel] / 2
  75                - [winfo reqwidth $toplevel] / 2
  76                - [winfo vrootx $toplevel]}]
  77   set y [expr {[winfo screenheight $toplevel] / 2
  78                - [winfo reqheight $toplevel] / 2
  79                - [winfo vrooty $toplevel]}]
  80   wm geometry $toplevel +${x}+${y}
  81   wm deiconify $toplevel
  82 }
  83
  84 #
  85 # Rearrange the bindtags so the widget comes after the class.  I was
  86 # always for Ousterhout putting the class bindings first, but no...
  87 #
  88 proc bind_widget_after_class {widget} {
  89   set class [winfo class $widget]
  90   set newList {}
  91   foreach tag [bindtags $widget] {
  92     if {$tag == $widget} {
  93       # Nothing.
  94     } {
  95       lappend newList $tag
  96       if {$tag == $class} {
  97         lappend newList $widget
  98       }
  99     }
 100   }
 101   bindtags $widget $newList
 102 }
 103
 104 #
 105 # Make sure line number $LINE is visible in the text widget.  But be
 106 # more clever than the "see" command: if LINE is not currently
 107 # displayed, arrange for LINE to be centered.  There are cases in
 108 # which this does not work, so as a last resort we revert to "see".
 109 #
 110 # This is inefficient, but probably not slow enough to actually
 111 # notice.
 112 #
 113 proc ensure_line_visible {text line} {
 114   set pixHeight [winfo height $text]
 115   # Compute height of widget in lines.  This fails if a line is wider
 116   # than the screen.  FIXME.
 117   set topLine [lindex [split [$text index @0,0] .] 0]
 118   set botLine [lindex [split [$text index @0,${pixHeight}] .] 0]
 119
 120   if {$line > $topLine && $line < $botLine} then {
 121     # Onscreen, and not on the very edge.
 122     return
 123   }
 124
 125   set newTop [expr {$line - ($botLine - $topLine)}]
 126   if {$newTop < 0} then {
 127     set newTop 0
 128   }
 129   $text yview moveto $newTop
 130
 131   # In case the above failed.
 132   $text see ${line}.0
 133 }
 134
 135 if {[info exists env(EDITOR)]} then {
 136   set editor $env(EDITOR)
 137 } else {
 138   set editor emacs
 139 }
 140
 141 # GDB callbacks
 142 #
 143 #  These functions are called by GDB (from C code) to do various things in
 144 #  TK-land.  All start with the prefix `gdbtk_tcl_' to make them easy to find.
 145 #
 146
 147 #
 148 # GDB Callback:
 149 #
 150 #       gdbtk_tcl_fputs (text) - Output text to the command window
 151 #
 152 # Description:
 153 #
 154 #       GDB calls this to output TEXT to the GDB command window.  The text is
 155 #       placed at the end of the text widget.  Note that output may not occur,
 156 #       due to buffering.  Use gdbtk_tcl_flush to cause an immediate update.
 157 #
 158
 159 proc gdbtk_tcl_fputs {arg} {
 160   .cmd.text insert end "$arg"
 161   .cmd.text see end
 162 }
 163
 164 proc gdbtk_tcl_fputs_error {arg} {
 165   .cmd.text insert end "$arg"
 166   .cmd.text see end
 167 }
 168
 169 #
 170 # GDB Callback:
 171 #
 172 #       gdbtk_tcl_flush () - Flush output to the command window
 173 #
 174 # Description:
 175 #
 176 #       GDB calls this to force all buffered text to the GDB command window.
 177 #
 178
 179 proc gdbtk_tcl_flush {} {
 180   .cmd.text see end
 181   update idletasks
 182 }
 183
 184 #
 185 # GDB Callback:
 186 #
 187 #       gdbtk_tcl_query (message) - Create a yes/no query dialog box
 188 #
 189 # Description:
 190 #
 191 #       GDB calls this to create a yes/no dialog box containing MESSAGE.  GDB
 192 #       is hung while the dialog box is active (ie: no commands will work),
 193 #       however windows can still be refreshed in case of damage or exposure.
 194 #
 195
 196 proc gdbtk_tcl_query {message} {
 197   # FIXME We really want a Help button here.  But Tk's brain-damaged
 198   # modal dialogs won't really allow it.  Should have async dialog
 199   # here.
 200   set result [tk_dialog .query "gdb : query" "$message" questhead 0 Yes No]
 201   return [expr {!$result}]
 202 }
 203
 204 #
 205 # GDB Callback:
 206 #
 207 #       gdbtk_start_variable_annotation (args ...) -
 208 #
 209 # Description:
 210 #
 211 #       Not yet implemented.
 212 #
 213
 214 proc gdbtk_tcl_start_variable_annotation {valaddr ref_type stor_cl
 215                                           cum_expr field type_cast} {
 216   echo "gdbtk_tcl_start_variable_annotation $valaddr $ref_type $stor_cl $cum_expr $field $type_cast"
 217 }
 218
 219 #
 220 # GDB Callback:
 221 #
 222 #       gdbtk_end_variable_annotation (args ...) -
 223 #
 224 # Description:
 225 #
 226 #       Not yet implemented.
 227 #
 228
 229 proc gdbtk_tcl_end_variable_annotation {} {
 230         echo gdbtk_tcl_end_variable_annotation
 231 }
 232
 233 #
 234 # GDB Callback:
 235 #
 236 #       gdbtk_tcl_breakpoint (action bpnum file line) - Notify the TK
 237 #       interface of changes to breakpoints.
 238 #
 239 # Description:
 240 #
 241 #       GDB calls this to notify TK of changes to breakpoints.  ACTION is one
 242 #       of:
 243 #               create          - Notify of breakpoint creation
 244 #               delete          - Notify of breakpoint deletion
 245 #               modify          - Notify of breakpoint modification
 246 #
 247
 248 # file line pc type enabled disposition silent ignore_count commands cond_string thread hit_count
 249
 250 proc gdbtk_tcl_breakpoint {action bpnum} {
 251         set bpinfo [gdb_get_breakpoint_info $bpnum]
 252         set file [lindex $bpinfo 0]
 253         set line [lindex $bpinfo 1]
 254         set pc [lindex $bpinfo 2]
 255         set enable [lindex $bpinfo 4]
 256
 257         if {$action == "modify"} {
 258                 if {$enable == "1"} {
 259                         set action enable
 260                 } else {
 261                         set action disable
 262                 }
 263         }
 264
 265         ${action}_breakpoint $bpnum $file $line $pc
 266 }
 267
 268 #
 269 # GDB Callback:
 270 #
 271 #       gdbtk_tcl_readline_begin (message) - Notify Tk to open an interaction
 272 #       window and start gathering user input
 273 #
 274 # Description:
 275 #
 276 #       GDB calls this to notify TK that it needs to open an interaction
 277 #       window, displaying the given message, and be prepared to accept
 278 #       calls to gdbtk_tcl_readline to gather user input.
 279
 280 proc gdbtk_tcl_readline_begin {message} {
 281     global readline_text
 282
 283     # If another readline window already exists, just bring it to the front.
 284     if {[winfo exists .rl]} {raise .rl ; return}
 285
 286     # Create top level frame with scrollbar and text widget.
 287     toplevel .rl
 288     wm title .rl "Interaction Window"
 289     wm iconname .rl "Input"
 290     message .rl.msg -text $message -aspect 7500 -justify left
 291     text .rl.text -width 80 -height 20 -setgrid true -cursor hand2 \
 292             -yscrollcommand {.rl.scroll set}
 293     scrollbar .rl.scroll -command {.rl.text yview}
 294     pack .rl.msg -side top -fill x
 295     pack .rl.scroll -side right -fill y
 296     pack .rl.text -side left -fill both -expand true
 297
 298     # When the user presses return, get the text from the command start mark to the
 299     # current insert point, stash it in the readline text variable, and update the
 300     # command start mark to the current insert point
 301     bind .rl.text <Return> {
 302         set readline_text [.rl.text get cmdstart {end - 1 char}]
 303         .rl.text mark set cmdstart insert
 304     }
 305     bindtags .rl.text {.rl.text Text all}
 306 }
 307
 308 #
 309 # GDB Callback:
 310 #
 311 #       gdbtk_tcl_readline (prompt) - Get one user input line
 312 #
 313 # Description:
 314 #
 315 #       GDB calls this to get one line of input from the user interaction
 316 #       window, using "prompt" as the command line prompt.
 317
 318 proc gdbtk_tcl_readline {prompt} {
 319     global readline_text
 320
 321     .rl.text insert end $prompt
 322     .rl.text mark set cmdstart insert
 323     .rl.text mark gravity cmdstart left
 324     .rl.text see insert
 325
 326     # Make this window the current one for input.
 327     focus .rl.text
 328     grab .rl
 329     tkwait variable readline_text
 330     grab release .rl
 331     return $readline_text
 332 }
 333
 334 #
 335 # GDB Callback:
 336 #
 337 #       gdbtk_tcl_readline_end  - Terminate a user interaction
 338 #
 339 # Description:
 340 #
 341 #       GDB calls this when it is done getting interactive user input.
 342 #       Destroy the interaction window.
 343
 344 proc gdbtk_tcl_readline_end {} {
 345     if {[winfo exists .rl]} { destroy .rl }
 346 }
 347
 348 proc create_breakpoints_window {} {
 349         global bpframe_lasty
 350
 351         if {[winfo exists .breakpoints]} {raise .breakpoints ; return}
 352
 353         build_framework .breakpoints "Breakpoints" ""
 354
 355 # First, delete all the old view menu entries
 356
 357         .breakpoints.menubar.view.menu delete 0 last
 358
 359 # Get rid of label
 360
 361         destroy .breakpoints.label
 362
 363 # Replace text with a canvas and fix the scrollbars
 364
 365         destroy .breakpoints.text
 366         scrollbar .breakpoints.scrollx -orient horizontal \
 367                 -command {.breakpoints.c xview} -relief sunken
 368         canvas .breakpoints.c -relief sunken -bd 2 \
 369                 -cursor hand2 \
 370                 -yscrollcommand {.breakpoints.scroll set} \
 371                 -xscrollcommand {.breakpoints.scrollx set}
 372         .breakpoints.scroll configure -command {.breakpoints.c yview}
 373
 374         pack .breakpoints.scrollx -side bottom -fill x -in .breakpoints.info
 375         pack .breakpoints.c -side left -expand yes -fill both \
 376                 -in .breakpoints.info
 377
 378         set bpframe_lasty 0
 379
 380 # Create a frame for each breakpoint
 381
 382         foreach bpnum [gdb_get_breakpoint_list] {
 383                 add_breakpoint_frame $bpnum
 384         }
 385 }
 386
 387 # Create a frame for bpnum in the .breakpoints canvas
 388
 389 proc add_breakpoint_frame bpnum {
 390   global bpframe_lasty
 391   global enabled
 392   global disposition
 393
 394   if {![winfo exists .breakpoints]} return
 395
 396   set bpinfo [gdb_get_breakpoint_info $bpnum]
 397
 398   lassign $bpinfo file line pc type enabled($bpnum) disposition($bpnum) \
 399     silent ignore_count commands cond thread hit_count
 400
 401   set f .breakpoints.c.$bpnum
 402
 403   if {![winfo exists $f]} {
 404     frame $f -relief sunken -bd 2
 405
 406     label $f.id -text "#$bpnum     $file:$line    ($pc)" \
 407       -relief flat -bd 2 -anchor w
 408     frame $f.hit_count
 409     label $f.hit_count.label -text "Hit count:" -relief flat \
 410       -bd 2 -anchor w -width 11
 411     label $f.hit_count.val -text $hit_count -relief flat \
 412       -bd 2 -anchor w
 413     checkbutton $f.hit_count.enabled -text Enabled \
 414       -variable enabled($bpnum) -anchor w -relief flat
 415
 416     pack $f.hit_count.label $f.hit_count.val -side left
 417     pack $f.hit_count.enabled -side right
 418
 419     frame $f.thread
 420     label $f.thread.label -text "Thread: " -relief flat -bd 2 \
 421       -width 11 -anchor w
 422     entry $f.thread.entry -bd 2 -relief sunken -width 10
 423     $f.thread.entry insert end $thread
 424     pack $f.thread.label -side left
 425     pack $f.thread.entry -side left -fill x
 426
 427     frame $f.cond
 428     label $f.cond.label -text "Condition: " -relief flat -bd 2 \
 429       -width 11 -anchor w
 430     entry $f.cond.entry -bd 2 -relief sunken
 431     $f.cond.entry insert end $cond
 432     pack $f.cond.label -side left
 433     pack $f.cond.entry -side left -fill x -expand yes
 434
 435     frame $f.ignore_count
 436     label $f.ignore_count.label -text "Ignore count: " \
 437       -relief flat -bd 2 -width 11 -anchor w
 438     entry $f.ignore_count.entry -bd 2 -relief sunken -width 10
 439     $f.ignore_count.entry insert end $ignore_count
 440     pack $f.ignore_count.label -side left
 441     pack $f.ignore_count.entry -side left -fill x
 442
 443     frame $f.disps
 444
 445     label $f.disps.label -text "Disposition: " -relief flat -bd 2 \
 446       -anchor w -width 11
 447
 448     radiobutton $f.disps.delete -text Delete \
 449       -variable disposition($bpnum) -anchor w -relief flat \
 450       -command "gdb_cmd \"delete break $bpnum\"" \
 451       -value delete
 452
 453     radiobutton $f.disps.disable -text Disable \
 454       -variable disposition($bpnum) -anchor w -relief flat \
 455       -command "gdb_cmd \"disable break $bpnum\"" \
 456       -value disable
 457
 458     radiobutton $f.disps.donttouch -text "Leave alone" \
 459       -variable disposition($bpnum) -anchor w -relief flat \
 460       -command "gdb_cmd \"enable break $bpnum\"" \
 461       -value donttouch
 462
 463     pack $f.disps.label $f.disps.delete $f.disps.disable \
 464       $f.disps.donttouch -side left -anchor w
 465     text $f.commands -relief sunken -bd 2 -setgrid true \
 466       -cursor hand2 -height 3 -width 30
 467
 468     foreach line $commands {
 469       $f.commands insert end "${line}\n"
 470     }
 471
 472     pack $f.id -side top -anchor nw -fill x
 473     pack $f.hit_count $f.cond $f.thread $f.ignore_count $f.disps \
 474       $f.commands -side top -fill x -anchor nw
 475   }
 476
 477   set tag [.breakpoints.c create window 0 $bpframe_lasty -window $f -anchor nw]
 478   update
 479   set bbox [.breakpoints.c bbox $tag]
 480
 481   set bpframe_lasty [lindex $bbox 3]
 482
 483   .breakpoints.c configure -width [lindex $bbox 2]
 484 }
 485
 486 # Delete a breakpoint frame
 487
 488 proc delete_breakpoint_frame bpnum {
 489         global bpframe_lasty
 490
 491         if {![winfo exists .breakpoints]} return
 492
 493 # First, clear the canvas
 494
 495         .breakpoints.c delete all
 496
 497 # Now, repopulate it with all but the doomed breakpoint
 498
 499         set bpframe_lasty 0
 500         foreach bp [gdb_get_breakpoint_list] {
 501                 if {$bp != $bpnum} {
 502                         add_breakpoint_frame $bp
 503                 }
 504         }
 505 }
 506
 507 proc asm_win_name {funcname} {
 508         if {$funcname == "*None*"} {return .asm.text}
 509
 510         regsub -all {\.} $funcname _ temp
 511
 512         return .asm.func_${temp}
 513 }
 514
 515 #
 516 # Local procedure:
 517 #
 518 #       create_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
 519 #
 520 # Description:
 521 #
 522 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
 523 #       land of breakpoint creation.  This consists of recording the file and
 524 #       line number in the breakpoint_file and breakpoint_line arrays.  Also,
 525 #       if there is already a window associated with FILE, it is updated with
 526 #       a breakpoint tag.
 527 #
 528
 529 proc create_breakpoint {bpnum file line pc} {
 530         global wins
 531         global breakpoint_file
 532         global breakpoint_line
 533         global pos_to_breakpoint
 534         global pos_to_bpcount
 535         global cfunc
 536         global pclist
 537
 538 # Record breakpoint locations
 539
 540         set breakpoint_file($bpnum) $file
 541         set breakpoint_line($bpnum) $line
 542         set pos_to_breakpoint($file:$line) $bpnum
 543         if {![info exists pos_to_bpcount($file:$line)]} {
 544                 set pos_to_bpcount($file:$line) 0
 545         }
 546         incr pos_to_bpcount($file:$line)
 547         set pos_to_breakpoint($pc) $bpnum
 548         if {![info exists pos_to_bpcount($pc)]} {
 549                 set pos_to_bpcount($pc) 0
 550         }
 551         incr pos_to_bpcount($pc)
 552
 553 # If there's a window for this file, update it
 554
 555         if {[info exists wins($file)]} {
 556                 insert_breakpoint_tag $wins($file) $line
 557         }
 558
 559 # If there's an assembly window, update that too
 560
 561         set win [asm_win_name $cfunc]
 562         if {[winfo exists $win]} {
 563                 insert_breakpoint_tag $win [pc_to_line $pclist($cfunc) $pc]
 564         }
 565
 566 # Update the breakpoints window
 567
 568         add_breakpoint_frame $bpnum
 569 }
 570
 571 #
 572 # Local procedure:
 573 #
 574 #       delete_breakpoint (bpnum file line pc) - Delete breakpoint info from TK land
 575 #
 576 # Description:
 577 #
 578 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
 579 #       land of breakpoint destruction.  This consists of removing the file and
 580 #       line number from the breakpoint_file and breakpoint_line arrays.  Also,
 581 #       if there is already a window associated with FILE, the tags are removed
 582 #       from it.
 583 #
 584
 585 proc delete_breakpoint {bpnum file line pc} {
 586         global wins
 587         global breakpoint_file
 588         global breakpoint_line
 589         global pos_to_breakpoint
 590         global pos_to_bpcount
 591         global cfunc pclist
 592
 593 # Save line number and file for later
 594
 595         set line $breakpoint_line($bpnum)
 596
 597         set file $breakpoint_file($bpnum)
 598
 599 # Reset breakpoint annotation info
 600
 601         if {$pos_to_bpcount($file:$line) > 0} {
 602                 decr pos_to_bpcount($file:$line)
 603
 604                 if {$pos_to_bpcount($file:$line) == 0} {
 605                         catch "unset pos_to_breakpoint($file:$line)"
 606
 607                         unset breakpoint_file($bpnum)
 608                         unset breakpoint_line($bpnum)
 609
 610 # If there's a window for this file, update it
 611
 612                         if {[info exists wins($file)]} {
 613                                 delete_breakpoint_tag $wins($file) $line
 614                         }
 615                 }
 616         }
 617
 618 # If there's an assembly window, update that too
 619
 620         if {$pos_to_bpcount($pc) > 0} {
 621                 decr pos_to_bpcount($pc)
 622
 623                 if {$pos_to_bpcount($pc) == 0} {
 624                         catch "unset pos_to_breakpoint($pc)"
 625
 626                         set win [asm_win_name $cfunc]
 627                         if {[winfo exists $win]} {
 628                                 delete_breakpoint_tag $win [pc_to_line $pclist($cfunc) $pc]
 629                         }
 630                 }
 631         }
 632
 633         delete_breakpoint_frame $bpnum
 634 }
 635
 636 #
 637 # Local procedure:
 638 #
 639 #       enable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
 640 #
 641 # Description:
 642 #
 643 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
 644 #       land of a breakpoint being enabled.  This consists of unstippling the
 645 #       specified breakpoint indicator.
 646 #
 647
 648 proc enable_breakpoint {bpnum file line pc} {
 649         global wins
 650         global cfunc pclist
 651         global enabled
 652
 653         if {[info exists wins($file)]} {
 654                 $wins($file) tag configure $line -fgstipple {}
 655         }
 656
 657 # If there's an assembly window, update that too
 658
 659         set win [asm_win_name $cfunc]
 660         if {[winfo exists $win]} {
 661                 $win tag configure [pc_to_line $pclist($cfunc) $pc] -fgstipple {}
 662         }
 663
 664 # If there's a breakpoint window, update that too
 665
 666         if {[winfo exists .breakpoints]} {
 667                 set enabled($bpnum) 1
 668         }
 669 }
 670
 671 #
 672 # Local procedure:
 673 #
 674 #       disable_breakpoint (bpnum file line pc) - Record breakpoint info in TK land
 675 #
 676 # Description:
 677 #
 678 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to notify TK
 679 #       land of a breakpoint being disabled.  This consists of stippling the
 680 #       specified breakpoint indicator.
 681 #
 682
 683 proc disable_breakpoint {bpnum file line pc} {
 684         global wins
 685         global cfunc pclist
 686         global enabled
 687
 688         if {[info exists wins($file)]} {
 689                 $wins($file) tag configure $line -fgstipple gray50
 690         }
 691
 692 # If there's an assembly window, update that too
 693
 694         set win [asm_win_name $cfunc]
 695         if {[winfo exists $win]} {
 696                 $win tag configure [pc_to_line $pclist($cfunc) $pc] -fgstipple gray50
 697         }
 698
 699 # If there's a breakpoint window, update that too
 700
 701         if {[winfo exists .breakpoints]} {
 702                 set enabled($bpnum) 0
 703         }
 704 }
 705
 706 #
 707 # Local procedure:
 708 #
 709 #       insert_breakpoint_tag (win line) - Insert a breakpoint tag in WIN.
 710 #
 711 # Description:
 712 #
 713 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to insert a
 714 #       breakpoint tag into window WIN at line LINE.
 715 #
 716
 717 proc insert_breakpoint_tag {win line} {
 718         $win configure -state normal
 719         $win delete $line.0
 720         $win insert $line.0 "B"
 721         $win tag add margin $line.0 $line.8
 722
 723         $win configure -state disabled
 724 }
 725
 726 #
 727 # Local procedure:
 728 #
 729 #       delete_breakpoint_tag (win line) - Remove a breakpoint tag from WIN.
 730 #
 731 # Description:
 732 #
 733 #       GDB calls this indirectly (through gdbtk_tcl_breakpoint) to remove a
 734 #       breakpoint tag from window WIN at line LINE.
 735 #
 736
 737 proc delete_breakpoint_tag {win line} {
 738         $win configure -state normal
 739         $win delete $line.0
 740         if {[string range $win 0 3] == ".src"} then {
 741                 $win insert $line.0 "\xa4"
 742         } else {
 743                 $win insert $line.0 " "
 744         }
 745         $win tag add margin $line.0 $line.8
 746         $win configure -state disabled
 747 }
 748
 749 proc gdbtk_tcl_busy {} {
 750         if {[winfo exists .cmd]} {
 751                 .cmd.text configure -state disabled
 752         }
 753         if {[winfo exists .src]} {
 754                 .src.start configure -state disabled
 755                 .src.stop configure -state normal
 756                 .src.step configure -state disabled
 757                 .src.next configure -state disabled
 758                 .src.continue configure -state disabled
 759                 .src.finish configure -state disabled
 760                 .src.up configure -state disabled
 761                 .src.down configure -state disabled
 762                 .src.bottom configure -state disabled
 763         }
 764         if {[winfo exists .asm]} {
 765                 .asm.stepi configure -state disabled
 766                 .asm.nexti configure -state disabled
 767                 .asm.continue configure -state disabled
 768                 .asm.finish configure -state disabled
 769                 .asm.up configure -state disabled
 770                 .asm.down configure -state disabled
 771                 .asm.bottom configure -state disabled
 772         }
 773         return
 774 }
 775
 776 proc gdbtk_tcl_idle {} {
 777         if {[winfo exists .cmd]} {
 778                 .cmd.text configure -state normal
 779         }
 780         if {[winfo exists .src]} {
 781                 .src.start configure -state normal
 782                 .src.stop configure -state disabled
 783                 .src.step configure -state normal
 784                 .src.next configure -state normal
 785                 .src.continue configure -state normal
 786                 .src.finish configure -state normal
 787                 .src.up configure -state normal
 788                 .src.down configure -state normal
 789                 .src.bottom configure -state normal
 790         }
 791         if {[winfo exists .asm]} {
 792                 .asm.stepi configure -state normal
 793                 .asm.nexti configure -state normal
 794                 .asm.continue configure -state normal
 795                 .asm.finish configure -state normal
 796                 .asm.up configure -state normal
 797                 .asm.down configure -state normal
 798                 .asm.bottom configure -state normal
 799         }
 800         return
 801 }
 802
 803 #
 804 # Local procedure:
 805 #
 806 #       pc_to_line (pclist pc) - convert PC to a line number.
 807 #
 808 # Description:
 809 #
 810 #       Convert PC to a line number from PCLIST.  If exact line isn't found,
 811 #       we return the first line that starts before PC.
 812 #
 813 proc pc_to_line {pclist pc} {
 814         set line [lsearch -exact $pclist $pc]
 815
 816         if {$line >= 1} { return $line }
 817
 818         set line 1
 819         foreach linepc [lrange $pclist 1 end] {
 820                 if {$pc < $linepc} { decr line ; return $line }
 821                 incr line
 822         }
 823         return [expr {$line - 1}]
 824 }
 825
 826 #
 827 # Menu:
 828 #
 829 #       file popup menu - Define the file popup menu.
 830 #
 831 # Description:
 832 #
 833 #       This menu just contains a bunch of buttons that do various things to
 834 #       the line under the cursor.
 835 #
 836 # Items:
 837 #
 838 #       Edit - Run the editor (specified by the environment variable EDITOR) on
 839 #              this file, at the current line.
 840 #       Breakpoint - Set a breakpoint at the current line.  This just shoves
 841 #               a `break' command at GDB with the appropriate file and line
 842 #               number.  Eventually, GDB calls us back (at gdbtk_tcl_breakpoint)
 843 #               to notify us of where the breakpoint needs to show up.
 844 #
 845
 846 menu .file_popup -cursor hand2 -tearoff 0
 847 .file_popup add command -label "Not yet set" -state disabled
 848 .file_popup add separator
 849 .file_popup add command -label "Edit" \
 850   -command {exec $editor +$selected_line $selected_file &}
 851 .file_popup add command -label "Set breakpoint" \
 852   -command {gdb_cmd "break $selected_file:$selected_line"}
 853
 854 # Use this procedure to get the GDB core to execute the string `cmd'.  This is
 855 # a wrapper around gdb_cmd, which will catch errors, and send output to the
 856 # command window.  It will also cause all of the other windows to be updated.
 857
 858 proc interactive_cmd {cmd} {
 859         catch {gdb_cmd "$cmd"} result
 860         .cmd.text insert end $result
 861         .cmd.text see end
 862         update_ptr
 863 }
 864
 865 #
 866 # Bindings:
 867 #
 868 #       file popup menu - Define the file popup menu bindings.
 869 #
 870 # Description:
 871 #
 872 #       This defines the binding for the file popup menu.  It simply
 873 #       unhighlights the line under the cursor.
 874 #
 875
 876 bind .file_popup <Any-ButtonRelease-1> {
 877   global selected_win
 878   # Unhighlight the selected line
 879   $selected_win tag delete breaktag
 880 }
 881
 882 #
 883 # Local procedure:
 884 #
 885 #       listing_window_popup (win x y xrel yrel) - Handle popups for listing window
 886 #
 887 # Description:
 888 #
 889 #       This procedure is invoked by holding down button 2 (usually) in the
 890 #       listing window.  The action taken depends upon where the button was
 891 #       pressed.  If it was in the left margin (the breakpoint column), it
 892 #       sets or clears a breakpoint.  In the main text area, it will pop up a
 893 #       menu.
 894 #
 895
 896 proc listing_window_popup {win x y xrel yrel} {
 897         global wins
 898         global win_to_file
 899         global file_to_debug_file
 900         global highlight
 901         global selected_line
 902         global selected_file
 903         global selected_win
 904         global pos_to_breakpoint
 905
 906 # Map TK window name back to file name.
 907
 908         set file $win_to_file($win)
 909
 910         set pos [split [$win index @$xrel,$yrel] .]
 911
 912 # Record selected file and line for menu button actions
 913
 914         set selected_file $file_to_debug_file($file)
 915         set selected_line [lindex $pos 0]
 916         set selected_col [lindex $pos 1]
 917         set selected_win $win
 918
 919 # Post the menu near the pointer, (and grab it)
 920
 921         .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
 922
 923         tk_popup .file_popup $x $y
 924 }
 925
 926 #
 927 # Local procedure:
 928 #
 929 #       toggle_breakpoint (win x y xrel yrel) - Handle clicks on breakdots
 930 #
 931 # Description:
 932 #
 933 #       This procedure sets or clears breakpoints where the button clicked.
 934 #
 935
 936 proc toggle_breakpoint {win x y xrel yrel} {
 937         global wins
 938         global win_to_file
 939         global file_to_debug_file
 940         global highlight
 941         global selected_line
 942         global selected_file
 943         global selected_win
 944         global pos_to_breakpoint
 945
 946 # Map TK window name back to file name.
 947
 948         set file $win_to_file($win)
 949
 950         set pos [split [$win index @$xrel,$yrel] .]
 951
 952 # Record selected file and line
 953
 954         set selected_file $file_to_debug_file($file)
 955         set selected_line [lindex $pos 0]
 956         set selected_col [lindex $pos 1]
 957         set selected_win $win
 958
 959 # If we're in the margin, then toggle the breakpoint
 960
 961         if {$selected_col < 8} {  # this is alway true actually
 962               set pos_break $selected_file:$selected_line
 963               set pos $file:$selected_line
 964               set tmp pos_to_breakpoint($pos)
 965               if {[info exists $tmp]} {
 966                       set bpnum [set $tmp]
 967                       gdb_cmd "delete $bpnum"
 968               } else {
 969                       gdb_cmd "break $pos_break"
 970               }
 971               return
 972         }
 973 }
 974
 975 #
 976 # Local procedure:
 977 #
 978 #       asm_window_button_1 (win x y xrel yrel) - Handle button 1 in asm window
 979 #
 980 # Description:
 981 #
 982 #       This procedure is invoked as a result of holding down button 1 in the
 983 #       assembly window.  The action taken depends upon where the button was
 984 #       pressed.  If it was in the left margin (the breakpoint column), it
 985 #       sets or clears a breakpoint.  In the main text area, it will pop up a
 986 #       menu.
 987 #
 988
 989 proc asm_window_button_1 {win x y xrel yrel} {
 990         global wins
 991         global win_to_file
 992         global file_to_debug_file
 993         global highlight
 994         global selected_line
 995         global selected_file
 996         global selected_win
 997         global pos_to_breakpoint
 998         global pclist
 999         global cfunc
1000
1001         set pos [split [$win index @$xrel,$yrel] .]
1002
1003 # Record selected file and line for menu button actions
1004
1005         set selected_line [lindex $pos 0]
1006         set selected_col [lindex $pos 1]
1007         set selected_win $win
1008
1009 # Figure out the PC
1010
1011         set pc [lindex $pclist($cfunc) $selected_line]
1012
1013 # If we're in the margin, then toggle the breakpoint
1014
1015         if {$selected_col < 11} {
1016                 set tmp pos_to_breakpoint($pc)
1017                 if {[info exists $tmp]} {
1018                         set bpnum [set $tmp]
1019                         gdb_cmd "delete $bpnum"
1020                 } else {
1021                         gdb_cmd "break *$pc"
1022                 }
1023                 return
1024         }
1025
1026 # Post the menu near the pointer, (and grab it)
1027
1028 #       .file_popup entryconfigure 0 -label "$selected_file:$selected_line"
1029 #       .file_popup post [expr $x-[winfo width .file_popup]/2] [expr $y-10]
1030 #       grab .file_popup
1031 }
1032
1033 #
1034 # Local procedure:
1035 #
1036 #       do_nothing - Does absolutely nothing.
1037 #
1038 # Description:
1039 #
1040 #       This procedure does nothing.  It is used as a placeholder to allow
1041 #       the disabling of bindings that would normally be inherited from the
1042 #       parent widget.  I can't think of any other way to do this.
1043 #
1044
1045 proc do_nothing {} {}
1046
1047 #
1048 # Local procedure:
1049 #
1050 #       not_implemented_yet - warn that a feature is unavailable
1051 #
1052 # Description:
1053 #
1054 #       This procedure warns that something doesn't actually work yet.
1055 #
1056
1057 proc not_implemented_yet {message} {
1058         tk_dialog .unimpl "gdb : unimpl" \
1059                 "$message: not implemented in the interface yet" \
1060                 warning 0 "OK"
1061 }
1062
1063 ##
1064 # Local procedure:
1065 #
1066 #       create_expr_window - Create expression display window
1067 #
1068 # Description:
1069 #
1070 #       Create the expression display window.
1071 #
1072
1073 set expr_num 0
1074 set delete_expr_num 0
1075
1076 # Set delete_expr_num, and set -state of Delete button.
1077 proc expr_update_button {num} {
1078   global delete_expr_num
1079   set delete_expr_num $num
1080   if {$num > 0} then {
1081     set state normal
1082   } else {
1083     set state disabled
1084   }
1085   .expr.buts.delete configure -state $state
1086 }
1087
1088 proc add_expr {expr} {
1089   global expr_update_list
1090   global expr_num
1091
1092   incr expr_num
1093
1094   set e .expr.exprs
1095   set f e$expr_num
1096
1097   checkbutton $e.updates.$f -text "" -relief flat \
1098     -variable expr_update_list($expr_num)
1099   text $e.expressions.$f -width 20 -height 1
1100   $e.expressions.$f insert 0.0 $expr
1101   bind $e.expressions.$f <1> "update_expr $expr_num"
1102   text $e.values.$f -width 20 -height 1
1103
1104   # Set up some bindings.
1105   foreach frame {updates expressions values} {
1106     bind $e.$frame.$f <FocusIn> "expr_update_button $expr_num"
1107     bind $e.$frame.$f <FocusOut> "expr_update_button 0"
1108   }
1109
1110   update_expr $expr_num
1111
1112   pack $e.updates.$f -side top
1113   pack $e.expressions.$f -side top -expand yes -fill x
1114   pack $e.values.$f -side top -expand yes -fill x
1115 }
1116
1117 proc delete_expr {} {
1118   global delete_expr_num
1119   if {$delete_expr_num > 0} then {
1120     set e .expr.exprs
1121     set f e${delete_expr_num}
1122
1123     destroy $e.updates.$f $e.expressions.$f $e.values.$f
1124
1125     # FIXME should we unset an element of expr_update_list here?
1126   }
1127 }
1128
1129 proc update_expr {expr_num} {
1130   global expr_update_list
1131
1132   set e .expr.exprs
1133   set f e${expr_num}
1134
1135   set expr [$e.expressions.$f get 0.0 end]
1136   $e.values.$f delete 0.0 end
1137   if {! [catch {gdb_eval $expr} val]} {
1138     $e.values.$f insert 0.0 $val
1139   } {
1140     # FIXME consider flashing widget here.
1141   }
1142 }
1143
1144 proc update_exprs {} {
1145         global expr_update_list
1146
1147         foreach expr_num [array names expr_update_list] {
1148                 if {$expr_update_list($expr_num)} {
1149                         update_expr $expr_num
1150                 }
1151         }
1152 }
1153
1154 proc create_expr_window {} {
1155
1156         if {[winfo exists .expr]} {raise .expr ; return}
1157
1158         toplevel .expr
1159         wm title .expr "GDB Expressions"
1160         wm iconname .expr "Expressions"
1161
1162         frame .expr.entryframe -borderwidth 2 -relief raised
1163         label .expr.entryframe.entrylab -text "Expression: "
1164         entry .expr.entryframe.entry -borderwidth 2 -relief sunken
1165         bind .expr.entryframe.entry <Return> {
1166           add_expr [.expr.entryframe.entry get]
1167           .expr.entryframe.entry delete 0 end
1168         }
1169
1170         pack .expr.entryframe.entrylab -side left
1171         pack .expr.entryframe.entry -side left -fill x -expand yes
1172
1173         frame .expr.buts -borderwidth 2 -relief raised
1174
1175         button .expr.buts.delete -text Delete -command delete_expr \
1176           -state disabled
1177
1178         button .expr.buts.close -text Close -command {destroy .expr}
1179         button .expr.buts.help -text Help -state disabled
1180
1181         pack .expr.buts.delete -side left
1182         pack .expr.buts.help .expr.buts.close -side right
1183
1184         pack .expr.buts -side bottom -fill x
1185         pack .expr.entryframe -side bottom -fill x
1186
1187         frame .expr.exprs -borderwidth 2 -relief raised
1188
1189         # Use three subframes so columns will line up.  Easier than
1190         # dealing with BLT for a table geometry manager.  Someday Tk
1191         # will have one, use it then.  FIXME this messes up keyboard
1192         # traversal.
1193         frame .expr.exprs.updates -borderwidth 0 -relief flat
1194         frame .expr.exprs.expressions -borderwidth 0 -relief flat
1195         frame .expr.exprs.values -borderwidth 0 -relief flat
1196
1197         label .expr.exprs.updates.label -text Update
1198         pack .expr.exprs.updates.label -side top -anchor w
1199         label .expr.exprs.expressions.label -text Expression
1200         pack .expr.exprs.expressions.label -side top -anchor w
1201         label .expr.exprs.values.label -text Value
1202         pack .expr.exprs.values.label -side top -anchor w
1203
1204         pack .expr.exprs.updates -side left
1205         pack .expr.exprs.values .expr.exprs.expressions \
1206           -side right -expand 1 -fill x
1207
1208         pack .expr.exprs -side top -fill both -expand 1 -anchor w
1209 }
1210
1211 #
1212 # Local procedure:
1213 #
1214 #       display_expression (expression) - Display EXPRESSION in display window
1215 #
1216 # Description:
1217 #
1218 #       Display EXPRESSION and its value in the expression display window.
1219 #
1220
1221 proc display_expression {expression} {
1222         create_expr_window
1223
1224         add_expr $expression
1225 }
1226
1227 #
1228 # Local procedure:
1229 #
1230 #       create_file_win (filename) - Create a win for FILENAME.
1231 #
1232 # Return value:
1233 #
1234 #       The new text widget.
1235 #
1236 # Description:
1237 #
1238 #       This procedure creates a text widget for FILENAME.  It returns the
1239 #       newly created widget.  First, a text widget is created, and given basic
1240 #       configuration info.  Second, all the bindings are setup.  Third, the
1241 #       file FILENAME is read into the text widget.  Fourth, margins and line
1242 #       numbers are added.
1243 #
1244
1245 proc create_file_win {filename debug_file} {
1246         global breakpoint_file
1247         global breakpoint_line
1248         global line_numbers
1249         global debug_interface
1250
1251 # Replace all the dirty characters in $filename with clean ones, and generate
1252 # a unique name for the text widget.
1253
1254         regsub -all {\.} $filename {} temp
1255         set win .src.text$temp
1256
1257 # Open the file, and read it into the text widget
1258
1259         if {[catch "open $filename" fh]} {
1260 # File can't be read.  Put error message into .src.nofile window and return.
1261
1262                 catch {destroy .src.nofile}
1263                 text .src.nofile -height 25 -width 88 -relief sunken \
1264                         -borderwidth 2 -yscrollcommand ".src.scroll set" \
1265                         -setgrid true -cursor hand2
1266                 .src.nofile insert 0.0 $fh
1267                 .src.nofile configure -state disabled
1268                 bind .src.nofile <1> do_nothing
1269                 bind .src.nofile <B1-Motion> do_nothing
1270                 return .src.nofile
1271         }
1272
1273 # Actually create and do basic configuration on the text widget.
1274
1275         text $win -height 25 -width 88 -relief sunken -borderwidth 2 \
1276                 -yscrollcommand ".src.scroll set" -setgrid true -cursor hand2
1277
1278 # Setup all the bindings
1279
1280         bind $win <Enter> {focus %W}
1281         bind $win <1> do_nothing
1282         bind $win <B1-Motion> do_nothing
1283
1284         bind $win <Key-Alt_R> do_nothing
1285         bind $win <Key-Alt_L> do_nothing
1286         bind $win <Key-Prior> "$win yview {@0,0 - 10 lines}"
1287         bind $win <Key-Next> "$win yview {@0,0 + 10 lines}"
1288         bind $win <Key-Up> "$win yview {@0,0 - 1 lines}"
1289         bind $win <Key-Down> "$win yview {@0,0 + 1 lines}"
1290         bind $win <Key-Home> {update_listing [gdb_loc]}
1291         bind $win <Key-End> "$win see end"
1292
1293         bind $win n {interactive_cmd next}
1294         bind $win s {interactive_cmd step}
1295         bind $win c {interactive_cmd continue}
1296         bind $win f {interactive_cmd finish}
1297         bind $win u {interactive_cmd up}
1298         bind $win d {interactive_cmd down}
1299
1300         if $debug_interface {
1301             bind $win <Control-C> {
1302                 puts stdout burp
1303             }
1304         }
1305
1306         $win delete 0.0 end
1307         $win insert 0.0 [read $fh]
1308         close $fh
1309
1310 # Add margins (for annotations) and a line number to each line (if requested)
1311
1312         set numlines [$win index end]
1313         set numlines [lindex [split $numlines .] 0]
1314         if {$line_numbers} {
1315                 for {set i 1} {$i <= $numlines} {incr i} {
1316                         $win insert $i.0 [format "   %4d " $i]
1317                         $win tag add source $i.8 "$i.0 lineend"
1318                         }
1319         } else {
1320                 for {set i 1} {$i <= $numlines} {incr i} {
1321                         $win insert $i.0 "        "
1322                         $win tag add source $i.8 "$i.0 lineend"
1323                         }
1324         }
1325
1326 # Add the breakdots
1327
1328         foreach i [gdb_sourcelines $debug_file] {
1329                 $win delete $i.0
1330                 $win insert $i.0 "\xa4"
1331                 $win tag add margin $i.0 $i.8
1332                 }
1333
1334         # A debugging trick to highlight sensitive regions.
1335         if $debug_interface {
1336             $win tag bind source <Enter> {
1337                 %W tag configure source -background yellow
1338             }
1339             $win tag bind source <Leave> {
1340                 %W tag configure source -background green
1341             }
1342             $win tag bind margin <Enter> {
1343                 %W tag configure margin -background red
1344             }
1345             $win tag bind margin <Leave> {
1346                 %W tag configure margin -background skyblue
1347             }
1348         }
1349
1350         $win tag bind margin <1> {
1351                 toggle_breakpoint %W %X %Y %x %y
1352                 }
1353
1354         $win tag bind source <1> {
1355                 %W mark set anchor "@%x,%y wordstart"
1356                 set last [%W index "@%x,%y wordend"]
1357                 %W tag remove sel 0.0 anchor
1358                 %W tag remove sel $last end
1359                 %W tag add sel anchor $last
1360                 }
1361 #       $win tag bind source <Double-Button-1> {
1362 #               %W mark set anchor "@%x,%y wordstart"
1363 #               set last [%W index "@%x,%y wordend"]
1364 #               %W tag remove sel 0.0 anchor
1365 #               %W tag remove sel $last end
1366 #               %W tag add sel anchor $last
1367 #               echo "Selected [selection get]"
1368 #               }
1369         $win tag bind source <B1-Motion> {
1370                 %W tag remove sel 0.0 anchor
1371                 %W tag remove sel $last end
1372                 %W tag add sel anchor @%x,%y
1373                 }
1374         $win tag bind sel <1> break
1375         $win tag bind sel <Double-Button-1> {
1376             display_expression [selection get]
1377             break
1378         }
1379         $win tag bind sel <B1-Motion> break
1380         $win tag lower sel
1381
1382         $win tag bind source <2> {
1383                 listing_window_popup %W %X %Y %x %y
1384                 }
1385
1386         # Make these bindings do nothing on the text window -- they
1387         # are completely handled by the tag bindings above.
1388         bind $win <1> break
1389         bind $win <B1-Motion> break
1390         bind $win <Double-Button-1> break
1391
1392 # Scan though the breakpoint data base and install any destined for this file
1393
1394         foreach bpnum [array names breakpoint_file] {
1395                 if {$breakpoint_file($bpnum) == $filename} {
1396                         insert_breakpoint_tag $win $breakpoint_line($bpnum)
1397                         }
1398                 }
1399
1400 # Disable the text widget to prevent user modifications
1401
1402         $win configure -state disabled
1403         return $win
1404 }
1405
1406 #
1407 # Local procedure:
1408 #
1409 #       create_asm_win (funcname pc) - Create an assembly win for FUNCNAME.
1410 #
1411 # Return value:
1412 #
1413 #       The new text widget.
1414 #
1415 # Description:
1416 #
1417 #       This procedure creates a text widget for FUNCNAME.  It returns the
1418 #       newly created widget.  First, a text widget is created, and given basic
1419 #       configuration info.  Second, all the bindings are setup.  Third, the
1420 #       function FUNCNAME is read into the text widget.
1421 #
1422
1423 proc create_asm_win {funcname pc} {
1424         global breakpoint_file
1425         global breakpoint_line
1426         global pclist
1427         global disassemble_with_source
1428
1429 # Replace all the dirty characters in $filename with clean ones, and generate
1430 # a unique name for the text widget.
1431
1432         set win [asm_win_name $funcname]
1433
1434 # Actually create and do basic configuration on the text widget.
1435
1436         text $win -height 25 -width 80 -relief sunken -borderwidth 2 \
1437                 -setgrid true -cursor hand2 -yscrollcommand ".asm.scroll set"
1438
1439 # Setup all the bindings
1440
1441         bind $win <Enter> {focus %W}
1442         bind $win <1> {asm_window_button_1 %W %X %Y %x %y; break}
1443         bind $win <B1-Motion> break
1444         bind $win <Double-Button-1> break
1445
1446         bind $win <Key-Alt_R> do_nothing
1447         bind $win <Key-Alt_L> do_nothing
1448
1449         bind $win n {interactive_cmd nexti}
1450         bind $win s {interactive_cmd stepi}
1451         bind $win c {interactive_cmd continue}
1452         bind $win f {interactive_cmd finish}
1453         bind $win u {interactive_cmd up}
1454         bind $win d {interactive_cmd down}
1455
1456 # Disassemble the code, and read it into the new text widget
1457
1458         $win insert end [gdb_disassemble $disassemble_with_source $pc]
1459
1460         set numlines [$win index end]
1461         set numlines [lindex [split $numlines .] 0]
1462         decr numlines
1463
1464 # Delete the first and last lines, cuz these contain useless info
1465
1466 #       $win delete 1.0 2.0
1467 #       $win delete {end - 1 lines} end
1468 #       decr numlines 2
1469
1470 # Add margins (for annotations) and note the PC for each line
1471
1472         catch "unset pclist($funcname)"
1473         lappend pclist($funcname) Unused
1474         for {set i 1} {$i <= $numlines} {incr i} {
1475                 scan [$win get $i.0 "$i.0 lineend"] "%s " pc
1476                 lappend pclist($funcname) $pc
1477                 $win insert $i.0 "    "
1478                 }
1479
1480 # Scan though the breakpoint data base and install any destined for this file
1481
1482 #       foreach bpnum [array names breakpoint_file] {
1483 #               if {$breakpoint_file($bpnum) == $filename} {
1484 #                       insert_breakpoint_tag $win $breakpoint_line($bpnum)
1485 #                       }
1486 #               }
1487
1488 # Disable the text widget to prevent user modifications
1489
1490         $win configure -state disabled
1491         return $win
1492 }
1493
1494 #
1495 # Local procedure:
1496 #
1497 #       update_listing (linespec) - Update the listing window according to
1498 #                                   LINESPEC.
1499 #
1500 # Description:
1501 #
1502 #       This procedure is called from various places to update the listing
1503 #       window based on LINESPEC.  It is usually invoked with the result of
1504 #       gdb_loc.
1505 #
1506 #       It will move the cursor, and scroll the text widget if necessary.
1507 #       Also, it will switch to another text widget if necessary, and update
1508 #       the label widget too.
1509 #
1510 #       LINESPEC is a list of the form:
1511 #
1512 #       { DEBUG_FILE FUNCNAME FILENAME LINE }, where:
1513 #
1514 #       DEBUG_FILE - is the abbreviated form of the file name.  This is usually
1515 #                    the file name string given to the cc command.  This is
1516 #                    primarily needed for breakpoint commands, and when an
1517 #                    abbreviated for of the filename is desired.
1518 #       FUNCNAME - is the name of the function.
1519 #       FILENAME - is the fully qualified (absolute) file name.  It is usually
1520 #                  the same as $PWD/$DEBUG_FILE, where PWD is the working dir
1521 #                  at the time the cc command was given.  This is used to
1522 #                  actually locate the file to be displayed.
1523 #       LINE - The line number to be displayed.
1524 #
1525 #       Usually, this procedure will just move the cursor one line down to the
1526 #       next line to be executed.  However, if the cursor moves out of range
1527 #       or into another file, it will scroll the text widget so that the line
1528 #       of interest is in the middle of the viewable portion of the widget.
1529 #
1530
1531 proc update_listing {linespec} {
1532         global pointers
1533         global wins cfile
1534         global current_label
1535         global win_to_file
1536         global file_to_debug_file
1537         global .src.label
1538
1539 # Rip the linespec apart
1540
1541         lassign $linespec debug_file funcname filename line
1542
1543 # Sometimes there's no source file for this location
1544
1545         if {$filename == ""} {set filename Blank}
1546
1547 # If we want to switch files, we need to unpack the current text widget, and
1548 # stick in the new one.
1549
1550         if {$filename != $cfile} then {
1551                 pack forget $wins($cfile)
1552                 set cfile $filename
1553
1554 # Create a text widget for this file if necessary
1555
1556                 if {![info exists wins($cfile)]} then {
1557                         set wins($cfile) [create_file_win $cfile $debug_file]
1558                         if {$wins($cfile) != ".src.nofile"} {
1559                                 set win_to_file($wins($cfile)) $cfile
1560                                 set file_to_debug_file($cfile) $debug_file
1561                                 set pointers($cfile) 1.1
1562                                 }
1563                         }
1564
1565 # Pack the text widget into the listing widget, and scroll to the right place
1566
1567                 pack $wins($cfile) -side left -expand yes -in .src.info \
1568                         -fill both -after .src.scroll
1569
1570 # Make the scrollbar point at the new text widget
1571
1572                 .src.scroll configure -command "$wins($cfile) yview"
1573
1574                  # $wins($cfile) see "${line}.0 linestart"
1575                  ensure_line_visible $wins($cfile) $line
1576                 }
1577
1578 # Update the label widget in case the filename or function name has changed
1579
1580         if {$current_label != "$filename.$funcname"} then {
1581                 set tail [expr [string last / $filename] + 1]
1582                 set .src.label "[string range $filename $tail end] : ${funcname}()"
1583 #               .src.label configure -text "[string range $filename $tail end] : ${funcname}()"
1584                 set current_label $filename.$funcname
1585                 }
1586
1587 # Update the pointer, scrolling the text widget if necessary to keep the
1588 # pointer in an acceptable part of the screen.
1589
1590         if {[info exists pointers($cfile)]} then {
1591                 $wins($cfile) configure -state normal
1592                 set pointer_pos $pointers($cfile)
1593                 $wins($cfile) configure -state normal
1594                 $wins($cfile) delete $pointer_pos "$pointer_pos + 2 char"
1595                 $wins($cfile) insert $pointer_pos "  "
1596
1597                 set pointer_pos [$wins($cfile) index $line.1]
1598                 set pointers($cfile) $pointer_pos
1599
1600                 $wins($cfile) delete $pointer_pos "$pointer_pos + 2 char"
1601                 $wins($cfile) insert $pointer_pos "->"
1602                 ensure_line_visible $wins($cfile) $line
1603                 $wins($cfile) configure -state disabled
1604                 }
1605 }
1606
1607 #
1608 # Local procedure:
1609 #
1610 #       create_asm_window - Open up the assembly window.
1611 #
1612 # Description:
1613 #
1614 #       Create an assembly window if it doesn't exist.
1615 #
1616
1617 proc create_asm_window {} {
1618         global cfunc
1619
1620         if {[winfo exists .asm]} {raise .asm ; return}
1621
1622         set cfunc *None*
1623         set win [asm_win_name $cfunc]
1624
1625         build_framework .asm Assembly "*NIL*"
1626
1627 # First, delete all the old menu entries
1628
1629         .asm.menubar.view.menu delete 0 last
1630
1631         .asm.text configure -yscrollcommand ".asm.scroll set"
1632
1633         frame .asm.row1
1634         frame .asm.row2
1635
1636         button .asm.stepi -width 6 -text Stepi \
1637                 -command {interactive_cmd stepi}
1638         button .asm.nexti -width 6 -text Nexti \
1639                 -command {interactive_cmd nexti}
1640         button .asm.continue -width 6 -text Cont \
1641                 -command {interactive_cmd continue}
1642         button .asm.finish -width 6 -text Finish \
1643                 -command {interactive_cmd finish}
1644         button .asm.up -width 6 -text Up -command {interactive_cmd up}
1645         button .asm.down -width 6 -text Down \
1646                 -command {interactive_cmd down}
1647         button .asm.bottom -width 6 -text Bottom \
1648                 -command {interactive_cmd {frame 0}}
1649
1650         pack .asm.stepi .asm.continue .asm.up .asm.bottom -side left -padx 3 -pady 5 -in .asm.row1
1651         pack .asm.nexti .asm.finish .asm.down -side left -padx 3 -pady 5 -in .asm.row2
1652
1653         pack .asm.row2 .asm.row1 -side bottom -anchor w -before .asm.info
1654
1655         update
1656
1657         update_assembly [gdb_loc]
1658
1659 # We do this update_assembly to get the proper value of disassemble-from-exec.
1660
1661 # exec file menu item
1662         .asm.menubar.view.menu add radiobutton -label "Exec file" \
1663                 -variable disassemble-from-exec -value 1
1664 # target memory menu item
1665         .asm.menubar.view.menu add radiobutton -label "Target memory" \
1666                 -variable disassemble-from-exec -value 0
1667
1668 # Disassemble with source
1669         .asm.menubar.view.menu add checkbutton -label "Source" \
1670                 -variable disassemble_with_source -onvalue source \
1671                 -offvalue nosource -command {
1672                         foreach asm [info command .asm.func_*] {
1673                                 destroy $asm
1674                                 }
1675                         set cfunc NIL
1676                         update_assembly [gdb_loc]
1677                 }
1678 }
1679
1680 proc reg_config_menu {} {
1681         catch {destroy .reg.config}
1682         toplevel .reg.config
1683         wm geometry .reg.config +300+300
1684         wm title .reg.config "Register configuration"
1685         wm iconname .reg.config "Reg config"
1686         set regnames [gdb_regnames]
1687         set num_regs [llength $regnames]
1688
1689         frame .reg.config.buts
1690
1691         button .reg.config.done -text " Done " -command "
1692                 recompute_reg_display_list $num_regs
1693                 populate_reg_window
1694                 update_registers all
1695                 destroy .reg.config "
1696
1697         button .reg.config.update -text Update -command "
1698                 recompute_reg_display_list $num_regs
1699                 populate_reg_window
1700                 update_registers all "
1701
1702         pack .reg.config.buts -side bottom -fill x
1703
1704         pack .reg.config.done -side left -fill x -expand yes -in .reg.config.buts
1705         pack .reg.config.update -side right -fill x -expand yes -in .reg.config.buts
1706
1707 # Since there can be lots of registers, we build the window with no more than
1708 # 32 rows, and as many columns as needed.
1709
1710 # First, figure out how many columns we need and create that many column frame
1711 # widgets
1712
1713         set ncols [expr ($num_regs + 31) / 32]
1714
1715         for {set col 0} {$col < $ncols} {incr col} {
1716                 frame .reg.config.col$col
1717                 pack .reg.config.col$col -side left -anchor n
1718         }
1719
1720 # Now, create the checkbutton widgets and pack them in the appropriate columns
1721
1722         set col 0
1723         set row 0
1724         for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
1725                 set regname [lindex $regnames $regnum]
1726                 checkbutton .reg.config.col$col.$row -text $regname -pady 0 \
1727                         -variable regena($regnum) -relief flat -anchor w -bd 1
1728
1729                 pack .reg.config.col$col.$row -side top -fill both
1730
1731                 incr row
1732                 if {$row >= 32} {
1733                         incr col
1734                         set row 0
1735                 }
1736         }
1737 }
1738
1739 #
1740 # Local procedure:
1741 #
1742 #       create_registers_window - Open up the register display window.
1743 #
1744 # Description:
1745 #
1746 #       Create the register display window, with automatic updates.
1747 #
1748
1749 proc create_registers_window {} {
1750         global reg_format
1751
1752         if {[winfo exists .reg]} {raise .reg ; return}
1753
1754 # Create an initial register display list consisting of all registers
1755
1756         if {![info exists reg_format]} {
1757                 global reg_display_list
1758                 global changed_reg_list
1759                 global regena
1760
1761                 set reg_format {}
1762                 set num_regs [llength [gdb_regnames]]
1763                 for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
1764                         set regena($regnum) 1
1765                 }
1766                 recompute_reg_display_list $num_regs
1767                 set changed_reg_list $reg_display_list
1768         }
1769
1770         build_framework .reg Registers
1771
1772 # First, delete all the old menu entries
1773
1774         .reg.menubar.view.menu delete 0 last
1775
1776 # Hex menu item
1777         .reg.menubar.view.menu add radiobutton -label Hex \
1778                 -command {set reg_format x ; update_registers all}
1779
1780 # Decimal menu item
1781         .reg.menubar.view.menu add radiobutton -label Decimal \
1782                 -command {set reg_format d ; update_registers all}
1783
1784 # Octal menu item
1785         .reg.menubar.view.menu add radiobutton -label Octal \
1786                 -command {set reg_format o ; update_registers all}
1787
1788 # Natural menu item
1789         .reg.menubar.view.menu add radiobutton -label Natural \
1790                 -command {set reg_format {} ; update_registers all}
1791
1792 # Config menu item
1793         .reg.menubar.view.menu add separator
1794
1795         .reg.menubar.view.menu add command -label Config -command {
1796                 reg_config_menu }
1797
1798         destroy .reg.label
1799
1800 # Install the reg names
1801
1802         populate_reg_window
1803         update_registers all
1804 }
1805
1806 # Convert regena into a list of the enabled $regnums
1807
1808 proc recompute_reg_display_list {num_regs} {
1809         global reg_display_list
1810         global regmap
1811         global regena
1812
1813         catch {unset reg_display_list}
1814
1815         set line 1
1816         for {set regnum 0} {$regnum < $num_regs} {incr regnum} {
1817
1818                 if {[set regena($regnum)] != 0} {
1819                         lappend reg_display_list $regnum
1820                         set regmap($regnum) $line
1821                         incr line
1822                 }
1823         }
1824 }
1825
1826 # Fill out the register window with the names of the regs specified in
1827 # reg_display_list.
1828
1829 proc populate_reg_window {} {
1830         global max_regname_width
1831         global reg_display_list
1832
1833         .reg.text configure -state normal
1834
1835         .reg.text delete 0.0 end
1836
1837         set regnames [eval gdb_regnames $reg_display_list]
1838
1839 # Figure out the longest register name
1840
1841         set max_regname_width 0
1842
1843         foreach reg $regnames {
1844                 set len [string length $reg]
1845                 if {$len > $max_regname_width} {set max_regname_width $len}
1846         }
1847
1848         set width [expr $max_regname_width + 15]
1849
1850         set height [llength $regnames]
1851
1852         if {$height > 60} {set height 60}
1853
1854         .reg.text configure -height $height -width $width
1855
1856         foreach reg $regnames {
1857                 .reg.text insert end [format "%-*s \n" $max_regname_width ${reg}]
1858         }
1859
1860         .reg.text yview 0
1861         .reg.text configure -state disabled
1862 }
1863
1864 #
1865 # Local procedure:
1866 #
1867 #       update_registers - Update the registers window.
1868 #
1869 # Description:
1870 #
1871 #       This procedure updates the registers window.
1872 #
1873
1874 proc update_registers {which} {
1875         global max_regname_width
1876         global reg_format
1877         global reg_display_list
1878         global changed_reg_list
1879         global highlight
1880         global regmap
1881
1882         set margin [expr $max_regname_width + 1]
1883         set win .reg.text
1884         set winwidth [lindex [$win configure -width] 4]
1885         set valwidth [expr $winwidth - $margin]
1886
1887         $win configure -state normal
1888
1889         if {$which == "all"} {
1890                 set lineindex 1
1891                 foreach regnum $reg_display_list {
1892                         set regval [gdb_fetch_registers $reg_format $regnum]
1893                         set regval [format "%-*s" $valwidth $regval]
1894                         $win delete $lineindex.$margin "$lineindex.0 lineend"
1895                         $win insert $lineindex.$margin $regval
1896                         incr lineindex
1897                 }
1898                 $win configure -state disabled
1899                 return
1900         }
1901
1902 # Unhighlight the old values
1903
1904         foreach regnum $changed_reg_list {
1905                 $win tag delete $win.$regnum
1906         }
1907
1908 # Now, highlight the changed values of the interesting registers
1909
1910         set changed_reg_list [eval gdb_changed_register_list $reg_display_list]
1911
1912         set lineindex 1
1913         foreach regnum $changed_reg_list {
1914                 set regval [gdb_fetch_registers $reg_format $regnum]
1915                 set regval [format "%-*s" $valwidth $regval]
1916
1917                 set lineindex $regmap($regnum)
1918                 $win delete $lineindex.$margin "$lineindex.0 lineend"
1919                 $win insert $lineindex.$margin $regval
1920                 $win tag add $win.$regnum $lineindex.0 "$lineindex.0 lineend"
1921                 eval $win tag configure $win.$regnum $highlight
1922         }
1923
1924         $win configure -state disabled
1925 }
1926
1927 #
1928 # Local procedure:
1929 #
1930 #       update_assembly - Update the assembly window.
1931 #
1932 # Description:
1933 #
1934 #       This procedure updates the assembly window.
1935 #
1936
1937 proc update_assembly {linespec} {
1938         global asm_pointers
1939         global wins cfunc
1940         global current_label
1941         global win_to_file
1942         global file_to_debug_file
1943         global current_asm_label
1944         global pclist
1945         global .asm.label
1946
1947 # Rip the linespec apart
1948
1949         lassign $linespec debug_file funcname filename line pc
1950
1951         set win [asm_win_name $cfunc]
1952
1953 # Sometimes there's no source file for this location
1954
1955         if {$filename == ""} {set filename Blank}
1956
1957 # If we want to switch funcs, we need to unpack the current text widget, and
1958 # stick in the new one.
1959
1960         if {$funcname != $cfunc } {
1961                 set oldwin $win
1962                 set cfunc $funcname
1963
1964                 set win [asm_win_name $cfunc]
1965
1966 # Create a text widget for this func if necessary
1967
1968                 if {![winfo exists $win]} {
1969                         create_asm_win $cfunc $pc
1970                         set asm_pointers($cfunc) 1.1
1971                         set current_asm_label NIL
1972                         }
1973
1974 # Pack the text widget, and scroll to the right place
1975
1976                 pack forget $oldwin
1977                 pack $win -side left -expand yes -fill both \
1978                         -after .asm.scroll
1979                 .asm.scroll configure -command "$win yview"
1980                 set line [pc_to_line $pclist($cfunc) $pc]
1981                 ensure_line_visible $win $line
1982                 update
1983                 }
1984
1985 # Update the label widget in case the filename or function name has changed
1986
1987         if {$current_asm_label != "$pc $funcname"} then {
1988                 set .asm.label "$pc $funcname"
1989                 set current_asm_label "$pc $funcname"
1990                 }
1991
1992 # Update the pointer, scrolling the text widget if necessary to keep the
1993 # pointer in an acceptable part of the screen.
1994
1995         if {[info exists asm_pointers($cfunc)]} then {
1996                 $win configure -state normal
1997                 set pointer_pos $asm_pointers($cfunc)
1998                 $win configure -state normal
1999                 $win delete $pointer_pos "$pointer_pos + 2 char"
2000                 $win insert $pointer_pos "  "
2001
2002 # Map the PC back to a line in the window
2003
2004                 set line [pc_to_line $pclist($cfunc) $pc]
2005
2006                 if {$line == -1} {
2007                         echo "Can't find PC $pc"
2008                         return
2009                         }
2010
2011                 set pointer_pos [$win index $line.1]
2012                 set asm_pointers($cfunc) $pointer_pos
2013
2014                 $win delete $pointer_pos "$pointer_pos + 2 char"
2015                 $win insert $pointer_pos "->"
2016                 ensure_line_visible $win $line
2017                 $win configure -state disabled
2018                 }
2019 }
2020
2021 #
2022 # Local procedure:
2023 #
2024 #       update_ptr - Update the listing window.
2025 #
2026 # Description:
2027 #
2028 #       This routine will update the listing window using the result of
2029 #       gdb_loc.
2030 #
2031
2032 proc update_ptr {} {
2033         update_listing [gdb_loc]
2034         if {[winfo exists .asm]} {
2035                 update_assembly [gdb_loc]
2036         }
2037         if {[winfo exists .reg]} {
2038                 update_registers changed
2039         }
2040         if {[winfo exists .expr]} {
2041                 update_exprs
2042         }
2043         if {[winfo exists .autocmd]} {
2044                 update_autocmd
2045         }
2046 }
2047
2048 # Make toplevel window disappear
2049
2050 wm withdraw .
2051
2052 proc files_command {} {
2053   toplevel .files_window
2054
2055   wm minsize .files_window 1 1
2056   #     wm overrideredirect .files_window true
2057   listbox .files_window.list -width 30 -height 20 -setgrid true \
2058     -yscrollcommand {.files_window.scroll set} -relief sunken \
2059     -borderwidth 2
2060   scrollbar .files_window.scroll -orient vertical \
2061     -command {.files_window.list yview} -relief sunken
2062   button .files_window.close -text Close -command {destroy .files_window}
2063   .files_window.list configure -selectmode single
2064
2065   # Get the file list from GDB, sort it, and insert into the widget.
2066   eval .files_window.list insert 0 [lsort [gdb_listfiles]]
2067
2068   pack .files_window.close -side bottom -fill x -expand no -anchor s
2069   pack .files_window.scroll -side right -fill both
2070   pack .files_window.list -side left -fill both -expand yes
2071   bind .files_window.list <Any-ButtonRelease-1> {
2072     set file [%W get [%W curselection]]
2073     gdb_cmd "list $file:1,0"
2074     update_listing [gdb_loc $file:1]
2075     destroy .files_window
2076   }
2077 }
2078
2079 button .files -text Files -command files_command
2080
2081 proc apply_filespec {label default command} {
2082     set filename [FSBox $label $default]
2083     if {$filename != ""} {
2084         if {[catch {gdb_cmd "$command $filename"} retval]} {
2085             tk_dialog .filespec_error "gdb : $label error" \
2086               "Error in command \"$command $filename\"" error \
2087               0 Dismiss
2088             return
2089         }
2090     update_ptr
2091     }
2092 }
2093
2094 # Run editor.
2095 proc run_editor {editor file} {
2096   # FIXME should use index of line in middle of window, not line at
2097   # top.
2098   global wins
2099   set lineNo [lindex [split [$wins($file) index @0,0] .] 0]
2100   exec $editor +$lineNo $file
2101 }
2102
2103 # Setup command window
2104 proc build_framework {win {title GDBtk} {label {}}} {
2105         global ${win}.label
2106
2107         toplevel ${win}
2108         wm title ${win} $title
2109         wm minsize ${win} 1 1
2110
2111         frame ${win}.menubar
2112
2113         menubutton ${win}.menubar.file -padx 12 -text File \
2114                 -menu ${win}.menubar.file.menu -underline 0
2115
2116         menu ${win}.menubar.file.menu
2117         ${win}.menubar.file.menu add command -label File... \
2118                 -command {apply_filespec File a.out file}
2119         ${win}.menubar.file.menu add command -label Target... \
2120                 -command { not_implemented_yet "target" }
2121         ${win}.menubar.file.menu add command -label Edit \
2122                 -command {run_editor $editor $cfile}
2123         ${win}.menubar.file.menu add separator
2124         ${win}.menubar.file.menu add command -label "Exec File..." \
2125                 -command {apply_filespec {Exec File} a.out exec-file}
2126         ${win}.menubar.file.menu add command -label "Symbol File..." \
2127                 -command {apply_filespec {Symbol File} a.out symbol-file}
2128         ${win}.menubar.file.menu add command -label "Add Symbol File..." \
2129                 -command { not_implemented_yet "menu item, add symbol file" }
2130         ${win}.menubar.file.menu add command -label "Core File..." \
2131                 -command {apply_filespec {Core File} core core-file}
2132
2133         ${win}.menubar.file.menu add separator
2134         ${win}.menubar.file.menu add command -label Close \
2135                 -command "destroy ${win}"
2136         ${win}.menubar.file.menu add separator
2137         ${win}.menubar.file.menu add command -label Quit \
2138                 -command {interactive_cmd quit}
2139
2140         menubutton ${win}.menubar.commands -padx 12 -text Commands \
2141                 -menu ${win}.menubar.commands.menu -underline 0
2142
2143         menu ${win}.menubar.commands.menu
2144         ${win}.menubar.commands.menu add command -label Run \
2145                 -command {interactive_cmd run}
2146         ${win}.menubar.commands.menu add command -label Step \
2147                 -command {interactive_cmd step}
2148         ${win}.menubar.commands.menu add command -label Next \
2149                 -command {interactive_cmd next}
2150         ${win}.menubar.commands.menu add command -label Continue \
2151                 -command {interactive_cmd continue}
2152         ${win}.menubar.commands.menu add separator
2153         ${win}.menubar.commands.menu add command -label Stepi \
2154                 -command {interactive_cmd stepi}
2155         ${win}.menubar.commands.menu add command -label Nexti \
2156                 -command {interactive_cmd nexti}
2157
2158         menubutton ${win}.menubar.view -padx 12 -text Options \
2159                 -menu ${win}.menubar.view.menu -underline 0
2160
2161         menu ${win}.menubar.view.menu
2162         ${win}.menubar.view.menu add command -label Hex \
2163                 -command {echo Hex}
2164         ${win}.menubar.view.menu add command -label Decimal \
2165                 -command {echo Decimal}
2166         ${win}.menubar.view.menu add command -label Octal \
2167                 -command {echo Octal}
2168
2169         menubutton ${win}.menubar.window -padx 12 -text Window \
2170                 -menu ${win}.menubar.window.menu -underline 0
2171
2172         menu ${win}.menubar.window.menu
2173         ${win}.menubar.window.menu add command -label Command \
2174                 -command create_command_window
2175         ${win}.menubar.window.menu add separator
2176         ${win}.menubar.window.menu add command -label Source \
2177                 -command create_source_window
2178         ${win}.menubar.window.menu add command -label Assembly \
2179                 -command create_asm_window
2180         ${win}.menubar.window.menu add separator
2181         ${win}.menubar.window.menu add command -label Registers \
2182                 -command create_registers_window
2183         ${win}.menubar.window.menu add command -label Expressions \
2184                 -command create_expr_window
2185         ${win}.menubar.window.menu add command -label "Auto Command" \
2186                 -command create_autocmd_window
2187         ${win}.menubar.window.menu add command -label Breakpoints \
2188                 -command create_breakpoints_window
2189
2190 #       ${win}.menubar.window.menu add separator
2191 #       ${win}.menubar.window.menu add command -label Files \
2192 #               -command { not_implemented_yet "files window" }
2193
2194         menubutton ${win}.menubar.help -padx 12 -text Help \
2195                 -menu ${win}.menubar.help.menu -underline 0
2196
2197         menu ${win}.menubar.help.menu
2198         ${win}.menubar.help.menu add command -label "with GDBtk" \
2199                 -command {echo "with GDBtk"}
2200         ${win}.menubar.help.menu add command -label "with this window" \
2201                 -command {echo "with this window"}
2202         ${win}.menubar.help.menu add command -label "Report bug" \
2203                 -command {exec send-pr}
2204
2205         pack    ${win}.menubar.file \
2206                 ${win}.menubar.view \
2207                 ${win}.menubar.window -side left
2208         pack    ${win}.menubar.help -side right
2209
2210         frame ${win}.info
2211         text ${win}.text -height 25 -width 80 -relief sunken -borderwidth 2 \
2212                 -setgrid true -cursor hand2 -yscrollcommand "${win}.scroll set"
2213
2214         set ${win}.label $label
2215         label ${win}.label -textvariable ${win}.label -borderwidth 2 -relief sunken
2216
2217         scrollbar ${win}.scroll -orient vertical -command "${win}.text yview" \
2218                 -relief sunken
2219
2220         bind $win <Key-Alt_R> do_nothing
2221         bind $win <Key-Alt_L> do_nothing
2222
2223         pack ${win}.label -side bottom -fill x -in ${win}.info
2224         pack ${win}.scroll -side right -fill y -in ${win}.info
2225         pack ${win}.text -side left -expand yes -fill both -in ${win}.info
2226
2227         pack ${win}.menubar -side top -fill x
2228         pack ${win}.info -side top -fill both -expand yes
2229 }
2230
2231 proc create_source_window {} {
2232         global wins
2233         global cfile
2234
2235         if {[winfo exists .src]} {raise .src ; return}
2236
2237         build_framework .src Source "*No file*"
2238
2239 # First, delete all the old view menu entries
2240
2241         .src.menubar.view.menu delete 0 last
2242
2243 # Source file selection
2244         .src.menubar.view.menu add command -label "Select source file" \
2245                 -command files_command
2246
2247 # Line numbers enable/disable menu item
2248         .src.menubar.view.menu add checkbutton -variable line_numbers \
2249                 -label "Line numbers" -onvalue 1 -offvalue 0 -command {
2250                 foreach source [array names wins] {
2251                         if {$source == "Blank"} continue
2252                         destroy $wins($source)
2253                         unset wins($source)
2254                         }
2255                 set cfile Blank
2256                 update_listing [gdb_loc]
2257                 }
2258
2259         frame .src.row1
2260         frame .src.row2
2261
2262         button .src.start -width 6 -text Start -command \
2263                 {interactive_cmd {break main}
2264                  interactive_cmd {enable delete $bpnum}
2265                  interactive_cmd run }
2266         button .src.stop -width 6 -text Stop -fg red -activeforeground red \
2267                 -state disabled -command gdb_stop
2268         button .src.step -width 6 -text Step \
2269                 -command {interactive_cmd step}
2270         button .src.next -width 6 -text Next \
2271                 -command {interactive_cmd next}
2272         button .src.continue -width 6 -text Cont \
2273                 -command {interactive_cmd continue}
2274         button .src.finish -width 6 -text Finish \
2275                 -command {interactive_cmd finish}
2276         button .src.up -width 6 -text Up \
2277                 -command {interactive_cmd up}
2278         button .src.down -width 6 -text Down \
2279                 -command {interactive_cmd down}
2280         button .src.bottom -width 6 -text Bottom \
2281                 -command {interactive_cmd {frame 0}}
2282
2283         pack .src.start .src.step .src.continue .src.up .src.bottom \
2284                 -side left -padx 3 -pady 5 -in .src.row1
2285         pack .src.stop .src.next .src.finish .src.down -side left -padx 3 \
2286                 -pady 5 -in .src.row2
2287
2288         pack .src.row2 .src.row1 -side bottom -anchor w -before .src.info
2289
2290         $wins($cfile) insert 0.0 "  This page intentionally left blank."
2291         $wins($cfile) configure -width 88 -state disabled \
2292                 -yscrollcommand ".src.scroll set"
2293 }
2294
2295 proc update_autocmd {} {
2296         global .autocmd.label
2297         global accumulate_output
2298
2299         catch {gdb_cmd "${.autocmd.label}"} result
2300         if {!$accumulate_output} { .autocmd.text delete 0.0 end }
2301         .autocmd.text insert end $result
2302         .autocmd.text see end
2303 }
2304
2305 proc create_autocmd_window {} {
2306   global .autocmd.label
2307
2308   if {[winfo exists .autocmd]} {raise .autocmd ; return}
2309
2310   build_framework .autocmd "Auto Command" ""
2311
2312   # First, delete all the old view menu entries
2313
2314   .autocmd.menubar.view.menu delete 0 last
2315
2316   # Accumulate output option
2317
2318   .autocmd.menubar.view.menu add checkbutton \
2319     -variable accumulate_output \
2320     -label "Accumulate output" -onvalue 1 -offvalue 0
2321
2322   # Now, create entry widget with label
2323
2324   frame .autocmd.entryframe
2325
2326   entry .autocmd.entry -borderwidth 2 -relief sunken
2327   bind .autocmd.entry <Key-Return> {
2328     set .autocmd.label [.autocmd.entry get]
2329     .autocmd.entry delete 0 end
2330   }
2331
2332   label .autocmd.entrylab -text "Command: "
2333
2334   pack .autocmd.entrylab -in .autocmd.entryframe -side left
2335   pack .autocmd.entry -in .autocmd.entryframe -side left -fill x -expand yes
2336
2337   pack .autocmd.entryframe -side bottom -fill x -before .autocmd.info
2338 }
2339
2340 # Return the longest common prefix in SLIST.  Can be empty string.
2341
2342 proc find_lcp slist {
2343 # Handle trivial cases where list is empty or length 1
2344         if {[llength $slist] <= 1} {return [lindex $slist 0]}
2345
2346         set prefix [lindex $slist 0]
2347         set prefixlast [expr [string length $prefix] - 1]
2348
2349         foreach str [lrange $slist 1 end] {
2350                 set test_str [string range $str 0 $prefixlast]
2351                 while {[string compare $test_str $prefix] != 0} {
2352                         decr prefixlast
2353                         set prefix [string range $prefix 0 $prefixlast]
2354                         set test_str [string range $str 0 $prefixlast]
2355                 }
2356                 if {$prefixlast < 0} break
2357         }
2358         return $prefix
2359 }
2360
2361 # Look through COMPLETIONS to generate the suffix needed to do command
2362 # completion on CMD.
2363
2364 proc find_completion {cmd completions} {
2365 # Get longest common prefix
2366         set lcp [find_lcp $completions]
2367         set cmd_len [string length $cmd]
2368 # Return suffix beyond end of cmd
2369         return [string range $lcp $cmd_len end]
2370 }
2371
2372 proc create_command_window {} {
2373         global command_line
2374         global saw_tab
2375         global gdb_prompt
2376
2377         set saw_tab 0
2378         if {[winfo exists .cmd]} {raise .cmd ; return}
2379
2380         build_framework .cmd Command "* Command Buffer *"
2381
2382         # Put focus on command area.
2383         focus .cmd.text
2384
2385         set command_line {}
2386
2387         gdb_cmd {set language c}
2388         gdb_cmd {set height 0}
2389         gdb_cmd {set width 0}
2390
2391         bind .cmd.text <Control-c> gdb_stop
2392
2393         # Tk uses the Motifism that Delete means delete forward.  I
2394         # hate this, and I'm not gonna take it any more.
2395         set bsBinding [bind Text <BackSpace>]
2396         bind .cmd.text <Delete> "delete_char %W ; $bsBinding; break"
2397         bind .cmd.text <BackSpace> {
2398           if {([%W cget -state] == "disabled")} { break }
2399           delete_char %W
2400         }
2401         bind .cmd.text <Control-u> {
2402           if {([%W cget -state] == "disabled")} { break }
2403           delete_line %W
2404           break
2405         }
2406         bind .cmd.text <Any-Key> {
2407           if {([%W cget -state] == "disabled")} { break }
2408           set saw_tab 0
2409           %W insert end %A
2410           %W see end
2411           append command_line %A
2412           break
2413         }
2414         bind .cmd.text <Key-Return> {
2415           if {([%W cget -state] == "disabled")} { break }
2416           set saw_tab 0
2417           %W insert end \n
2418           interactive_cmd $command_line
2419
2420           # %W see end
2421           # catch "gdb_cmd [list $command_line]" result
2422           # %W insert end $result
2423           set command_line {}
2424           # update_ptr
2425           %W insert end "$gdb_prompt"
2426           %W see end
2427           break
2428         }
2429         bind .cmd.text <Button-2> {
2430           %W insert end [selection get]
2431           %W see end
2432           append command_line [selection get]
2433           break
2434         }
2435         bind .cmd.text <B2-Motion> break
2436         bind .cmd.text <ButtonRelease-2> break
2437         bind .cmd.text <Key-Tab> {
2438           if {([%W cget -state] == "disabled")} { break }
2439           set choices [gdb_cmd "complete $command_line"]
2440           set choices [string trimright $choices \n]
2441           set choices [split $choices \n]
2442
2443           # Just do completion if this is the first tab
2444           if {!$saw_tab} {
2445             set saw_tab 1
2446             set completion [find_completion $command_line $choices]
2447             append command_line $completion
2448             # Here is where the completion is actually done.  If there
2449             # is one match, complete the command and print a space.
2450             # If two or more matches, complete the command and beep.
2451             # If no match, just beep.
2452             switch [llength $choices] {
2453               0 {}
2454               1 {
2455                 %W insert end "$completion "
2456                 append command_line " "
2457                 return
2458               }
2459
2460               default {
2461                 %W insert end $completion
2462               }
2463             }
2464             bell
2465             %W see end
2466           } else {
2467             # User hit another consecutive tab.  List the choices.
2468             # Note that at this point, choices may contain commands
2469             # with spaces.  We have to lop off everything before (and
2470             # including) the last space so that the completion list
2471             # only shows the possibilities for the last token.
2472             set choices [lsort $choices]
2473             if {[regexp ".* " $command_line prefix]} {
2474               regsub -all $prefix $choices {} choices
2475             }
2476             %W insert end "\n[join $choices { }]\n$gdb_prompt$command_line"
2477             %W see end
2478           }
2479           break
2480         }
2481 }
2482
2483 # Trim one character off the command line.  The argument is ignored.
2484
2485 proc delete_char {win} {
2486   global command_line
2487   set tmp [expr [string length $command_line] - 2]
2488   set command_line [string range $command_line 0 $tmp]
2489 }
2490
2491 # FIXME: This should actually check that the first characters of the current
2492 # line  match the gdb prompt, since the user can move the insertion point
2493 # anywhere.  It should also check that the insertion point is in the last
2494 # line of the text widget.
2495
2496 proc delete_line {win} {
2497     global command_line
2498     global gdb_prompt
2499
2500     set tmp [string length $gdb_prompt]
2501     $win delete "insert linestart + $tmp chars" "insert lineend"
2502     $win see insert
2503     set command_line {}
2504 }
2505
2506 #
2507 # fileselect.tcl --
2508 # simple file selector.
2509 #
2510 # Mario Jorge Silva                               msilva@cs.Berkeley.EDU
2511 # University of California Berkeley                 Ph:    +1(510)642-8248
2512 # Computer Science Division, 571 Evans Hall         Fax:   +1(510)642-5775
2513 # Berkeley CA 94720
2514 #
2515 #
2516 # Copyright 1993 Regents of the University of California
2517 # Permission to use, copy, modify, and distribute this
2518 # software and its documentation for any purpose and without
2519 # fee is hereby granted, provided that this copyright
2520 # notice appears in all copies.  The University of California
2521 # makes no representations about the suitability of this
2522 # software for any purpose.  It is provided "as is" without
2523 # express or implied warranty.
2524 #
2525
2526
2527 # names starting with "fileselect" are reserved by this module
2528 # no other names used.
2529 # Hack - FSBox is defined instead of fileselect for backwards compatibility
2530
2531
2532 # this is the proc that creates the file selector box
2533 # purpose - comment string
2534 # defaultName - initial value for name
2535 # cmd - command to eval upon OK
2536 # errorHandler - command to eval upon Cancel
2537 # If neither cmd or errorHandler are specified, the return value
2538 # of the FSBox procedure is the selected file name.
2539
2540 proc FSBox {{purpose "Select file:"} {defaultName ""} {cmd ""} {errorHandler
2541 ""}} {
2542     global fileselect
2543     set w .fileSelect
2544     if {[Exwin_Toplevel $w "Select File" FileSelect]} {
2545         # path independent names for the widgets
2546
2547         set fileselect(list) $w.file.sframe.list
2548         set fileselect(scroll) $w.file.sframe.scroll
2549         set fileselect(direntry) $w.file.f1.direntry
2550         set fileselect(entry) $w.file.f2.entry
2551         set fileselect(ok) $w.but.ok
2552         set fileselect(cancel) $w.but.cancel
2553         set fileselect(msg) $w.label
2554
2555         set fileselect(result) ""       ;# value to return if no callback procedures
2556
2557         # widgets
2558         Widget_Label $w label {top fillx pady 10 padx 20} -anchor w -width 24
2559         Widget_Frame $w file Dialog {left expand fill} -bd 10
2560
2561         Widget_Frame $w.file f1 Exmh {top fillx}
2562         Widget_Label $w.file.f1 label {left} -text "Dir"
2563         Widget_Entry $w.file.f1 direntry {right fillx expand}  -width 30
2564
2565         Widget_Frame $w.file sframe
2566
2567         scrollbar $w.file.sframe.yscroll -relief sunken \
2568                 -command [list $w.file.sframe.list yview]
2569         listbox $w.file.sframe.list -relief sunken \
2570                 -yscroll [list $w.file.sframe.yscroll set] -setgrid 1
2571         pack append $w.file.sframe \
2572                 $w.file.sframe.yscroll {right filly} \
2573                 $w.file.sframe.list {left expand fill}
2574
2575         Widget_Frame $w.file f2 Exmh {top fillx}
2576         Widget_Label $w.file.f2 label {left} -text Name
2577         Widget_Entry $w.file.f2 entry {right fillx expand}
2578
2579         # buttons
2580         $w.but.quit configure -text Cancel \
2581                 -command [list fileselect.cancel.cmd $w]
2582
2583         Widget_AddBut $w.but ok OK \
2584                 [list fileselect.ok.cmd $w $cmd $errorHandler] {left padx 1}
2585
2586         Widget_AddBut $w.but list List \
2587                 [list fileselect.list.cmd $w] {left padx 1}
2588         Widget_CheckBut $w.but listall "List all" fileselect(pattern)
2589         $w.but.listall configure -onvalue "{*,.*}" -offvalue "*" \
2590             -command {fileselect.list.cmd $fileselect(direntry)}
2591         $w.but.listall deselect
2592
2593         # Set up bindings for the browser.
2594         foreach ww [list $w $fileselect(entry)] {
2595             bind $ww <Return> [list $fileselect(ok) invoke]
2596             bind $ww <Control-c> [list $fileselect(cancel) invoke]
2597         }
2598         bind $fileselect(direntry) <Return> [list fileselect.list.cmd %W]
2599         bind $fileselect(direntry) <Tab> [list fileselect.tab.dircmd]
2600         bind $fileselect(entry) <Tab> [list fileselect.tab.filecmd]
2601
2602         $fileselect(list) configure -selectmode single
2603
2604         bind $fileselect(list) <Button-1> {
2605             # puts stderr "button 1 release"
2606             $fileselect(entry) delete 0 end
2607             $fileselect(entry) insert 0 [%W get [%W nearest %y]]
2608         }
2609
2610         bind $fileselect(list) <Key> {
2611             $fileselect(entry) delete 0 end
2612             $fileselect(entry) insert 0 [%W get [%W nearest %y]]
2613         }
2614
2615         bind $fileselect(list) <Double-ButtonPress-1> {
2616             # puts stderr "double button 1"
2617             $fileselect(entry) delete 0 end
2618             $fileselect(entry) insert 0 [%W get [%W nearest %y]]
2619             $fileselect(ok) invoke
2620         }
2621
2622         bind $fileselect(list) <Return> {
2623             $fileselect(entry) delete 0 end
2624             $fileselect(entry) insert 0 [%W get [%W nearest %y]]
2625             $fileselect(ok) invoke
2626         }
2627     }
2628     set fileselect(text) $purpose
2629     $fileselect(msg) configure -text $purpose
2630     $fileselect(entry) delete 0 end
2631     $fileselect(entry) insert 0 [file tail $defaultName]
2632
2633     if {[info exists fileselect(lastDir)] && ![string length $defaultName]} {
2634         set dir $fileselect(lastDir)
2635     } else {
2636         set dir [file dirname $defaultName]
2637     }
2638     set fileselect(pwd) [pwd]
2639     fileselect.cd $dir
2640     $fileselect(direntry) delete 0 end
2641     $fileselect(direntry) insert 0 [pwd]/
2642
2643     $fileselect(list) delete 0 end
2644     $fileselect(list) insert 0 "Big directory:"
2645     $fileselect(list) insert 1 $dir
2646     $fileselect(list) insert 2 "Press Return for Listing"
2647
2648     fileselect.list.cmd $fileselect(direntry) startup
2649
2650     # set kbd focus to entry widget
2651
2652 #    Exwin_ToplevelFocus $w $fileselect(entry)
2653
2654     # Wait for button hits if no callbacks are defined
2655
2656     if {"$cmd" == "" && "$errorHandler" == ""} {
2657         # wait for the box to be destroyed
2658         update idletask
2659         grab $w
2660         tkwait variable fileselect(result)
2661         grab release $w
2662
2663         set path $fileselect(result)
2664         set fileselect(lastDir) [pwd]
2665         fileselect.cd $fileselect(pwd)
2666         return [string trimright [string trim $path] /]
2667     }
2668     fileselect.cd $fileselect(pwd)
2669     return ""
2670 }
2671
2672 proc fileselect.cd { dir } {
2673     global fileselect
2674     if {[catch {cd $dir} err]} {
2675         fileselect.yck $dir
2676         cd
2677     }
2678 }
2679 # auxiliary button procedures
2680
2681 proc fileselect.yck { {tag {}} } {
2682     global fileselect
2683     $fileselect(msg) configure -text "Yck! $tag"
2684 }
2685
2686 proc fileselect.ok {} {
2687     global fileselect
2688     $fileselect(msg) configure -text $fileselect(text)
2689 }
2690
2691 proc fileselect.cancel.cmd {w} {
2692     global fileselect
2693     set fileselect(result) {}
2694     destroy $w
2695 }
2696
2697 proc fileselect.list.cmd {w {state normal}} {
2698     global fileselect
2699     set seldir [$fileselect(direntry) get]
2700     if {[catch {glob $seldir} dir]} {
2701         fileselect.yck "glob failed"
2702         return
2703     }
2704     if {[llength $dir] > 1} {
2705         set dir [file dirname $seldir]
2706         set pat [file tail $seldir]
2707     } else {
2708         set pat $fileselect(pattern)
2709     }
2710     fileselect.ok
2711     update idletasks
2712     if {[file isdirectory $dir]} {
2713         fileselect.getfiles $dir $pat $state
2714         focus $fileselect(entry)
2715     } else {
2716         fileselect.yck "not a dir"
2717     }
2718 }
2719
2720 proc fileselect.ok.cmd {w cmd errorHandler} {
2721     global fileselect
2722     set selname [$fileselect(entry) get]
2723     set seldir [$fileselect(direntry) get]
2724
2725     if {[string match /* $selname]} {
2726         set selected $selname
2727     } else {
2728         if {[string match ~* $selname]} {
2729             set selected $selname
2730         } else {
2731             set selected $seldir/$selname
2732         }
2733     }
2734
2735     # some nasty file names may cause "file isdirectory" to return an error
2736     if {[catch {file isdirectory $selected} isdir]} {
2737         fileselect.yck "isdirectory failed"
2738         return
2739     }
2740     if {[catch {glob $selected} globlist]} {
2741         if {![file isdirectory [file dirname $selected]]} {
2742             fileselect.yck "bad pathname"
2743             return
2744         }
2745         set globlist $selected
2746     }
2747     fileselect.ok
2748     update idletasks
2749
2750     if {[llength $globlist] > 1} {
2751         set dir [file dirname $selected]
2752         set pat [file tail $selected]
2753         fileselect.getfiles $dir $pat
2754         return
2755     } else {
2756         set selected $globlist
2757     }
2758     if {[file isdirectory $selected]} {
2759         fileselect.getfiles $selected $fileselect(pattern)
2760         $fileselect(entry) delete 0 end
2761         return
2762     }
2763
2764     if {$cmd != {}} {
2765         $cmd $selected
2766     } else {
2767         set fileselect(result) $selected
2768     }
2769     destroy $w
2770 }
2771
2772 proc fileselect.getfiles { dir {pat *} {state normal} } {
2773     global fileselect
2774     $fileselect(msg) configure -text Listing...
2775     update idletasks
2776
2777     set currentDir [pwd]
2778     fileselect.cd $dir
2779     if {[catch {set files [lsort [glob -nocomplain $pat]]} err]} {
2780         $fileselect(msg) configure -text $err
2781         $fileselect(list) delete 0 end
2782         update idletasks
2783         return
2784     }
2785     switch -- $state {
2786         normal {
2787             # Normal case - show current directory
2788             $fileselect(direntry) delete 0 end
2789             $fileselect(direntry) insert 0 [pwd]/
2790         }
2791         opt {
2792             # Directory already OK (tab related)
2793         }
2794         newdir {
2795             # Changing directory (tab related)
2796             fileselect.cd $currentDir
2797         }
2798         startup {
2799             # Avoid listing huge directories upon startup.
2800             $fileselect(direntry) delete 0 end
2801             $fileselect(direntry) insert 0 [pwd]/
2802             if {[llength $files] > 32} {
2803                 fileselect.ok
2804                 return
2805             }
2806         }
2807     }
2808
2809     # build a reordered list of the files: directories are displayed first
2810     # and marked with a trailing "/"
2811     if {[string compare $dir /]} {
2812         fileselect.putfiles $files [expr {($pat == "*") ? 1 : 0}]
2813     } else {
2814         fileselect.putfiles $files
2815     }
2816     fileselect.ok
2817 }
2818
2819 proc fileselect.putfiles {files {dotdot 0} } {
2820     global fileselect
2821
2822     $fileselect(list) delete 0 end
2823     if {$dotdot} {
2824         $fileselect(list) insert end "../"
2825     }
2826     foreach i $files {
2827         if {[file isdirectory $i]} {
2828             $fileselect(list) insert end $i/
2829         } else {
2830             $fileselect(list) insert end $i
2831         }
2832     }
2833 }
2834
2835 proc FileExistsDialog { name } {
2836     set w .fileExists
2837     global fileExists
2838     set fileExists(ok) 0
2839     {
2840         message $w.msg -aspect 1000
2841         pack $w.msg -side top -fill both -padx 20 -pady 20
2842         $w.but.quit config -text Cancel -command {FileExistsCancel}
2843         button $w.but.ok -text OK -command {FileExistsOK}
2844         pack $w.but.ok -side left
2845         bind $w.msg <Return> {FileExistsOK}
2846     }
2847     $w.msg config -text "Warning: file exists
2848 $name
2849 OK to overwrite it?"
2850
2851     set fileExists(focus) [focus]
2852     focus $w.msg
2853     grab $w
2854     tkwait variable fileExists(ok)
2855     grab release $w
2856     destroy $w
2857     return $fileExists(ok)
2858 }
2859
2860 proc FileExistsCancel {} {
2861     global fileExists
2862     set fileExists(ok) 0
2863 }
2864
2865 proc FileExistsOK {} {
2866     global fileExists
2867     set fileExists(ok) 1
2868 }
2869
2870 proc fileselect.getfiledir { dir {basedir [pwd]} } {
2871     global fileselect
2872
2873     set path [$fileselect(direntry) get]
2874     set returnList {}
2875
2876     if {$dir != 0} {
2877         if {[string index $path 0] == "~"} {
2878             set path $path/
2879         }
2880     } else {
2881         set path [$fileselect(entry) get]
2882     }
2883     if {[catch {set listFile [glob -nocomplain $path*]}]} {
2884         return  $returnList
2885     }
2886     foreach el $listFile {
2887         if {$dir != 0} {
2888             if {[file isdirectory $el]} {
2889                 lappend returnList [file tail $el]
2890             }
2891         } elseif {![file isdirectory $el]} {
2892             lappend returnList [file tail $el]
2893         }
2894     }
2895
2896     return $returnList
2897 }
2898
2899 proc fileselect.gethead { list } {
2900     set returnHead ""
2901
2902     for {set i 0} {[string length [lindex $list 0]] > $i}\
2903         {incr i; set returnHead $returnHead$thisChar} {
2904             set thisChar [string index [lindex $list 0] $i]
2905             foreach el $list {
2906                 if {[string length $el] < $i} {
2907                     return $returnHead
2908                 }
2909                 if {$thisChar != [string index $el $i]} {
2910                     return $returnHead
2911                 }
2912             }
2913         }
2914     return $returnHead
2915 }
2916
2917 # FIXME this function is a crock.  Can write tilde expanding function
2918 # in terms of glob and quote_glob; do so.
2919 proc fileselect.expand.tilde { } {
2920     global fileselect
2921
2922     set entry [$fileselect(direntry) get]
2923     set dir [string range $entry 1 [string length $entry]]
2924
2925     if {$dir == ""} {
2926         return
2927     }
2928
2929     set listmatch {}
2930
2931     ## look in /etc/passwd
2932     if {[file exists /etc/passwd]} {
2933         if {[catch {set users [exec cat /etc/passwd | sed s/:.*//]} err]} {
2934             puts "Error\#1 $err"
2935             return
2936         }
2937         set list [split $users "\n"]
2938     }
2939     if {[lsearch -exact $list "+"] != -1} {
2940         if {[catch {set users [exec ypcat passwd | sed s/:.*//]} err]} {
2941             puts "Error\#2 $err"
2942             return
2943         }
2944         set list [concat $list [split $users "\n"]]
2945     }
2946     $fileselect(list) delete 0 end
2947     foreach el $list {
2948         if {[string match $dir* $el]} {
2949             lappend listmatch $el
2950             $fileselect(list) insert end $el
2951         }
2952     }
2953     set addings [fileselect.gethead $listmatch]
2954     if {$addings == ""} {
2955         return
2956     }
2957     $fileselect(direntry) delete 0 end
2958     if {[llength $listmatch] == 1} {
2959         $fileselect(direntry) insert 0 [file dirname ~$addings/]
2960         fileselect.getfiles [$fileselect(direntry) get]
2961     } else {
2962         $fileselect(direntry) insert 0 ~$addings
2963     }
2964 }
2965
2966 proc fileselect.tab.dircmd { } {
2967     global fileselect
2968
2969     set dir [$fileselect(direntry) get]
2970     if {$dir == ""} {
2971         $fileselect(direntry) delete 0 end
2972             $fileselect(direntry) insert 0 [pwd]
2973         if {[string compare [pwd] "/"]} {
2974             $fileselect(direntry) insert end /
2975         }
2976         return
2977     }
2978     if {[catch {set tmp [file isdirectory [file dirname $dir]]}]} {
2979         if {[string index $dir 0] == "~"} {
2980             fileselect.expand.tilde
2981         }
2982         return
2983     }
2984     if {!$tmp} {
2985         return
2986     }
2987     set dirFile [fileselect.getfiledir 1 $dir]
2988     if {![llength $dirFile]} {
2989         return
2990     }
2991     if {[llength $dirFile] == 1} {
2992         $fileselect(direntry) delete 0 end
2993         $fileselect(direntry) insert 0 [file dirname $dir]
2994         if {[string compare [file dirname $dir] /]} {
2995             $fileselect(direntry) insert end /[lindex $dirFile 0]/
2996         } else {
2997             $fileselect(direntry) insert end [lindex $dirFile 0]/
2998         }
2999         fileselect.getfiles [$fileselect(direntry) get] \
3000             "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
3001         return
3002     }
3003     set headFile [fileselect.gethead $dirFile]
3004     $fileselect(direntry) delete 0 end
3005     $fileselect(direntry) insert 0 [file dirname $dir]
3006     if {[string compare [file dirname $dir] /]} {
3007         $fileselect(direntry) insert end /$headFile
3008     } else {
3009         $fileselect(direntry) insert end $headFile
3010     }
3011     if {$headFile == "" && [file isdirectory $dir]} {
3012         fileselect.getfiles $dir\
3013             "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
3014     } else {
3015         fileselect.getfiles [file dirname $dir]\
3016             "[file tail [$fileselect(direntry) get]]*" newdir
3017     }
3018 }
3019
3020 proc fileselect.tab.filecmd { } {
3021     global fileselect
3022
3023     set dir [$fileselect(direntry) get]
3024     if {$dir == ""} {
3025         set dir [pwd]
3026     }
3027     if {![file isdirectory $dir]} {
3028         error "dir $dir doesn't exist"
3029     }
3030     set listFile [fileselect.getfiledir 0 $dir]
3031     puts $listFile
3032     if {![llength $listFile]} {
3033         return
3034     }
3035     if {[llength $listFile] == 1} {
3036         $fileselect(entry) delete 0 end
3037         $fileselect(entry) insert 0 [lindex $listFile 0]
3038         return
3039     }
3040     set headFile [fileselect.gethead $listFile]
3041     $fileselect(entry) delete 0 end
3042     $fileselect(entry) insert 0 $headFile
3043     fileselect.getfiles $dir "[$fileselect(entry) get]$fileselect(pattern)" opt
3044 }
3045
3046 proc Exwin_Toplevel { path name {class Dialog} {dismiss yes}} {
3047     global exwin
3048     if {[catch {wm state $path} state]} {
3049         set t [Widget_Toplevel $path $name $class]
3050         if {![info exists exwin(toplevels)]} {
3051             set exwin(toplevels) [option get . exwinPaths {}]
3052         }
3053         set ix [lsearch $exwin(toplevels) $t]
3054         if {$ix < 0} {
3055             lappend exwin(toplevels) $t
3056         }
3057         if {$dismiss == "yes"} {
3058             set f [Widget_Frame $t but Menubar {top fill}]
3059             Widget_AddBut $f quit "Dismiss" [list Exwin_Dismiss $path]
3060         }
3061         return 1
3062     } else {
3063         if {$state != "normal"} {
3064             catch {
3065                 wm geometry $path $exwin(geometry,$path)
3066 #               Exmh_Debug Exwin_Toplevel $path $exwin(geometry,$path)
3067             }
3068             wm deiconify $path
3069         } else {
3070             catch {raise $path}
3071         }
3072         return 0
3073     }
3074 }
3075
3076 proc Exwin_Dismiss { path {geo ok} } {
3077     global exwin
3078     case $geo {
3079         "ok" {
3080             set exwin(geometry,$path) [wm geometry $path]
3081         }
3082         "nosize" {
3083             set exwin(geometry,$path) [string trimleft [wm geometry $path] 0123456789x]
3084         }
3085         default {
3086             catch {unset exwin(geometry,$path)}
3087         }
3088     }
3089     wm withdraw $path
3090 }
3091
3092 proc Widget_Toplevel { path name {class Dialog} {x {}} {y {}} } {
3093     set self [toplevel $path -class $class]
3094     set usergeo [option get $path position Position]
3095     if {$usergeo != {}} {
3096         if {[catch {wm geometry $self $usergeo} err]} {
3097 #           Exmh_Debug Widget_Toplevel $self $usergeo => $err
3098         }
3099     } else {
3100         if {($x != {}) && ($y != {})} {
3101 #           Exmh_Debug Event position $self +$x+$y
3102             wm geometry $self +$x+$y
3103         }
3104     }
3105     wm title $self $name
3106     wm group $self .
3107     return $self
3108 }
3109
3110 proc Widget_Frame {par child {class GDB} {where {top expand fill}} args } {
3111     if {$par == "."} {
3112         set self .$child
3113     } else {
3114         set self $par.$child
3115     }
3116     eval {frame $self -class $class} $args
3117     pack append $par $self $where
3118     return $self
3119 }
3120
3121 proc Widget_AddBut {par but txt cmd {where {right padx 1}} } {
3122     # Create a Packed button.  Return the button pathname
3123     set cmd2 [list button $par.$but -text $txt -command $cmd]
3124     if {[catch $cmd2 t]} {
3125         puts stderr "Widget_AddBut (warning) $t"
3126         eval $cmd2 {-font fixed}
3127     }
3128     pack append $par $par.$but $where
3129     return $par.$but
3130 }
3131
3132 proc Widget_CheckBut {par but txt var {where {right padx 1}} } {
3133     # Create a check button.  Return the button pathname
3134     set cmd [list checkbutton $par.$but -text $txt -variable $var]
3135     if {[catch $cmd t]} {
3136         puts stderr "Widget_CheckBut (warning) $t"
3137         eval $cmd {-font fixed}
3138     }
3139     pack append $par $par.$but $where
3140     return $par.$but
3141 }
3142
3143 proc Widget_Label { frame {name label} {where {left fill}} args} {
3144     set cmd [list label $frame.$name ]
3145     if {[catch [concat $cmd $args] t]} {
3146         puts stderr "Widget_Label (warning) $t"
3147         eval $cmd $args {-font fixed}
3148     }
3149     pack append $frame $frame.$name $where
3150     return $frame.$name
3151 }
3152
3153 proc Widget_Entry { frame {name entry} {where {left fill}} args} {
3154     set cmd [list entry $frame.$name ]
3155     if {[catch [concat $cmd $args] t]} {
3156         puts stderr "Widget_Entry (warning) $t"
3157         eval $cmd $args {-font fixed}
3158     }
3159     pack append $frame $frame.$name $where
3160     return $frame.$name
3161 }
3162
3163 # End of fileselect.tcl.
3164
3165 #
3166 # Create a copyright window and center it on the screen.  Arrange for
3167 # it to disappear when the user clicks it, or after a suitable period
3168 # of time.
3169 #
3170 proc create_copyright_window {} {
3171   toplevel .c
3172   message .c.m -text [gdb_cmd {show version}] -aspect 500 -relief raised
3173   pack .c.m
3174
3175   bind .c.m <1> {destroy .c}
3176   bind .c <Leave> {destroy .c}
3177   # "suitable period" currently means "15 seconds".
3178   after 15000 {
3179     if {[winfo exists .c]} then {
3180       destroy .c
3181     }
3182   }
3183
3184   wm transient .c .
3185   center_window .c
3186 }
3187
3188 # Begin support primarily for debugging the tcl/tk portion of gdbtk.  You can
3189 # start gdbtk, and then issue the command "tk tclsh" and a window will pop up
3190 # giving you direct access to the tcl interpreter.  With this, it is very easy
3191 # to examine the values of global variables, directly invoke routines that are
3192 # part of the gdbtk interface, replace existing proc's with new ones, etc.
3193 # This code was inspired from example 11-3 in Brent Welch's "Practical
3194 # Programming in Tcl and Tk"
3195
3196 set tcl_prompt "tcl> "
3197
3198 # Get the current command that user has typed, from cmdstart to end of text
3199 # widget.  Evaluate it, insert result back into text widget, issue a new
3200 # prompt, update text widget and update command start mark.
3201
3202 proc evaluate_tcl_command { twidget } {
3203     global tcl_prompt
3204
3205     set command [$twidget get cmdstart end]
3206     if [info complete $command] {
3207         set err [catch {uplevel #0 $command} result]
3208         $twidget insert insert \n$result\n
3209         $twidget insert insert $tcl_prompt
3210         $twidget see insert
3211         $twidget mark set cmdstart insert
3212         return
3213     }
3214 }
3215
3216 # Create the evaluation window and set up the keybindings to evaluate the
3217 # last single line entered by the user.  FIXME: allow multiple lines?
3218
3219 proc tclsh {} {
3220     global tcl_prompt
3221
3222     # If another evaluation window already exists, just bring it to the front.
3223     if {[winfo exists .eval]} {raise .eval ; return}
3224
3225     # Create top level frame with scrollbar and text widget.
3226     toplevel .eval
3227     wm title .eval "Tcl Evaluation"
3228     wm iconname .eval "Tcl"
3229     text .eval.text -width 80 -height 20 -setgrid true -cursor hand2 \
3230             -yscrollcommand {.eval.scroll set}
3231     scrollbar .eval.scroll -command {.eval.text yview}
3232     pack .eval.scroll -side right -fill y
3233     pack .eval.text -side left -fill both -expand true
3234
3235     # Insert the tcl_prompt and initialize the cmdstart mark
3236     .eval.text insert insert $tcl_prompt
3237     .eval.text mark set cmdstart insert
3238     .eval.text mark gravity cmdstart left
3239
3240     # Make this window the current one for input.
3241     focus .eval.text
3242
3243     # Keybindings that limit input and evaluate things
3244     bind .eval.text <Return> { evaluate_tcl_command .eval.text ; break }
3245     bind .eval.text <Any-Key> {
3246         if [%W compare insert < cmdstart] {
3247             %W mark set insert end
3248         }
3249     }
3250     bindtags .eval.text {.eval.text Text all}
3251 }
3252
3253 # This proc is executed just prior to falling into the Tk main event loop.
3254 proc gdbtk_tcl_preloop {} {
3255     global gdb_prompt
3256     .cmd.text insert end "$gdb_prompt"
3257     .cmd.text see end
3258     update
3259 }
3260
3261 # FIXME need to handle mono here.  In Tk4 that is more complicated.
3262 set highlight "-background red2 -borderwidth 2 -relief sunken"
3263
3264 # Setup the initial windows
3265 create_source_window
3266 create_command_window
3267
3268 # Make this last so user actually sees it.
3269 create_copyright_window
3270 # Refresh.
3271 update
3272
3273 if {[file exists ~/.gdbtkinit]} {
3274   source ~/.gdbtkinit
3275 }