URL https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [gdb/] [gdbtcl/] [interface.tcl] - Blame information for rev 1767

Go to most recent revision | Details | Compare with Previous | View Log

# Interface between GDB and Insight.
# Copyright 1997, 1998, 1999, 2001 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
 
  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
 
  SrcWin::point_to_main
  set msg ""
  catch {gdb_cmd "info files"} msg
  set line1 [string range $msg 0 [string first \n $msg]]
  if {[regexp {Symbols from "(.*)"\.} $line1 dummy name]} {
    set gdb_exe_name $name
  }
 
 
  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]} {
    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 tcl_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 {$tcl_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 -modal $modal -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}
        default {show_warning $message}
       }
}
 
# ------------------------------------------------------------------
# PROC: show_warning -
# ------------------------------------------------------------------
proc show_warning {message} {
  global tcl_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 {$tcl_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 -modal $modal -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 {$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 {$::gdbtk_state(console) != ""} {
    $::gdbtk_state(console) einsert $message err_tag
    update
  }
}
 
# ------------------------------------------------------------------
# PROC: gdbtk_tcl_fputs_log - write a log message
# ------------------------------------------------------------------
proc gdbtk_tcl_fputs_log {message} {
  if {$::gdbtk_state(console) != ""} {
    $::gdbtk_state(console) einsert $message log_tag
    update
  }
}
 
# ------------------------------------------------------------------
# PROC: gdbtk_tcl_fputs_target - write target output
# ------------------------------------------------------------------
proc gdbtk_tcl_fputs_target {message} {
  if {$::gdbtk_state(console) != ""} {
    $::gdbtk_state(console) einsert $message target_tag
    update
  }
}
 
# ------------------------------------------------------------------
# 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
  gdb_cmd $command
}
 
# ------------------------------------------------------------------
# PROC: gdbtk_tcl_readline_begin -
# ------------------------------------------------------------------
proc gdbtk_tcl_readline_begin {message} {
  global gdbtk_state
#  debug "readline begin"
  set gdbtk_state(readline) 0
  if {$gdbtk_state(console) != ""} {
    $gdbtk_state(console) insert $message
  }
}
 
# ------------------------------------------------------------------
# PROC: gdbtk_tcl_readline -
# ------------------------------------------------------------------
proc gdbtk_tcl_readline {prompt} {
  global gdbtk_state
#  debug "$prompt"
  if {[info exists gdbtk_state(readlineArgs)]} {
    # Not interactive, so pop the list, and print element.
    set cmd [lvarpop gdbtk_state(readlineArgs)]
    command::insert_command $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 "readline_end"
  catch {unset gdbtk_state(readlineArgs)}
  unset gdbtk_state(readlineActive)
  command::end_multi_line_input
}
 
# ------------------------------------------------------------------
# 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"                              #
#         - pre_add_symbol_hook                                    #
#            Called in symbol_file_add before loading. The tcl     #
#            hook is "gdbtk_tcl_pre_add_symbol"                    #
#         - 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
    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.
  set filename [string trim $filename \']
  if {[string index $filename 0] != "/"} {
    set pwd [pwd]
    set filename "$pwd/$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
#  6: shared library name if the pc is in a shared lib
#  we are browsing, or walking the stack.
#
# ------------------------------------------------------------------
proc gdbtk_locate_main {} {
  set main_names [pref get gdb/main_names]
  debug "Searching $main_names"
  foreach main $main_names {
    if {![catch {gdb_search functions $main -static 1}] \
        && ![catch {gdb_loc $main} linespec]} {
      return $linespec
    }
  }
  if {![catch gdb_entry_point entry_point]
      && ![catch {gdb_loc "*$entry_point"} linespec]} {
    return $linespec
  }
  return {}
}
 
##############################################
#  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"
 
  if {$gdb_exe_name != ""} then {
    session_save
  }
 
  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 -modal system \
        -message "This executable has no debugging information."
      set gdb_exe_name {}
      set file_done 0
      return
    }
 
    # 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 tcl_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 {$tcl_platform(platform) == "windows"} {
    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} {
    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 get 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"
    set err [catch {gdb_immediate "target $gdb_target_cmd"} msg ]
    $srcWin set_status
 
    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 \
        -modal task -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] einsert $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 tcl_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]} {
      if {[gdbtk_attach_remote] == "ATTACH_CANCELED"} {
        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 {$tcl_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 ui_loop_hook to 
# keep us alive. For native unix, we use an interval timer.
# Simulators either call ui_loop_hook directly (older sims, at least)
# or they call gdb's os_poll_quit callback, where we insert a call
# to ui_loop_hook. Some targets (like v850ice and windows native)
# require a call to 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 3000 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 {} {
  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 {![_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
  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) ""
  }
 
  # 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
}
 
Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [gdb/] [gdbtcl/] [interface.tcl] - Blame information for rev 1767

Line No.	Rev	Author	Line
1	578	markom	`# Interface between GDB and Insight.`
2			`# Copyright 1997, 1998, 1999, 2001 Red Hat, Inc.`
3			`#`
4			`# This program is free software; you can redistribute it and/or modify it`
5			`# under the terms of the GNU General Public License (GPL) as published by`
6			`# the Free Software Foundation; either version 2 of the License, or (at`
7			`# your option) any later version.`
8			`#`
9			`# This program is distributed in the hope that it will be useful,`
10			`# but WITHOUT ANY WARRANTY; without even the implied warranty of`
11			`# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the`
12			`# GNU General Public License for more details.`
13
14
15			`# This variable is reserved for this module. Ensure it is an array.`
16			`global gdbtk_state`
17			`set gdbtk_state(busyCount) 0`
18
19			`# *** DEPRECATED: Use GDBEventHandler::breakpoint instead.`
20			`# This is run when a breakpoint changes. The arguments are the`
21			`# action, the breakpoint number, and the breakpoint info.`
22			`#define_hook gdb_breakpoint_change_hook`
23
24			`# *** DEPRECATED: Use GDBEventHandler::set_variable instead.`
25			# This is run when a `set' command successfully completes in gdb. The
26			`# first argument is the gdb variable name (as a Tcl list). The second`
27			`# argument is the new value.`
28			`#define_hook gdb_set_hook`
29
30			`# ------------------------------------------------------------`
31			`# PROC: gdbtk_tcl_set_variable - A "set" command was issued`
32			`# in gdb to change an internal variable. Notify`
33			`# gui.`
34			`# ------------------------------------------------------------`
35			`proc gdbtk_tcl_set_variable {var val} {`
36			`set e [SetVariableEvent \#auto -variable $var -value $val]`
37			`GDBEventHandler::dispatch $e`
38			`delete object $e`
39			`}`
40