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