/home/stan/gdb/src/gdb/gdbtk/library/interface.tcl

Go to the documentation of this file.

# Interface between GDB and Insight.
# Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2008 Red Hat, Inc.
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License (GPL) as published by
# the Free Software Foundation; either version 2 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.


# This variable is reserved for this module.  Ensure it is an array.
global gdbtk_state
set gdbtk_state(busyCount) 0

# *** DEPRECATED: Use GDBEventHandler::breakpoint instead.
# This is run when a breakpoint changes.  The arguments are the
# action, the breakpoint number, and the breakpoint info.
#define_hook gdb_breakpoint_change_hook

# *** DEPRECATED: Use GDBEventHandler::set_variable instead.
# This is run when a `set' command successfully completes in gdb.  The
# first argument is the gdb variable name (as a Tcl list).  The second
# argument is the new value.
#define_hook gdb_set_hook

# ------------------------------------------------------------
#  PROC:  gdbtk_tcl_set_variable - A "set" command was issued
#          in gdb to change an internal variable. Notify
#          gui.
# ------------------------------------------------------------
proc gdbtk_tcl_set_variable {var val} {
  set e [SetVariableEvent \#auto -variable $var -value $val]
  GDBEventHandler::dispatch $e
  delete object $e
}

####################################################################
#                                                                  #
#                        GUI STATE HOOKS                           #
#                                                                  #
####################################################################
# !!!!!   NOTE   !!!!!
# For debugging purposes, please put debug statements at the very
# beginning and ends of all GUI state hooks.

# *** DEPRECATED: Use GDBEventHandler::busy instead.
# GDB_BUSY_HOOK
#   This hook is used to register a callback when the UI should
#   be disabled because the debugger is either busy or talking
#   to the target.
#
#   All callbacks should disable ALL user input which could cause
#   any state changes in either the target or the debugger.
#define_hook gdb_busy_hook

# *** DEPRECATED: Use GDBEventHandler::idle instead.
# GDB_IDLE_HOOK
#   This hook is used to register a callback when the UI should
#   be enabled because the debugger is no longer busy.
#
#   All callbacks should enable user input. These callbacks
#   should also be as fast as possible to avoid any significant
#   time delays when enabling the UI.
define_hook gdb_idle_hook

# *** DEPRECATED: Use GDBEventHandler::update instead.
# GDB_UPDATE_HOOK
#   This hook is used to register a callback to update the widget
#   when debugger state has changed.
#define_hook gdb_update_hook

# GDB_NO_INFERIOR_HOOK
#   This hook is used to register a callback which should be invoked
#   whenever there is no inferior (either at startup time or when
#   an inferior is killed).
#
#   All callbacks should reset their windows to a known, "startup"
#   state.
define_hook gdb_no_inferior_hook

# GDB_DISPLAY_CHANGE_HOOK
# This is run when a display changes.  The arguments are the action,
# the breakpoint number, and (optionally) the value.
define_hook gdb_display_change_hook

# GDB_TRACE_FIND_HOOK
#    This hook is run by the trace find command.  It is used to switch
#    from control to browse mode when the user runs tfind commands...
#
define_hook gdb_trace_find_hook

# ------------------------------------------------------------------
#  gdbtk_tcl_preloop - This function is called after gdb is initialized
#  but before the mainloop is started.  It sets the app name, and
#  opens the first source window.
# ------------------------------------------------------------------

proc gdbtk_tcl_preloop { } {
  global gdb_exe_name gdb_current_directory

  set_baud

  tk appname gdbtk
  # If there was an error loading an executible specified on the command line
  # then we will have called pre_add_symbol, which would set us to busy,
  # but not the corresponding post_add_symbol.  Do this here just in case...
  after idle gdbtk_idle 
  ManagedWin::startup

  if {$gdb_exe_name != ""} {
    # At startup, file_changed_hook is called too late for us, so we
    # must notice the initial session by hand.  If the arguments exist
    # -- if the user used `gdb --args' -- then we want the new
    # arguments and pwd to override what is set in the session.
    set current_args [gdb_get_inferior_args]
    set current_dir $gdb_current_directory
    Session::notice_file_change
    set_baud
    if {[string length $current_args] > 0} {
      gdb_set_inferior_args $current_args
      gdb_cmd "cd $current_dir"
    }
  }
  
  gdbtk_update
}


# ------------------------------------------------------------------
#  PROCEDURE:  gdbtk_busy - Dispatch a busy event
#
#         Use this procedure from within GUI code to indicate that
#         the debugger is busy, either running the inferior or
#         talking to the target.
# ------------------------------------------------------------------
proc gdbtk_busy {} {

  set e [BusyEvent \#auto]
  GDBEventHandler::dispatch $e
  delete object $e

  # Force the screen to update
  update
}

# ------------------------------------------------------------------
#   PROCEDURE:  gdbtk_update - run all update hooks
#
#          Use this procedure to force all widgets to update
#          themselves. This hook is usually run after command
#          that could change target state.
# ------------------------------------------------------------------
proc gdbtk_update {} {

  set e [UpdateEvent \#auto]
  GDBEventHandler::dispatch $e
  delete object $e
  
  # Force the screen to update
  update
}

# ------------------------------------------------------------------
#   PROCEDURE:  gdbtk_update_safe - run all update hooks in a safe way
#
#          Use this procedure to force all widgets to update
#          themselves. This hook is usually run after command
#          that could change target state.
#          Like gdbtk_update but safe to be used in "after idle"
#          which is used in update hooks.
# ------------------------------------------------------------------
proc gdbtk_update_safe {} {
  global gdb_running

  # Fencepost: Do not update if we are running the target
  # We get here because script commands may have changed memory or
  # registers and "after idle" events registered as a consequence
  # If we try to update while the target is running we are doomed.
  if {!$gdb_running} {
    gdbtk_update
  }
}

# ------------------------------------------------------------------
#   PROCEDURE: gdbtk_idle - dispatch IdleEvent
#
#          Use this procedure to free the UI for more user input.
#          This should only be run AFTER all communication with
#          the target has halted, otherwise the risk of two (or
#          more) widgets talking to the target arises.
# ------------------------------------------------------------------
proc gdbtk_idle {} {
  global gdb_running

  # Put the unfiltered hook back in place, just in case
  # somebody swapped it out, and then died before they
  # could replace it.
  gdb_restore_fputs

  set err [catch {run_hooks gdb_idle_hook}]
  if {$err} {
    dbug E "Error running gdb_idle_hook: $::errorInfo"
  }

  set e [IdleEvent \#auto]
  GDBEventHandler::dispatch $e
  delete object $e

  if {!$gdb_running} {
    set err [catch {run_hooks gdb_no_inferior_hook} txt]
    if {$err} { 
      dbug E "no_inferior_hook error: $txt" 
    }
  }

  # Force the screen to update
  update
}

define_hook download_progress_hook

# ------------------------------------------------------------------
#  PROCEDURE:  gdbtk_quit_check - Ask if the user really wants to quit.
# ------------------------------------------------------------------
proc gdbtk_quit_check {} {
  global gdb_downloading gdb_running gdb_exe_name
  
  if {$gdb_downloading} {
    set msg "Downloading to target,\n really close the debugger?"
    if {![gdbtk_tcl_query $msg no]} {
      return 0
    }
  } elseif {$gdb_running} {
    # While we are running the inferior, gdb_cmd is fenceposted and
    # returns immediately. Therefore, we need to ask here. Do we need
    # to stop the target, too?
    set msg "A debugging session is active.\n"
    append msg "Do you still want to close the debugger?"
    if {![gdbtk_tcl_query $msg no]} {
      return 0
    }
  }
  
  return 1
}

# ------------------------------------------------------------------
#  PROCEDURE:  gdbtk_quit - Quit the debugger
#         Call this procedure anywhere the user can request to quit.
#         This procedure will ask all the right questions before
#         exiting.
# ------------------------------------------------------------------
proc gdbtk_quit {} {
  if {[gdbtk_quit_check]} {
    gdbtk_force_quit
  }
}

# ------------------------------------------------------------------
#  PROCEDURE:  gdbtk_force_quit - Quit the debugger immediately
# ------------------------------------------------------------------
proc gdbtk_force_quit {} {
  # If we don't delete source windows, GDB hooks will
  # try to update them as we exit
  foreach win [ManagedWin::find SrcWin] {
    delete object $win
  }
  # Calling gdb_force_quit is probably not necessary here
  # because it should have been called when the source window(s)
  # were deleted, but just in case...
  gdb_force_quit
}

# ------------------------------------------------------------------
#  PROCEDURE:  gdbtk_cleanup - called by GDB immediately
#         before exiting.  Last chance to cleanup!
# ------------------------------------------------------------------
proc gdbtk_cleanup {} {
  global gdb_exe_name

  # Save the session
  if {$gdb_exe_name != ""} {
    Session::save
  }

  # This is a sign that it is too late to be doing updates, etc...
  set ::gdb_shutting_down 1

  # Shutdown the window manager and save all preferences
  # This way a "quit" in the console window will cause
  # preferences to be saved.
  ManagedWin::shutdown
  pref_save
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_query -
# ------------------------------------------------------------------
proc gdbtk_tcl_query {message {default yes}} {
  global gdb_checking_for_exit gdbtk_state gdbtk_platform

  # FIXME We really want a Help button here.  But Tk's brain-damaged
  # modal dialogs won't really allow it.  Should have async dialog
  # here.

  set title "GDB"
  set modal "task"

  # If we are checking whether to exit gdb, we want a system modal
  # box.  Otherwise it may be hidden by some other program, and the
  # user will have no idea what is going on.
  if {[info exists gdb_checking_for_exit] && $gdb_checking_for_exit} {
    set modal "system"
  }
  
  if {$gdbtk_platform(platform) == "windows"} {
    # On Windows, we want to only ask each question once.
    # If we're already asking the question, just wait for the answer
    # to come back.
    set ans [list answer $message]
    set pending [list pending $message]

    if {[info exists gdbtk_state($pending)]} {
      incr gdbtk_state($pending)
    } else {
      set gdbtk_state($pending) 1
      set gdbtk_state($ans) {}

      ide_messageBox [list set gdbtk_state($ans)] -icon warning \
  -default $default -message $message -title $title \
  -type yesno -modal $modal -parent .
    }

    vwait gdbtk_state($ans)
    set r $gdbtk_state($ans)
    if {[incr gdbtk_state($pending) -1] == 0} {
      # Last call waiting for this answer, so clear it.
      unset gdbtk_state($pending)
      unset gdbtk_state($ans)
    }
  } else {
    # On Unix, apparently it doesn't matter how many times we ask a
    # question.
    set r [tk_messageBox -icon warning -default $default \
       -message $message -title $title \
       -type yesno -parent .]
  }

  update idletasks
  return [expr {$r == "yes"}]
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_warning -
# ------------------------------------------------------------------
proc gdbtk_tcl_warning {message} {
  debug "$message"

# ADD a warning message here if the gui must NOT display it
# add the message at the beginning of the switch followed by - 

  switch -regexp $message {
        "Unable to find dynamic linker breakpoint function.*" {return}
  "Internal error.*" { gdbtk_tcl_fputs_error $message }
        "incomplete CFI.*" { gdbtk_tcl_fputs_error $message }
  "RTTI symbol not found for class.*" { gdbtk_tcl_fputs_error $message }
        "DW_AT.*" { gdbtk_tcl_fputs_error $message }
        "unsupported tag.*" { gdbtk_tcl_fputs_error $message }
        default {show_warning $message}
       }
}

# ------------------------------------------------------------------
# PROC: show_warning -
# ------------------------------------------------------------------
proc show_warning {message} {
  global gdbtk_platform

  # FIXME We really want a Help button here.  But Tk's brain-damaged
  # modal dialogs won't really allow it.  Should have async dialog
  # here.
  set title "GDB"
  set modal "task"

# On Windows, we use ide_messageBox which runs the Win32 MessageBox function
# in another thread.  This permits a program which handles IDE requests from
# other programs to not return from the request until the MessageBox completes.
# This is not possible without using another thread, since the MessageBox
# function call will be running its own event loop, and will be higher on the
# stack than the IDE request.
#
# On Unix tk_messageBox runs in the regular Tk event loop, so
# another thread is not required.

 
  if {$gdbtk_platform(platform) == "windows"} {
      ide_messageBox [list set r] -icon warning \
        -default ok -message $message -title $title \
        -type ok -modal $modal -parent .
  } else {
    set r [tk_messageBox -icon warning -default ok \
             -message $message -title $title \
             -type ok -parent .]
  }
} 

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_ignorable_warning -
# ------------------------------------------------------------------
proc gdbtk_tcl_ignorable_warning {class message} {
  catch {ManagedWin::open WarningDlg -center -transient \
     -message [list $message] -ignorable $class}
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_fputs -
# ------------------------------------------------------------------
proc gdbtk_tcl_fputs {message} {
  global gdbtk_state
  # Restore the fputs hook, in case anyone forgot to put it back...
  gdb_restore_fputs

  if {[info exists gdbtk_state(console)] &&   $gdbtk_state(console) != ""} {
    $gdbtk_state(console) insert $message
  }
}

# ------------------------------------------------------------------
# PROC: echo -
# ------------------------------------------------------------------
proc echo {args} {
  gdbtk_tcl_fputs [concat $args]\n
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_fputs_error - write an error message
# ------------------------------------------------------------------
proc gdbtk_tcl_fputs_error {message} {
  if {[info exists ::gdbtk_state(console)] && $::gdbtk_state(console) != ""} {
    $::gdbtk_state(console) insert $message err_tag
    update
  }
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_fputs_log - write a log message
# ------------------------------------------------------------------
proc gdbtk_tcl_fputs_log {message} {
  if {[info exists ::gdbtk_state(console)] && $::gdbtk_state(console) != ""} {
    $::gdbtk_state(console) insert $message log_tag
    update
  }
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_fputs_target - write target output
# ------------------------------------------------------------------
proc gdbtk_tcl_fputs_target {message} {
  if {$::gdbtk_state(console) == ""} {
    ManagedWin::open Console -force
  }
  $::gdbtk_state(console) insert $message target_tag
  update
}


# ------------------------------------------------------------------
# PROC: gdbtk_tcl_fputs_target_err - write target error output
# ------------------------------------------------------------------
proc gdbtk_tcl_fputs_target_err {message} {
  if {$::gdbtk_state(console) == ""} {
    ManagedWin::open Console -force
  }  
  $::gdbtk_state(console) insert $message err_tag
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_flush -
# ------------------------------------------------------------------
proc gdbtk_tcl_flush {} {
  debug [info level 0]
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_start_variable_annotation -
# ------------------------------------------------------------------
proc gdbtk_tcl_start_variable_annotation {valaddr ref_type stor_cl
                                    cum_expr field type_cast} {
  debug [info level 0]
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_end_variable_annotation -
# ------------------------------------------------------------------
proc gdbtk_tcl_end_variable_annotation {} {
  debug [info level 0]
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_breakpoint - A breakpoint was changed -- notify
#                               gui.
# ------------------------------------------------------------------
proc gdbtk_tcl_breakpoint {action bpnum} {
#  debug "BREAKPOINT: $action $bpnum"
  set e [BreakpointEvent \#auto -action $action -number $bpnum]
  GDBEventHandler::dispatch $e
  delete object $e
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_tracepoint - A tracepoint was changed -- notify
#                               gui.
# ------------------------------------------------------------------
proc gdbtk_tcl_tracepoint {action tpnum} {
#  debug "TRACEPOINT: $action $tpnum"
  set e [TracepointEvent \#auto -action $action -number $tpnum]
  GDBEventHandler::dispatch $e
  delete object $e
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_trace_find_hook -
# ------------------------------------------------------------------
proc gdbtk_tcl_trace_find_hook {arg from_tty} {
#  debug "$arg $from_tty"
  run_hooks gdb_trace_find_hook $arg $from_tty
}

################################################################
#
# Handle `readline' interface.
#

# Run a command that is known to use the "readline" interface.  We set
# up the appropriate buffer, and then run the actual command via
# gdb_cmd.  Calls into the "readline" callbacks just return values
# from our list.

# ------------------------------------------------------------------
# PROC: gdb_run_readline_command -
# ------------------------------------------------------------------
proc gdb_run_readline_command {command args} {
  global gdbtk_state
  debug "$command $args"
  set gdbtk_state(readlineArgs) $args
  set gdbtk_state(readlineShowUser) 1
  gdb_cmd $command
}

# ------------------------------------------------------------------
# PROC: gdb_run_readline_command_no_output
# Run a readline command, but don't show the commands to the user.
# ------------------------------------------------------------------
proc gdb_run_readline_command_no_output {command args} {
  global gdbtk_state
  debug "$command $args"
  set gdbtk_state(readlineArgs) $args
  set gdbtk_state(readlineShowUser) 0
  gdb_cmd $command
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_readline_begin -
# ------------------------------------------------------------------
proc gdbtk_tcl_readline_begin {message} {
  global gdbtk_state
#  debug
  set gdbtk_state(readline) 0
  if {$gdbtk_state(console) != "" && $gdbtk_state(readlineShowUser)} {
    $gdbtk_state(console) insert $message
  }
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_readline -
# ------------------------------------------------------------------
proc gdbtk_tcl_readline {prompt} {
  global gdbtk_state
#  debug "prompt=$prompt"
  if {[info exists gdbtk_state(readlineArgs)]} {
    # Not interactive, so pop the list, and print element.
    set cmd [lvarpop gdbtk_state(readlineArgs)]
    if {$gdbtk_state(console) != "" && $gdbtk_state(readlineShowUser)} {
      $gdbtk_state(console) insert $cmd
    }
  } else {
    # Interactive.
#    debug "interactive"
    set gdbtk_state(readline) 1
    $gdbtk_state(console) activate $prompt
    vwait gdbtk_state(readline_response)
    set cmd $gdbtk_state(readline_response)
#    debug "got response: $cmd"
    unset gdbtk_state(readline_response)
    set gdbtk_state(readline) 0
  }
  return $cmd
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_readline_end -
# ------------------------------------------------------------------
proc gdbtk_tcl_readline_end {} {
  global gdbtk_state
#  debug
  catch {unset gdbtk_state(readlineArgs)}
  catch {unset gdbtk_state(readlineActive)}
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_busy - this is called immediately before gdb 
#    executes a command.
#
# ------------------------------------------------------------------
proc gdbtk_tcl_busy {} {
  global gdbtk_state
  if {[incr gdbtk_state(busyCount)] == 1} {
    gdbtk_busy
  }
}

################################################################
#
# 
#

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_idle - this is called immediately after gdb 
#    executes a command.
# ------------------------------------------------------------------
proc gdbtk_tcl_idle {} {
  global gdbtk_state
  if {$gdbtk_state(busyCount) > 0
      && [incr gdbtk_state(busyCount) -1] == 0} {
    gdbtk_update
    gdbtk_idle
  }
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_tstart -
# ------------------------------------------------------------------
proc gdbtk_tcl_tstart {} {
  set srcwin [lindex [manage find src] 0]
  $srcwin.toolbar do_tstop 0
  
}

# ------------------------------------------------------------------
# PROC: gdbtk_tcl_tstop -
# ------------------------------------------------------------------
proc gdbtk_tcl_tstop {} {
  set srcwin [lindex [manage find src] 0]
  $srcwin.toolbar do_tstop 0
  
}


# ------------------------------------------------------------------
# PROC: gdbtk_tcl_display -
#
# A display changed.  ACTION is `enable', `disable', `delete',
# `create', or `update'.  VALUE is only meaningful in the `update'
# case.
# ------------------------------------------------------------------
proc gdbtk_tcl_display {action number {value {}}} {
  # Handle create explicitly.
  if {$action == "create"} {
    manage create_if_never data
  }
  run_hooks gdb_display_change_hook $action $number $value
}

# ------------------------------------------------------------------
#  PROCEDURE: gdbtk_register_changed
#         This hook is called from value_assign to inform us that
#         the user has changed the contents of a register.
# ------------------------------------------------------------------
proc gdbtk_register_changed {} {
  after idle gdbtk_update_safe
}

# ------------------------------------------------------------------
#  PROCEDURE: gdbtk_memory_changed
#         This hook is called from value_assign to inform us that
#         the user has changed the contents of memory (including
#         the program's variables).
# ------------------------------------------------------------------
proc gdbtk_memory_changed {} {
  after idle gdbtk_update_safe
}

####################################################################
#                                                                  #
#                           FILE HOOKS                             #
#                                                                  #
#    There are a number of hooks that are installed in gdb to      #
#    aid with file-like commands (selecting an exectuable and      #
#    loading symbols):                                             #
#         - exec_file_display_hook                                 #
#            Called in exec_file_command. The tcl hook is          #
#            "gdbtk_tcl_exec_file_display"                         #
#         - file_changed_hook                                      #
#            Called in file_command. The tcl hook is               #
#            "gdbtk_tcl_file_changed"                              #
#         - deprecated_pre_add_symbol_hook                         #
#            Called in symbol_file_add before loading. The tcl     #
#            hook is "gdbtk_tcl_pre_add_symbol"                    #
#         - deprecated_post_add_symbol_hook                        #
#            Called in symbol_file_add when finished loading       #
#            a symbol file. The tcl hook is                        #
#            "gdbtk_tcl_post_add_symbol"                           #
#                                                                  #
#  Together, these hooks should give the gui enough information    #
#  to cover the two most common uses of file commands:             #
#  1. executable with symbols                                      #
#  2. separate executable and symbol file(s)                       #
#                                                                  #
####################################################################
define_hook file_changed_hook

# ------------------------------------------------------------------
#  PROCEDURE:  gdbtk_tcl_pre_add_symbol
#         This hook is called before any symbol files
#         are loaded so that we can inform the user.
# ------------------------------------------------------------------
proc gdbtk_tcl_pre_add_symbol {file} {

  gdbtk_busy

  # Display some feedback to the user
  set srcs [ManagedWin::find SrcWin]
  foreach w $srcs {
    $w set_status "Reading symbols from $file..."
  }
  update idletasks
}

# ------------------------------------------------------------------
#   PROCEDURE: gdbtk_tcl_post_add_symbol
#          This hook is called after we finish reading a symbol
#          file, so the source windows' combo boxes need filling.
# ------------------------------------------------------------------
proc gdbtk_tcl_post_add_symbol {} {

  set srcs [ManagedWin::find SrcWin]
  foreach w $srcs {
    $w fillNameCB
  }
  gdbtk_idle
}

# ------------------------------------------------------------------
#  PROCEDURE: gdbtk_tcl_file_changed
#         This hook is called whenever the exec file changes.
#         This is called AFTER symbol reading, so it is
#         ok to point to main when we get called.
# ------------------------------------------------------------------
proc gdbtk_tcl_file_changed {filename} {

  if {$filename == ""} {
    gdb_clear_file
    catch {run_hooks gdb_clear_file_hook}
    set ::gdb_exe_name ""
    set ::gdb_loaded 0
    set ::gdb_running 0
    gdbtk_update
  } else {
    SrcWin::point_to_main
    run_hooks file_changed_hook
  }
}

# ------------------------------------------------------------------
#  PROCEDURE: gdbtk_tcl_exec_file_display 
#         This hook is called from exec_file_command. It's purpose
#         is to setup the gui for a new file. Note that we cannot
#         look for main, since this hook is called BEFORE we
#         read symbols. If the user used the "file" command,
#         gdbtk_tcl_file_changed will set the source window to
#         look at main. If the user used "exec-file" and "add-symbol"
#         commands, then we cannot look for main.
# ------------------------------------------------------------------
proc gdbtk_tcl_exec_file_display {filename} {
  global gdb_exe_changed

  # DO NOT CALL set_exe here! 

  # Clear out the GUI, don't do it if filename is "" so that
  # you avoid distracting flashes in the source window.

  if {$filename != ""} {
    gdbtk_clear_file
  }

  # set_exe calls file command with the filename in
  # quotes, so we need to strip them here.
  # We need to make sure that we turn filename into
  # an absolute path or sessions won't work.
  if {[file tail $filename] == $filename} {
    # want full pathname
    set filename [file join $::gdb_current_directory $filename]
  }
  set_exe_name $filename
  set gdb_exe_changed 0

  SrcWin::point_to_main
}

# ------------------------------------------------------------------
#  PROCEDURE: gdbtk_locate_main 
#         This proc tries to locate a suitable main function from
#         a list of names defined in the gdb/main_names preference; 
#         returns the linespec (see below) if found, or a null string
#         if not.
#
#  The return linespec looks like this:
#  0: basename of the file
#  1: function name
#  2: full filename
#  3: source line number
#  4: address
#  5: current PC - which will often be the same as address, but not when
#  we are browsing, or walking the stack.
#  6: shared library name if the pc is in a shared lib
#
# ------------------------------------------------------------------
proc gdbtk_locate_main {{init ""}} {
  global _main_cache gdb_exe_name
  debug

  if {$init == "" && $_main_cache != ""} {
    #debug "returning $_main_cache from cache"
    return $_main_cache
  }
  set _main_cache {}

  set main_names [pref get gdb/main_names]
  foreach main $main_names {
    if {![catch {gdb_loc $main} linespec]} {
      set _main_cache $linespec
      break
    }
  }
  if {$_main_cache == {} 
      && ![catch gdb_entry_point entry_point]
      && ![catch {gdb_loc "*$entry_point"} linespec]} {
    set _main_cache $linespec
  }
  
  # need to see if result is valid
  lassign $_main_cache file func ffile line addr rest
  if {$addr == 0x0 && $func == {}} { set _main_cache {} }

  #debug "returning $_main_cache"
  return $_main_cache
}

##############################################
#  The rest of this file is an assortment of Tcl wrappers
#  for various bits of gdb functionality.
#
#############################################

# ------------------------------------------------------------------
# PROC: set_exe_name - Update the executable name
# ------------------------------------------------------------------
proc set_exe_name {exe} {
  global gdb_exe_name gdb_exe_changed
  #debug "exe=$exe  gdb_exe_name=$gdb_exe_name"

  set gdb_exe_name $exe
  set gdb_exe_changed 1    
}


# ------------------------------------------------------------------
# PROC: set_exe -
# ------------------------------------------------------------------ 
proc set_exe {} {
  global gdb_exe_name gdb_exe_changed gdb_target_changed gdb_loaded file_done
#  debug "gdb_exe_changed=$gdb_exe_changed gdb_exe_name=$gdb_exe_name"
  if {$gdb_exe_changed} {
    set gdb_exe_changed 0
    if {$gdb_exe_name == ""} { return }
    set err [catch {gdb_cmd "file '$gdb_exe_name'" 1} msg]
    if {$err} {
      dbug E "$msg"
      set l [split $msg :]
      set errtxt [join [lrange $l 1 end] :]
      set msg "Error loading \"$gdb_exe_name\":\n"
      append msg $errtxt
      tk_messageBox -title "Error" -message $msg -icon error \
  -type ok
      set gdb_exe_name {}
      set file_done 0
      return
    } elseif {[string match {*no debugging symbols found*} $msg]} {
      tk_messageBox -icon error -default ok \
  -title "GDB" -type ok \
  -message "This executable has no debugging information."
    }

    # force new target command
    set gdb_target_changed 1
    set gdb_loaded 0
    set file_done 1
  }
}

# ------------------------------------------------------------------
#  _open_file - open a file dialog to select a file for debugging.
#  If filename is not "", then open this file.
# ------------------------------------------------------------------

proc _open_file {{file ""}} {
  global gdb_running gdb_downloading gdbtk_platform
  
  if {$gdb_running || $gdb_downloading} {
    # We are already running/downloading something..
    if {$gdb_running} {
      set msg "A debugging session is active.\nAbort session and load new file?"
    } else {
      set msg "A download is in progress.\nAbort download and load new file?"
    }
    if {![gdbtk_tcl_query $msg no]} {
      return 0
    }
  }

  if {[string compare $file ""] == 0} {
    set curFocus [focus]
    
    # Make sure that this is really a modal dialog...
    # FIXME: Add a disable_all to ide_grab_support.
    
    ide_grab_support disable_except {}
    
    set file [tk_getOpenFile -parent . -title "Load New Executable"]
  
    ide_grab_support enable_all
    
    # If no one had the focus before, leave it that way (since I
    # am not sure how this could happen...  Also, the vwait in 
    # tk_getOpenFile could have allowed the curFocus window to actually
    # be destroyed, so make sure it is still around.
    
    if {$curFocus != "" && [winfo exists $curFocus]} {
      raise [winfo toplevel $curFocus]
      focus $curFocus
    }
  } elseif {![file exists $file]} {
    tk_messageBox -message "File \"$file\" does not exist"
    return 0
  }
    

  if {$file == ""} {
    return 0
  }
  # Add the base dir for this file to the source search path.
  set root [file dirname $file]
  if {$gdbtk_platform(os) == "cygwin"} {
    set root [ide_cygwin_path to_posix $root]
    set file [ide_cygwin_path to_posix $file]
  }
  
  catch {gdb_cmd "cd $root"}

  # Clear out gdb's internal state, so that it will allow us
  # (the gui) to ask the user questions.
  gdb_clear_file

  # The gui needs to set this...
  set_exe_name $file
  
  # set_exe needs to be called anywhere the gui does a file_command...
  if {[set_exe] == "cancel"} {
    gdbtk_update
    gdbtk_idle
    return 0
  }

  return 1
}

# ------------------------------------------------------------------
#  _close_file - close the current executable and prepare for
#    another executable.
# ------------------------------------------------------------------
proc _close_file {} {

  # If there is already an inferior, ask him if he wants to close
  # the file. If there is already an exec file loaded (and not run)
  # also ask, but don't ask twice.
  set okay 1
  if {[gdb_target_has_execution]} {
    set okay [gdbtk_tcl_query "Program is already running.\nClose file anyway?"]
  } elseif {$::gdb_exe_name != ""} {
    set okay [gdbtk_tcl_query "Program already loaded.\nClose file anyway?"]
  } else {
    # No exec file yet
    return
  }

  if {$okay} {
    Session::save
    gdb_clear_file
    gdbtk_tcl_file_changed ""

    # Print out a little message to all console windows
    foreach cw [ManagedWin::find Console] {
      $cw insert "No executable file now.\n"
    }
  }
}

# ------------------------------------------------------------------
# PROC: set_target_name - Update the target name.  
#
# This function will prompt for a new target and update
# all variables.
#
# If $prompt is 0 it will just update gdb_target_cmd from gdb_target.
#
# RETURN:
#     1 if successful, 
#     0 if the not (the user canceled the target selection dialog)
# ------------------------------------------------------------------
proc set_target_name {{prompt 1}} {
  global gdb_target_name gdb_target_changed gdb_exe_changed
  global gdb_target_cmd gdb_pretty_name
#  debug
  set cmd_tmp $gdb_target_cmd
  set name_tmp $gdb_target_name

#  debug "gdb_target_name=$gdb_target_name; name_tmp=$name_tmp"
  if {$prompt} {
    set win [ManagedWin::open TargetSelection -exportcancel 1 -center \
         -transient]
    # need to call update here so the target selection dialog can take over
    update idletasks
  }

#  debug "gdb_target_name=$gdb_target_name"
  if {$gdb_target_name == "CANCEL"} {
    set gdb_target_cmd $cmd_tmp
    set gdb_target_name $name_tmp
    return 0
  }
  set target $gdb_target_name
  set targ [TargetSelection::getname $target cmd]
  set gdb_target_cmd $cmd_tmp
  set gdb_pretty_name [TargetSelection::getname $target pretty-name]

#  debug "target=$target pretty_name=$gdb_pretty_name"
  set targ_opts ""
  switch -regexp -- $gdb_target_name {
    sim|ice {
      set targ $gdb_target_name
      set targ_opts [pref getd gdb/load/${gdb_target_name}-opts]
    }
    default {
      set port [pref getd gdb/load/$target-port]
      if {$port == ""} {
  set port [pref get gdb/load/default-port]
      }
      set portnum [pref getd gdb/load/$target-portname]
      if {$portnum == ""} {
  set portnum [pref get gdb/load/default-portname]
      }
      set hostname [pref getd gdb/load/$target-hostname]
      if {$hostname == ""} {
  set hostname [pref getd gdb/load/default-hostname]
      }
      # replace "com1" with the real port name
      set targ [lrep $targ "com1" $port]
      # replace "tcpX" with hostname:portnum
      set targ [lrep $targ "tcpX" ${hostname}:${portnum}]
      # replace "ethX" with hostname
      set targ [lrep $targ "ethX" e=${hostname}]
    }
  }
  
#  debug "targ=$targ gdb_target_cmd=$gdb_target_cmd"
  if {$gdb_target_cmd != $targ || $gdb_target_changed} {
    set gdb_target_changed 1
    set gdb_target_cmd "$targ $targ_opts"
  }
  return 1
}

# ------------------------------------------------------------------
# PROC: set_target - Change the target
# ------------------------------------------------------------------
proc set_target {} {
  global gdb_target_cmd gdb_target_changed gdb_pretty_name gdb_target_name
  #debug "gdb_target_changed=$gdb_target_changed gdb_target_cmd=\"$gdb_target_cmd\""
  #debug "gdb_target_name=$gdb_target_name"
  if {$gdb_target_cmd == "" && ![TargetSelection::native_debugging]} {
    if {$gdb_target_name == ""} {
      set prompt 1

      # get the default
      #set gdb_target_name [pref getd gdb/load/target]
    } else {
      set prompt 0
    }
    if {![set_target_name $prompt]} {
      set gdb_target_name ""
      return CANCELED
    }
  }
  
  if {$gdb_target_changed} {
    set srcWin [lindex [ManagedWin::find SrcWin] 0]

    $srcWin set_status "Trying to communicate with target $gdb_pretty_name" 1
    update
    catch {gdb_cmd "detach"}
    debug "CONNECTING TO TARGET: $gdb_target_cmd"
    gdbtk_busy
    set err [catch {gdb_immediate "target $gdb_target_cmd"} msg ]
    $srcWin set_status
    gdbtk_idle

    if {$err} {
      if {[string first "Program not killed" $msg] != -1} {
  return CANCELED
      }
      update
      set dialog_title "GDB"
      set debugger_name "GDB"
      tk_messageBox -icon error -title $dialog_title -type ok \
  -message "$msg\n\n$debugger_name cannot connect to the target board\
using [lindex $gdb_target_cmd 1].\nVerify that the board is securely connected and, if\
necessary,\nmodify the port setting with the debugger preferences."
      return ERROR
    }
    
    if {![catch {pref get gdb/load/$gdb_target_name-after_attaching} aa] && $aa != ""} {
      if {[catch {gdb_cmd $aa} err]} {
  catch {[ManagedWin::find Console] insert $err err_tag}
      }
    }
    set gdb_target_changed 0
    return TARGET_CHANGED
  }
  return TARGET_UNCHANGED
}

# ------------------------------------------------------------------
# PROC: run_executable -
#
# This procedure is used to run an executable.  It is called when the 
# run button is used.
# ------------------------------------------------------------------
proc run_executable { {auto_start 1} } {
  global gdb_loaded gdb_downloading gdb_target_name
  global gdb_exe_changed gdb_target_changed gdb_program_has_run
  global gdb_running gdb_exe_name gdbtk_platform

#  debug "auto_start=$auto_start gdb_target_name=$gdb_target_name"

  set gdb_running_saved $gdb_running
  set gdb_running 0

  # No executable was specified.  Prompt the user for one.
  if {$gdb_exe_name == ""} {
    if {[_open_file]} {
      run_executable $auto_start
      return
    } else {
      # The user canceled the load of a new executable.
      return
    }
  }

  if {$gdb_downloading} { return }
  if {[pref get gdb/control_target]} {
    # Breakpoint mode
    set_exe

    # Attach
    if {$gdb_target_name == "" || [pref get gdb/src/run_attach]} {
      set r [gdbtk_attach_remote]
      if {$r == "ATTACH_CANCELED" || $r == "ATTACH_ERROR"} {
  return
      }
    }

    # Download
    if {[pref get gdb/src/run_load] && $gdb_target_name != "exec"} {
      debug "Downloading..."
      set gdb_loaded 0
      
      # if the app has not been downloaded or the app has already
      # started, we need to redownload before running
      if {!$gdb_loaded} {
  if {[Download::download_it]} {
    # user cancelled the command
#   debug "user cancelled the command $gdb_running"
    set gdb_loaded 0
    gdbtk_update
    gdbtk_idle
  }
  if {!$gdb_loaded} {
    # The user cancelled the download after it started
#   debug "User cancelled the download after it started $gdb_running"
    gdbtk_update
    gdbtk_idle
    return
  }
      }
    }

    # _Now_ set/clear breakpoints
    if {[pref get gdb/load/exit] && ![TargetSelection::native_debugging]} {
      debug "Setting new BP at exit"
      catch {gdb_cmd "clear exit"}
      catch {gdb_cmd "break exit"}
    }
      
    if {[pref get gdb/load/main]} {
      set main "main"
      if {[set linespec [gdbtk_locate_main]] != ""} {
        set main [lindex $linespec 1]
      }
      debug "Setting new BP at $main"
      catch {gdb_cmd "clear $main"}
      catch {gdb_cmd "break $main"}
    }

    # set BP at user-specified function
    if {[pref get gdb/load/bp_at_func]} {
      foreach bp [pref get gdb/load/bp_func] {
  debug "Setting BP at $bp"
  catch {gdb_cmd "clear $bp"}
  catch {gdb_cmd "break $bp"}
      }
    }

    # This is a hack.  If the target is "sim" the opts are appended
    # to the target command. Otherwise they are assumed to be command line
    # args.  What about simulators that accept command line args?
    if {$gdb_target_name != "sim"} {
      # set args
      set gdb_args [pref getd gdb/load/$gdb_target_name-opts]
      if { $gdb_args != ""} {
  debug "set args $gdb_args"
  gdb_set_inferior_args $gdb_args
      }
    }

    # If the user requested it, start an xterm for use as the
    # inferior's tty.
    if {$gdbtk_platform(platform) != "windows"
  && [pref getd gdb/process/xtermtty] == "yes"} {
      tty::create
    }

    # 
    # Run

    if {$auto_start} {
      if {[pref get gdb/src/run_run]} {
  debug "Runnning target..."
  set run run
      } else {
  debug "Continuing target..."
  set run cont
      }
      if {$gdb_target_name == "exec"} {
  set run run
      }
      if {[catch {gdb_immediate $run} msg]} {
  dbug W "msg=$msg"
  gdbtk_idle
  if {[string match "*help target*" $msg]} {
    set_target_name
    run_executable $auto_start
    return
  }
  if {[string match "No executable*" $msg]} {
    # No executable was specified.  Prompt the user for one.
    if {[_open_file]} {
      run_executable $auto_start
    } else {
      debug "CANCELLED"
    }
    return
  }
  set gdb_running $gdb_running_saved
      } else {
  debug RUNNING
  set gdb_running 1
      }
    } else {
      SrcWin::point_to_main
    }
    
    gdbtk_update
    gdbtk_idle
  } elseif {[pref get gdb/mode]} {
    # tracepoint -- need to tstart
    set gdb_running 1
    tstart
  }
  return
}

# ------------------------------------------------------------------
#  PROC: gdbtk_attach_remote - attach to the target
#        This proc returns the following status messages:
#
#        ATTACH_ERROR: An error occurred connecting to target.
#        ATTACH_CANCELED: The attach was canceled.
#        ATTACH_TARGET_CHANGED: Successfully attached, target changed.
#        ATTACH_TARGET_UNCHANGED: Successfully attached, target unchanged.
#        UNKNOWN: An unknown error occurred.
# ------------------------------------------------------------------
proc gdbtk_attach_remote {} {
  global gdb_loaded

  debug "Attaching...."
  set r UNKNOWN
  while {1} {

    switch [set_target] {

      ERROR {
  # target command failed, ask for a new target name
  if {![set_target_name]} {
    # canceled again
    set r ATTACH_ERROR
    break
  }
      }

      TARGET_CHANGED {
  # success -- target changed
  set gdb_loaded 0
  set r ATTACH_TARGET_CHANGED
  break
      }

      CANCELED {
  # command cancelled by user
  set r ATTACH_CANCELED
  break
      }

      TARGET_UNCHANGED {
  # success -- target NOT changed (i.e., rerun)
  set r ATTACH_TARGET_UNCHANGED
  break
      }
    }
  }

#  debug "Attach returning: \"$r\""
  return $r
}

# ------------------------------------------------------------------
# PROC:  gdbtk_connect: connect to a remote target 
#                      in asynch mode if async is 1
# ------------------------------------------------------------------
proc gdbtk_connect {{async 0}} {
  global file_done

  debug "async=$async"

  gdbtk_busy

  set result [gdbtk_attach_remote]
  switch $result {
    ATTACH_ERROR {
      set successful 0
    }

    ATTACH_TARGET_CHANGED {
  if {[pref get gdb/load/check] && $file_done} {
    set err [catch {gdb_cmd "compare-sections"} errTxt]
    if {$err} {
      set successful 0
      tk_messageBox -title "Error" -message $errTxt \
        -icon error -type ok
      break
    }
  }

  tk_messageBox -title "GDB" -message "Successfully connected" \
    -icon info -type ok
  set successful 1
    }

    ATTACH_CANCELED {
  tk_messageBox -title "GDB" -message "Connection Canceled" -icon info \
    -type ok
  set successful 0
    }

    ATTACH_TARGET_UNCHANGED {
  tk_messageBox -title "GDB" -message "Successfully connected" \
    -icon info -type ok
  set successful 1
    }

    default {
  dbug E "Unhandled response from gdbtk_attach_remote: \"$result\""
  set successful 0
    }
  }

  gdbtk_idle

  # Whenever we attach, we need to do an update
  if {$successful} {
    gdbtk_attached
  }
  return $successful
}

# ------------------------------------------------------------------
#  PROC: gdbtk_step - step the target
# ------------------------------------------------------------------
proc gdbtk_step {} {
  catch {gdb_immediate step}
}

# ------------------------------------------------------------------
#  PROC: gdbtk_next
# ------------------------------------------------------------------
proc gdbtk_next {} {
  catch {gdb_immediate next}
}

# ------------------------------------------------------------------
#  PROC: gdbtk_finish
# ------------------------------------------------------------------
proc gdbtk_finish {} {
  catch {gdb_immediate finish}
}

# ------------------------------------------------------------------
#  PROC: gdbtk_continue
# ------------------------------------------------------------------
proc gdbtk_continue {} {
  catch {gdb_immediate continue}
}

# ------------------------------------------------------------------
#  PROC: gdbtk_stepi
# ------------------------------------------------------------------
proc gdbtk_stepi {} {
  catch {gdb_immediate stepi}
}

# ------------------------------------------------------------------
#  PROC: gdbtk_nexti
# ------------------------------------------------------------------
proc gdbtk_nexti {} {
  catch {gdb_immediate nexti}
}

# ------------------------------------------------------------------
#  PROC: gdbtk_attached
# ------------------------------------------------------------------
#
# This is called AFTER gdb has successfully done an attach.  Use it to 
# bring the GUI up to a current state...
proc gdbtk_attached {} {
  gdbtk_update
}

# ------------------------------------------------------------------
#  PROC: gdbtk_detached
# ------------------------------------------------------------------
#
# This is called AFTER gdb has successfully done an detach.  Use it to 
# bring the GUI up to a current state...
proc gdbtk_detached {} {
  if {!$::gdb_shutting_down} {
    run_hooks gdb_no_inferior_hook
  }
}

# ------------------------------------------------------------------
#  PROC: gdbtk_stop
# ------------------------------------------------------------------
#
# The stop button is tricky. In order to use the stop button,
# the debugger must be able to keep gui alive while target_wait is
# blocking (so that the user can interrupt or detach from it).
# 
# The best solution for this is to capture gdb deep down where it can
# block. For _any_ target board, this will be in either serial or
# socket code. These places call deprecated_ui_loop_hook to keep us
# alive. For native unix, we use an interval timer.  Simulators either
# call deprecated_ui_loop_hook directly (older sims, at least) or they
# call gdb's os_poll_quit callback, where we insert a call to
# deprecated_ui_loop_hook. Some targets (like v850ice and windows
# native) require a call to deprecated_ui_loop_hook directly in
# target_wait. See comments before gdb_stop and x_event to find out
# more about how this is accomplished.
#
# The stop button's behavior:
# Pressing the stop button should attempt to stop the target. If, after
# some time (like 3 seconds), gdb fails to fall out of target_wait (i.e.,
# the gui's idle hooks are run), then open a dialog asking the user if
# he'd like to detach.
proc gdbtk_stop {} {
  global _gdbtk_stop

  if {$_gdbtk_stop(timer) == ""} {
    add_hook gdb_idle_hook gdbtk_stop_idle_callback
    set _gdbtk_stop(timer) [after 15000 gdbtk_detach]
    catch {gdb_stop}
  }
}

# ------------------------------------------------------------------
#  PROC: gdbtk_stop_idle_callback
# ------------------------------------------------------------------
# This callback normally does nothing. When the stop button has
# been pressed, though, and gdb has successfully stopped the target,
# this callback will clean up after gdbtk_stop, removing the "Detach"
# dialog (if it's open) and gettingg rid of any outstanding timers
# and hooks.
proc gdbtk_stop_idle_callback {} {
  global _gdbtk_stop gdbtk_state

  # Check if the dialog asking if user wants to detach is open
  # and unpost it if it exists.
  if {$_gdbtk_stop(msg) != ""} {
    set ans [list answer $_gdbtk_stop(msg)]
    set gdbtk_state($ans) no
  }

  if {$_gdbtk_stop(timer) != ""} {
    # Cancel the timer callback
    after cancel $_gdbtk_stop(timer)
    set _gdbtk_stop(timer) ""
    catch {remove_hook gdb_idle_hook gdbtk_stop_idle_callback}
  }
}

# ------------------------------------------------------------------
#  PROC: gdbtk_detach
# ------------------------------------------------------------------
# This proc is installed as a timer event when the stop button
# is pressed. If target_wait doesn't return (we were unable to stop
# the target), then this proc is called.
#
# Open a dialog box asking if the user would like to detach. If so,
# try to detach. If not, do nothing and go away.
proc gdbtk_detach {} {
  global _gdbtk_stop

  set _gdbtk_stop(msg) "No response from target. Detach from target\n(and stop debugging it)?"
  if {[gdbtk_tcl_query  $_gdbtk_stop(msg) no]} {
    catch {gdb_stop detach}
  }

  set _gdbtk_stop(timer) ""
  set _gdbtk_stop(msg) ""
  remove_hook gdb_idle_hook gdbtk_stop_idle_callback
}

# ------------------------------------------------------------------
#  PROC: gdbtk_run
# ------------------------------------------------------------------
proc gdbtk_run {} {
  if {$::gdb_running == 1} {
    set msg "A program is currently being debugged.\n"
    append msg "Do you want to restart?"
    if {![gdbtk_tcl_query $msg no]} {
      # NO
      return
    }
  }
  run_executable
}

# ------------------------------------------------------------------
# PROC:  gdbtk_attach_native: attach to a running target
# ------------------------------------------------------------------
proc gdbtk_attach_native {} {
    ManagedWin::open_dlg AttachDlg ;#-transient

    debug "ManagedWin got [AttachDlg::last_button] [AttachDlg::pid]"

    if {[AttachDlg::last_button]} {
  set pid [AttachDlg::pid]
  set symbol_file [AttachDlg::symbol_file]
  if {$symbol_file != "" && ![_open_file $symbol_file]} {
      ManagedWin::open WarningDlg -transient \
              -message "Could not load symbols from $symbol_file."
      return
  }
  
  if {[catch {gdb_cmd "attach $pid"} result]} {
      ManagedWin::open WarningDlg -transient \
              -message [list "Could not attach to $pid:\n$result"]
      return
  }
    }
}

# ------------------------------------------------------------------
# PROC: set_baud -  Tell GDB the baud rate.
# ------------------------------------------------------------------
proc set_baud {} {
  global gdb_target_name
  #set target [ide_property get target-internal-name]
  set baud [pref getd gdb/load/${gdb_target_name}-baud]
  if {$baud == ""} {
    set baud [pref get gdb/load/baud]
  }
#  debug "setting baud to $baud"
  catch {gdb_cmd "set remotebaud $baud"}
}

# ------------------------------------------------------------------
# PROC: do_state_hook -
# ------------------------------------------------------------------
proc do_state_hook {varname ind op} {
  run_hooks state_hook $varname
}

# ------------------------------------------------------------------
# PROC: gdbtk_disconnect -
# ------------------------------------------------------------------
proc gdbtk_disconnect {{async 0}} {
   global gdb_loaded gdb_target_changed
   catch {gdb_cmd "detach"}
   # force a new target command to do something
   set gdb_loaded 0
   set gdb_target_changed 1
   set gdb_running 0
   gdbtk_idle
   gdbtk_update
 }

# ------------------------------------------------------------------
# PROC: tstart -
# ------------------------------------------------------------------
proc tstart {} {
   if {[catch {gdb_cmd "tstart"} errTxt]} {
     tk_messageBox -title "Error" -message $errTxt -icon error \
       -type ok
    gdbtk_idle
     return 0
   }
  return 1
}

# ------------------------------------------------------------------
# PROC: tstop -
# ------------------------------------------------------------------
proc tstop {} {

   if {[catch {gdb_cmd "tstop"} errTxt]} {
     tk_messageBox -title "Error" -message $errTxt -icon error \
       -type ok
     gdbtk_idle
     return 0
   }
   return 1
 }

# ------------------------------------------------------------------
# PROC: source_file -
# ------------------------------------------------------------------
proc source_file {} {
  set file_name [tk_getOpenFile -title "Choose GDB Command file"]
  if {$file_name != ""} {
    gdb_cmd "source $file_name"
  }
}


# -----------------------------------------------------------------------------
# NAME:           gdbtk_signal
#
# SYNOPSIS:       gdbtk_signal {name longname}
#
# DESC:           This procedure is called from GDB when a signal 
#         is generated, for example, a SIGSEGV.
#
# ARGS:           name - The name of the signal, as returned by
#                 target_signal_to_name().
#         longname - A description of the signal.
# -----------------------------------------------------------------------------
proc gdbtk_signal {name {longname ""}} {
  dbug W "caught signal $name $longname"
  set longname
  set message "Program received signal $name, $longname"
  set srcs [ManagedWin::find SrcWin]
  foreach w $srcs {
    $w set_status $message
  }
  gdbtk_tcl_ignorable_warning signal $message
  update idletasks
}

# Hook for clearing out executable state. Widgets should register a callback
# for this hook if they have anything that may need cleaning if the user
# requests to re-load an executable.
define_hook gdb_clear_file_hook

# -----------------------------------------------------------------------------
# NAME:       gdbtk_clear_file
#
# SYNOPSIS:   gdbtk_clear_file
#
# DESC:       This procedure is called when the user requests a new exec
#             file load. It runs the gdb_clear_file_hook, which tells
#             all widgets to clear state. It CANNOT call gdb_clear_file,
#             since this hook runs AFTER we load a new exec file (i.e.,
#             gdb_clear_file would clear the file name).
#
# ARGS:       none
# -----------------------------------------------------------------------------
proc gdbtk_clear_file {} {
  global gdb_target_name

  debug
  # Give widgets a chance to clean up
  catch {run_hooks gdb_clear_file_hook}

  # Save the target name in case the user has already selected a
  # target. No need to force the user to select it again.
  set old_target $gdb_target_name

  # Finally, reset our state
  initialize_gdbtk

  set gdb_target_name $old_target
}

# ------------------------------------------------------------------
#  PROC: intialize_gdbtk - (re)initialize gdbtk's state
# ------------------------------------------------------------------
proc initialize_gdbtk {} {
  global gdb_exe_changed gdb_target_changed gdb_running gdb_downloading \
    gdb_loaded gdb_program_has_run file_done gdb_pretty_name gdb_exec \
    gdb_target_cmd download_dialog gdb_pretty_name gdb_exe_name _gdbtk_stop \
    gdb_target_name gdb_target_changed gdbtk_state gdb_kod_cmd gdb_shutting_down

  # initialize state variables
  set gdb_exe_changed 0
  set gdb_target_changed 0
  set gdb_running 0
  set gdb_downloading 0
  set gdb_loaded 0
  set gdb_program_has_run 0
  set file_done 0
  set gdb_pretty_name {}
  set gdb_exec {}
  set gdb_target_cmd ""
  set gdb_running 0
  set gdb_shutting_down 0

  set download_dialog ""

  # gdb_pretty_name is the name of the GDB target as it should be
  # displayed to the user.
  set gdb_pretty_name ""

  # gdb_exe_name is the name of the executable we are debugging.  
  set gdb_exe_name ""

  # Initialize readline
  if {![info exists gdbtk_state(readline)]} {
    # Only do this once...
    set gdbtk_state(readline) 0
    set gdbtk_state(console) ""
    set gdbtk_state(readlineShowUser) 1
  }

  # flush cache for gdbtk_locate_main
  gdbtk_locate_main 1

  # check for existence of a kod command and get it's name and
  # text for menu entry
  set gdb_kod_cmd ""
  set msg ""
  if {![catch {gdb_cmd "show os"} msg] && ($msg != "")} {
    set line1 [string range $msg 0 [expr [string first \n $msg] -1]]
    if {[regexp -- \"(.*)\" $line1 dummy cmd]} {
      set gdb_kod_cmd $cmd
    }
  }
#  debug "kod_cmd=$gdb_kod_cmd"

  # setup stop button
  set _gdbtk_stop(timer) ""
  set _gdbtk_stop(msg) ""

  # gdb_target_name is the name of the GDB target; that is, the argument
  # to the GDB target command.
  set gdb_target_name ""

  # By setting gdb_target_changed, we force a target dialog
  # to be displayed on the first "run"
  set gdb_target_changed 1
}

# The architecture changed. Inform the UI.
proc gdbtk_tcl_architecture_changed {} {
  set e [ArchChangedEvent \#auto]
  # First perform global actions as a result of the architecture change.
  gdb_reg_arch_changed $e 
  # Now dispatch to all the other event handlers.
  GDBEventHandler::dispatch $e
  delete object $e
}

proc gdbtk_console_read {} {
  if {$::gdbtk_state(console) == ""} {
    ManagedWin::open Console -force
  } else {
    raise [namespace tail $::gdbtk_state(console)]
  }
  set result [$::gdbtk_state(console) gets]
  debug "result=$result"
  return $result
}

# This is based on TIP 171 to enable better default behavior
# with the MouseWheel event. I don't know why this is not in 
# Tk yet (at least 8.5), but this allows all of our windows to
# scroll without having to do anything.
proc ::tk::MouseWheel {wFired X Y D {shifted 0}} {
    # Set event to check based on call
    set evt "<[expr {$shifted?{Shift-}:{}}]MouseWheel>"
    # do not double-fire in case the class already has a binding
    if {[bind [winfo class $wFired] $evt] ne ""} { return }
    # obtain the window the mouse is over
    set w [winfo containing $X $Y]
    # if we are outside the app, try and scroll the focus widget
    if {![winfo exists $w]} { catch {set w [focus]} }
    if {[winfo exists $w]} {
  if {[bind $w $evt] ne ""} {
      # Awkward ... this widget has a MouseWheel binding, but to
      # trigger successfully in it, we must give it focus.
      catch {focus} old
      if {$w ne $old} { focus $w }
      event generate $w $evt -rootx $X -rooty $Y -delta $D
      if {$w ne $old} { focus $old }
      return
  }
  # aqua and x11/win32 have different delta handling
  if {[tk windowingsystem] ne "aqua"} {
      set delta [expr {- ($D / 30)}]
  } else {
      set delta [expr {- ($D)}]
  }
  # scrollbars have different call conventions
  if {[string match "*Scrollbar" [winfo class $w]]} {
      catch {tk::ScrollByUnits $w \
                 [string index [$w cget -orient] 0] $delta}
  } else {
      # Walking up to find the proper widget handles cases like
      # embedded widgets in a canvas

      # 20091008-keiths: This cannot possibly work the way it
      # was written in the TIP, so I've rewritten it to work the
      # way the comments say it should.
      set cmd [list "%W" [expr {$shifted ? "xview" : "yview"}] \
                   scroll $delta units]
      while {[catch [regsub "%W" $cmd $w]] && [winfo toplevel $w] ne $w} {
          set w [winfo parent $w]
      }
  }
    }
}

bind all <MouseWheel> [list ::tk::MouseWheel %W %X %Y %D 0]
bind all <Shift-MouseWheel> [list ::tk::MouseWheel %W %X %Y %D 1]
if {[tk windowingsystem] eq "x11"} {
    # Support for mousewheels on Linux/Unix commonly comes through
    # mapping the wheel to the extended buttons.
    bind all <4> [list ::tk::MouseWheel %W %X %Y 120]
    bind all <5> [list ::tk::MouseWheel %W %X %Y -120]
}

set mw_classes [list Text Listbox Table TreeCtrl]
foreach class $mw_classes { bind $class <MouseWheel> {} }
if {[tk windowingsystem] eq "x11"} {
    foreach class $mw_classes {
   bind $class <4> {}
   bind $class <5> {}
    }
}