| # 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 } |
| 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" |
| # ARC 24/11/08 |
| # change 1 to 0 in lindex |
| # check for target being simulator |
| set target [lindex $gdb_target_cmd 0] |
| if {$target == "sim" } { |
| set message "$msg\n\n$debugger_name cannot connect to the simulator.\ |
| \nSelect an executable file to be debugged first." |
| } else { |
| set message "$msg\n\n$debugger_name cannot connect to the target board\ |
| using $target.\nVerify that the board is securely connected and, if\ |
| necessary,\nmodify the port setting with the debugger preferences." |
| } |
| tk_messageBox -icon error -title $dialog_title -type ok -message $message |
| 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] |
| 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 |
| } |