gdb/gdbtk.tcl

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