OpenE2K
/
binutils-gdb
12
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
binutils-gdb/gdb/testsuite/lib/mi-support.exp

2317 lines
68 KiB
Plaintext
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

# Copyright 1999-2013 Free Software Foundation, Inc.
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 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.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
# This file was based on a file written by Fred Fish. (fnf@cygnus.com)
# Test setup routines that work with the MI interpreter.
# The variable mi_gdb_prompt is a regexp which matches the gdb mi prompt.
# Set it if it is not already set.
global mi_gdb_prompt
if ![info exists mi_gdb_prompt] then {
set mi_gdb_prompt "\[(\]gdb\[)\] \r\n"
}
global mi_inferior_spawn_id
global mi_inferior_tty_name
set MIFLAGS "-i=mi"
set thread_selected_re "=thread-selected,id=\"\[0-9\]+\"\r\n"
set gdbindex_warning_re "&\"warning: Skipping \[^\r\n\]+ \.gdb_index section in \[^\r\n\]+\"\r\n(?:&\"\\\\n\"\r\n)?"
set library_loaded_re "=library-loaded\[^\n\]+\"\r\n(?:$gdbindex_warning_re)?"
set breakpoint_re "=(?:breakpoint-created|breakpoint-deleted)\[^\n\]+\"\r\n"
#
# mi_gdb_exit -- exit the GDB, killing the target program if necessary
#
proc mi_gdb_exit {} {
catch mi_uncatched_gdb_exit
}
proc mi_uncatched_gdb_exit {} {
global GDB
global INTERNAL_GDBFLAGS GDBFLAGS
global verbose
global gdb_spawn_id;
global gdb_prompt
global mi_gdb_prompt
global MIFLAGS
gdb_stop_suppressing_tests;
if { [info procs sid_exit] != "" } {
sid_exit
}
if ![info exists gdb_spawn_id] {
return;
}
verbose "Quitting $GDB $INTERNAL_GDBFLAGS $GDBFLAGS $MIFLAGS"
if { [is_remote host] && [board_info host exists fileid] } {
send_gdb "999-gdb-exit\n";
gdb_expect 10 {
-re "y or n" {
send_gdb "y\n";
exp_continue;
}
-re "Undefined command.*$gdb_prompt $" {
send_gdb "quit\n"
exp_continue;
}
-re "DOSEXIT code" { }
default { }
}
}
if ![is_remote host] {
remote_close host;
}
unset gdb_spawn_id
}
#
# default_mi_gdb_start [INFERIOR_PTY] -- start gdb running, default procedure
#
# INFERIOR_PTY should be set to separate-inferior-tty to have the inferior work
# with it's own PTY. If set to same-inferior-tty, the inferior shares GDB's PTY.
# The default value is same-inferior-tty.
#
# When running over NFS, particularly if running many simultaneous
# tests on different hosts all using the same server, things can
# get really slow. Give gdb at least 3 minutes to start up.
#
proc default_mi_gdb_start { args } {
global verbose use_gdb_stub
global GDB
global INTERNAL_GDBFLAGS GDBFLAGS
global gdb_prompt
global mi_gdb_prompt
global timeout
global gdb_spawn_id;
global MIFLAGS
gdb_stop_suppressing_tests;
set inferior_pty no-tty
# Set the default value, it may be overriden later by specific testfile.
set use_gdb_stub [target_info exists use_gdb_stub]
if { [llength $args] == 1} {
set inferior_pty [lindex $args 0]
}
set separate_inferior_pty [string match $inferior_pty separate-inferior-tty]
# Start SID.
if { [info procs sid_start] != "" } {
verbose "Spawning SID"
sid_start
}
verbose "Spawning $GDB $INTERNAL_GDBFLAGS $GDBFLAGS $MIFLAGS"
if [info exists gdb_spawn_id] {
return 0
}
if ![is_remote host] {
if { [which $GDB] == 0 } then {
perror "$GDB does not exist."
exit 1
}
}
# Create the new PTY for the inferior process.
if { $separate_inferior_pty } {
spawn -pty
global mi_inferior_spawn_id
global mi_inferior_tty_name
set mi_inferior_spawn_id $spawn_id
set mi_inferior_tty_name $spawn_out(slave,name)
}
set res [remote_spawn host "$GDB $INTERNAL_GDBFLAGS $GDBFLAGS $MIFLAGS [host_info gdb_opts]"];
if { $res < 0 || $res == "" } {
perror "Spawning $GDB failed."
return 1
}
gdb_expect {
-re "~\"GNU.*\r\n~\".*$mi_gdb_prompt$" {
# We have a new format mi startup prompt. If we are
# running mi1, then this is an error as we should be
# using the old-style prompt.
if { $MIFLAGS == "-i=mi1" } {
perror "(mi startup) Got unexpected new mi prompt."
remote_close host;
return -1
}
verbose "GDB initialized."
}
-re "\[^~\].*$mi_gdb_prompt$" {
# We have an old format mi startup prompt. If we are
# not running mi1, then this is an error as we should be
# using the new-style prompt.
if { $MIFLAGS != "-i=mi1" } {
perror "(mi startup) Got unexpected old mi prompt."
remote_close host;
return -1
}
verbose "GDB initialized."
}
-re ".*unrecognized option.*for a complete list of options." {
untested "Skip mi tests (not compiled with mi support)."
remote_close host;
return -1
}
-re ".*Interpreter `mi' unrecognized." {
untested "Skip mi tests (not compiled with mi support)."
remote_close host;
return -1
}
timeout {
perror "(timeout) GDB never initialized after 10 seconds."
remote_close host;
return -1
}
}
set gdb_spawn_id -1;
# FIXME: mi output does not go through pagers, so these can be removed.
# force the height to "unlimited", so no pagers get used
send_gdb "100-gdb-set height 0\n"
gdb_expect 10 {
-re ".*100-gdb-set height 0\r\n100\\\^done\r\n$mi_gdb_prompt$" {
verbose "Setting height to 0." 2
}
timeout {
warning "Couldn't set the height to 0"
}
}
# force the width to "unlimited", so no wraparound occurs
send_gdb "101-gdb-set width 0\n"
gdb_expect 10 {
-re ".*101-gdb-set width 0\r\n101\\\^done\r\n$mi_gdb_prompt$" {
verbose "Setting width to 0." 2
}
timeout {
warning "Couldn't set the width to 0."
}
}
# If allowing the inferior to have its own PTY then assign the inferior
# its own terminal device here.
if { $separate_inferior_pty } {
send_gdb "102-inferior-tty-set $mi_inferior_tty_name\n"
gdb_expect 10 {
-re ".*102\\\^done\r\n$mi_gdb_prompt$" {
verbose "redirect inferior output to new terminal device."
}
timeout {
warning "Couldn't redirect inferior output." 2
}
}
}
mi_detect_async
return 0
}
#
# Overridable function. You can override this function in your
# baseboard file.
#
proc mi_gdb_start { args } {
return [default_mi_gdb_start $args]
}
# Many of the tests depend on setting breakpoints at various places and
# running until that breakpoint is reached. At times, we want to start
# with a clean-slate with respect to breakpoints, so this utility proc
# lets us do this without duplicating this code everywhere.
#
proc mi_delete_breakpoints {} {
global mi_gdb_prompt
# FIXME: The mi operation won't accept a prompt back and will use the 'all' arg
send_gdb "102-break-delete\n"
gdb_expect 30 {
-re "Delete all breakpoints.*y or n.*$" {
send_gdb "y\n";
exp_continue
}
-re "102-break-delete\r\n102\\\^done\r\n$mi_gdb_prompt$" {
# This happens if there were no breakpoints
}
timeout { perror "Delete all breakpoints in mi_delete_breakpoints (timeout)" ; return }
}
# The correct output is not "No breakpoints or watchpoints." but an
# empty BreakpointTable. Also, a query is not acceptable with mi.
send_gdb "103-break-list\n"
gdb_expect 30 {
-re "103-break-list\r\n103\\\^done,BreakpointTable=\{\}\r\n$mi_gdb_prompt$" {}
-re "103-break-list\r\n103\\\^done,BreakpointTable=\{nr_rows=\".\",nr_cols=\".\",hdr=\\\[\{width=\".*\",alignment=\".*\",col_name=\"number\",colhdr=\"Num\"\}.*colhdr=\"Type\".*colhdr=\"Disp\".*colhdr=\"Enb\".*colhdr=\"Address\".*colhdr=\"What\".*\\\],body=\\\[\\\]\}\r\n$mi_gdb_prompt$" {}
-re "103-break-list\r\n103\\\^doneNo breakpoints or watchpoints.\r\n\r\n$mi_gdb_prompt$" {warning "Unexpected console text received"}
-re "$mi_gdb_prompt$" { perror "Breakpoints not deleted" ; return }
-re "Delete all breakpoints.*or n.*$" {
warning "Unexpected prompt for breakpoints deletion";
send_gdb "y\n";
exp_continue
}
timeout { perror "-break-list (timeout)" ; return }
}
}
proc mi_gdb_reinitialize_dir { subdir } {
global mi_gdb_prompt
global MIFLAGS
global suppress_flag
if { $suppress_flag } {
return
}
if [is_remote host] {
return ""
}
if { $MIFLAGS == "-i=mi1" } {
send_gdb "104-environment-directory\n"
gdb_expect 60 {
-re ".*Reinitialize source path to empty.*y or n. " {
warning "Got confirmation prompt for dir reinitialization."
send_gdb "y\n"
gdb_expect 60 {
-re "$mi_gdb_prompt$" {}
timeout {error "Dir reinitialization failed (timeout)"}
}
}
-re "$mi_gdb_prompt$" {}
timeout {error "Dir reinitialization failed (timeout)"}
}
} else {
send_gdb "104-environment-directory -r\n"
gdb_expect 60 {
-re "104\\\^done,source-path=.*\r\n$mi_gdb_prompt$" {}
-re "$mi_gdb_prompt$" {}
timeout {error "Dir reinitialization failed (timeout)"}
}
}
send_gdb "105-environment-directory $subdir\n"
gdb_expect 60 {
-re "Source directories searched.*$mi_gdb_prompt$" {
verbose "Dir set to $subdir"
}
-re "105\\\^done.*\r\n$mi_gdb_prompt$" {
# FIXME: We return just the prompt for now.
verbose "Dir set to $subdir"
# perror "Dir \"$subdir\" failed."
}
}
}
# Send GDB the "target" command.
# FIXME: Some of these patterns are not appropriate for MI. Based on
# config/monitor.exp:gdb_target_command.
proc mi_gdb_target_cmd { targetname serialport } {
global mi_gdb_prompt
set serialport_re [string_to_regexp $serialport]
for {set i 1} {$i <= 3} {incr i} {
send_gdb "47-target-select $targetname $serialport\n"
gdb_expect 60 {
-re "47\\^connected.*$mi_gdb_prompt" {
verbose "Set target to $targetname";
return 0
}
-re "unknown host.*$mi_gdb_prompt" {
verbose "Couldn't look up $serialport"
}
-re "Couldn't establish connection to remote.*$mi_gdb_prompt$" {
verbose "Connection failed";
}
-re "Remote MIPS debugging.*$mi_gdb_prompt$" {
verbose "Set target to $targetname";
return 0
}
-re "Remote debugging using .*$serialport_re.*$mi_gdb_prompt$" {
verbose "Set target to $targetname";
return 0
}
-re "Remote target $targetname connected to.*$mi_gdb_prompt$" {
verbose "Set target to $targetname";
return 0
}
-re "Connected to.*$mi_gdb_prompt$" {
verbose "Set target to $targetname";
return 0
}
-re "Ending remote.*$mi_gdb_prompt$" { }
-re "Connection refused.*$mi_gdb_prompt$" {
verbose "Connection refused by remote target. Pausing, and trying again."
sleep 5
continue
}
-re "Non-stop mode requested, but remote does not support non-stop.*$mi_gdb_prompt" {
unsupported "Non-stop mode not supported"
return 1
}
-re "Timeout reading from remote system.*$mi_gdb_prompt$" {
verbose "Got timeout error from gdb.";
}
timeout {
send_gdb "";
break
}
}
}
return 1
}
#
# load a file into the debugger (file command only).
# return a -1 if anything goes wrong.
#
proc mi_gdb_file_cmd { arg } {
global verbose
global loadpath
global loadfile
global GDB
global mi_gdb_prompt
global last_loaded_file
upvar timeout timeout
set last_loaded_file $arg
if [is_remote host] {
set arg [remote_download host $arg];
if { $arg == "" } {
error "download failed"
return -1
}
}
# FIXME: Several of these patterns are only acceptable for console
# output. Queries are an error for mi.
send_gdb "105-file-exec-and-symbols $arg\n"
gdb_expect 120 {
-re "Reading symbols from.*done.*$mi_gdb_prompt$" {
verbose "\t\tLoaded $arg into the $GDB"
return 0
}
-re "has no symbol-table.*$mi_gdb_prompt$" {
perror "$arg wasn't compiled with \"-g\""
return -1
}
-re "Load new symbol table from \".*\".*y or n. $" {
send_gdb "y\n"
gdb_expect 120 {
-re "Reading symbols from.*done.*$mi_gdb_prompt$" {
verbose "\t\tLoaded $arg with new symbol table into $GDB"
# All OK
}
timeout {
perror "(timeout) Couldn't load $arg, other program already loaded."
return -1
}
}
}
-re "No such file or directory.*$mi_gdb_prompt$" {
perror "($arg) No such file or directory\n"
return -1
}
-re "105-file-exec-and-symbols .*\r\n105\\\^done\r\n$mi_gdb_prompt$" {
# We (MI) are just giving the prompt back for now, instead of giving
# some acknowledgement.
return 0
}
timeout {
perror "couldn't load $arg into $GDB (timed out)."
return -1
}
eof {
# This is an attempt to detect a core dump, but seems not to
# work. Perhaps we need to match .* followed by eof, in which
# gdb_expect does not seem to have a way to do that.
perror "couldn't load $arg into $GDB (end of file)."
return -1
}
}
}
#
# connect to the target and download a file, if necessary.
# return a -1 if anything goes wrong.
#
proc mi_gdb_target_load { } {
global verbose
global loadpath
global loadfile
global GDB
global mi_gdb_prompt
if [target_info exists gdb_load_timeout] {
set loadtimeout [target_info gdb_load_timeout]
} else {
set loadtimeout 1600
}
if { [info procs gdbserver_gdb_load] != "" } {
mi_gdb_test "kill" ".*" ""
set res [gdbserver_gdb_load]
set protocol [lindex $res 0]
set gdbport [lindex $res 1]
if { [mi_gdb_target_cmd $protocol $gdbport] != 0 } {
return -1
}
} elseif { [info procs send_target_sid] != "" } {
# For SID, things get complex
send_gdb "kill\n"
gdb_expect 10 {
-re ".*$mi_gdb_prompt$"
}
send_target_sid
gdb_expect $loadtimeout {
-re "\\^done.*$mi_gdb_prompt$" {
}
timeout {
perror "Unable to connect to SID target (timeout)"
return -1
}
}
send_gdb "48-target-download\n"
gdb_expect $loadtimeout {
-re "48\\^done.*$mi_gdb_prompt$" {
}
timeout {
perror "Unable to download to SID target (timeout)"
return -1
}
}
} elseif { [target_info protocol] == "sim" } {
# For the simulator, just connect to it directly.
send_gdb "47-target-select sim\n"
gdb_expect $loadtimeout {
-re "47\\^connected.*$mi_gdb_prompt$" {
}
timeout {
perror "Unable to select sim target (timeout)"
return -1
}
}
send_gdb "48-target-download\n"
gdb_expect $loadtimeout {
-re "48\\^done.*$mi_gdb_prompt$" {
}
timeout {
perror "Unable to download to sim target (timeout)"
return -1
}
}
} elseif { [target_info gdb_protocol] == "remote" } {
# remote targets
if { [mi_gdb_target_cmd "remote" [target_info netport]] != 0 } {
perror "Unable to connect to remote target"
return -1
}
send_gdb "48-target-download\n"
gdb_expect $loadtimeout {
-re "48\\^done.*$mi_gdb_prompt$" {
}
timeout {
perror "Unable to download to remote target (timeout)"
return -1
}
}
}
return 0
}
#
# load a file into the debugger.
# return a -1 if anything goes wrong.
#
proc mi_gdb_load { arg } {
if { $arg != "" } {
return [mi_gdb_file_cmd $arg]
}
return 0
}
# mi_gdb_test COMMAND PATTERN MESSAGE [IPATTERN] -- send a command to gdb;
# test the result.
#
# COMMAND is the command to execute, send to GDB with send_gdb. If
# this is the null string no command is sent.
# PATTERN is the pattern to match for a PASS, and must NOT include
# the \r\n sequence immediately before the gdb prompt.
# MESSAGE is the message to be printed. (If this is the empty string,
# then sometimes we don't call pass or fail at all; I don't
# understand this at all.)
# IPATTERN is the pattern to match for the inferior's output. This parameter
# is optional. If present, it will produce a PASS if the match is
# successful, and a FAIL if unsuccessful.
#
# Returns:
# 1 if the test failed,
# 0 if the test passes,
# -1 if there was an internal error.
#
proc mi_gdb_test { args } {
global verbose
global mi_gdb_prompt
global GDB expect_out
global inferior_exited_re async
upvar timeout timeout
set command [lindex $args 0]
set pattern [lindex $args 1]
set message [lindex $args 2]
if [llength $args]==4 {
set ipattern [lindex $args 3]
}
if [llength $args]==5 {
set question_string [lindex $args 3];
set response_string [lindex $args 4];
} else {
set question_string "^FOOBAR$"
}
if $verbose>2 then {
send_user "Sending \"$command\" to gdb\n"
send_user "Looking to match \"$pattern\"\n"
send_user "Message is \"$message\"\n"
}
set result -1
set string "${command}\n";
set string_regex [string_to_regexp $command]
if { $command != "" } {
while { "$string" != "" } {
set foo [string first "\n" "$string"];
set len [string length "$string"];
if { $foo < [expr $len - 1] } {
set str [string range "$string" 0 $foo];
if { [send_gdb "$str"] != "" } {
global suppress_flag;
if { ! $suppress_flag } {
perror "Couldn't send $command to GDB.";
}
fail "$message";
return $result
}
gdb_expect 2 {
-re "\[\r\n\]" { }
timeout { }
}
set string [string range "$string" [expr $foo + 1] end];
} else {
break;
}
}
if { "$string" != "" } {
if { [send_gdb "$string"] != "" } {
global suppress_flag;
if { ! $suppress_flag } {
perror "Couldn't send $command to GDB.";
}
fail "$message";
return $result
}
}
}
if [info exists timeout] {
set tmt $timeout;
} else {
global timeout;
if [info exists timeout] {
set tmt $timeout;
} else {
set tmt 60;
}
}
if {$async} {
# With $prompt_re "" there may come arbitrary asynchronous response
# from the previous command, before or after $string_regex.
set string_regex ".*"
}
verbose -log "Expecting: ^($string_regex\[\r\n\]+)?($pattern\[\r\n\]+$mi_gdb_prompt\[ \]*)"
gdb_expect $tmt {
-re "\\*\\*\\* DOSEXIT code.*" {
if { $message != "" } {
fail "$message";
}
gdb_suppress_entire_file "GDB died";
return -1
}
-re "Ending remote debugging.*$mi_gdb_prompt\[ \]*$" {
if ![isnative] then {
warning "Can`t communicate to remote target."
}
gdb_exit
gdb_start
set result -1
}
-re "^($string_regex\[\r\n\]+)?($pattern\[\r\n\]+$mi_gdb_prompt\[ \]*)" {
# At this point, $expect_out(1,string) is the MI input command.
# and $expect_out(2,string) is the MI output command.
# If $expect_out(1,string) is "", then there was no MI input command here.
# NOTE, there is no trailing anchor because with GDB/MI,
# asynchronous responses can happen at any point, causing more
# data to be available. Normally an anchor is used to make
# sure the end of the output is matched, however, $mi_gdb_prompt
# is just as good of an anchor since mi_gdb_test is meant to
# match a single mi output command. If a second GDB/MI output
# response is sent, it will be in the buffer for the next
# time mi_gdb_test is called.
if ![string match "" $message] then {
pass "$message"
}
set result 0
}
-re "(${question_string})$" {
send_gdb "$response_string\n";
exp_continue;
}
-re "Undefined.* command:.*$mi_gdb_prompt\[ \]*$" {
perror "Undefined command \"$command\"."
fail "$message"
set result 1
}
-re "Ambiguous command.*$mi_gdb_prompt\[ \]*$" {
perror "\"$command\" is not a unique command name."
fail "$message"
set result 1
}
-re "$inferior_exited_re with code \[0-9\]+.*$mi_gdb_prompt\[ \]*$" {
if ![string match "" $message] then {
set errmsg "$message (the program exited)"
} else {
set errmsg "$command (the program exited)"
}
fail "$errmsg"
return -1
}
-re "The program is not being run.*$mi_gdb_prompt\[ \]*$" {
if ![string match "" $message] then {
set errmsg "$message (the program is no longer running)"
} else {
set errmsg "$command (the program is no longer running)"
}
fail "$errmsg"
return -1
}
-re ".*$mi_gdb_prompt\[ \]*$" {
if ![string match "" $message] then {
fail "$message"
}
set result 1
}
"<return>" {
send_gdb "\n"
perror "Window too small."
fail "$message"
}
-re "\\(y or n\\) " {
send_gdb "n\n"
perror "Got interactive prompt."
fail "$message"
}
eof {
perror "Process no longer exists"
if { $message != "" } {
fail "$message"
}
return -1
}
full_buffer {
perror "internal buffer is full."
fail "$message"
}
timeout {
if ![string match "" $message] then {
fail "$message (timeout)"
}
set result 1
}
}
# If the GDB output matched, compare the inferior output.
if { $result == 0 } {
if [ info exists ipattern ] {
if { ![target_info exists gdb,noinferiorio] } {
global mi_inferior_spawn_id
expect {
-i $mi_inferior_spawn_id -re "$ipattern" {
pass "$message inferior output"
}
timeout {
fail "$message inferior output (timeout)"
set result 1
}
}
} else {
unsupported "$message inferior output"
}
}
}
return $result
}
#
# MI run command. (A modified version of gdb_run_cmd)
#
# In patterns, the newline sequence ``\r\n'' is matched explicitly as
# ``.*$'' could swallow up output that we attempt to match elsewhere.
proc mi_run_cmd_full {use_mi_command args} {
global suppress_flag
if { $suppress_flag } {
return -1
}
global mi_gdb_prompt use_gdb_stub
global thread_selected_re
global library_loaded_re
if {$use_mi_command} {
set run_prefix "220-exec-"
set run_match "220"
} else {
set run_prefix ""
set run_match ""
}
if [target_info exists gdb_init_command] {
send_gdb "[target_info gdb_init_command]\n";
gdb_expect 30 {
-re "$mi_gdb_prompt$" { }
default {
perror "gdb_init_command for target failed";
return -1
}
}
}
if { [mi_gdb_target_load] < 0 } {
return -1
}
if $use_gdb_stub {
if [target_info exists gdb,do_reload_on_run] {
send_gdb "${run_prefix}continue\n";
gdb_expect 60 {
-re "${run_match}\\^running\[\r\n\]+\\*running,thread-id=\"\[^\"\]+\"\r\n$mi_gdb_prompt" {}
default {}
}
return 0
}
if [target_info exists gdb,start_symbol] {
set start [target_info gdb,start_symbol];
} else {
set start "start";
}
# HACK: Should either use 000-jump or fix the target code
# to better handle RUN.
send_gdb "jump *$start\n"
warning "Using CLI jump command, expect run-to-main FAIL"
return 0
}
send_gdb "${run_prefix}run $args\n"
gdb_expect {
-re "${run_match}\\^running\r\n(\\*running,thread-id=\"\[^\"\]+\"\r\n|=thread-created,id=\"1\",group-id=\"\[0-9\]+\"\r\n)*(${library_loaded_re})*(${thread_selected_re})?${mi_gdb_prompt}" {
}
-re "\\^error,msg=\"The target does not support running in non-stop mode.\"" {
unsupported "Non-stop mode not supported"
return -1
}
timeout {
perror "Unable to start target"
return -1
}
}
# NOTE: Shortly after this there will be a ``000*stopped,...(gdb)''
return 0
}
# A wrapper for mi_run_cmd_full which uses -exec-run and
# -exec-continue, as appropriate. ARGS are passed verbatim to
# mi_run_cmd_full.
proc mi_run_cmd {args} {
return [eval mi_run_cmd_full 1 $args]
}
# A wrapper for mi_run_cmd_full which uses the CLI commands 'run' and
# 'continue', as appropriate. ARGS are passed verbatim to
# mi_run_cmd_full.
proc mi_run_with_cli {args} {
return [eval mi_run_cmd_full 0 $args]
}
#
# Just like run-to-main but works with the MI interface
#
proc mi_run_to_main { } {
global suppress_flag
if { $suppress_flag } {
return -1
}
global srcdir
global subdir
global binfile
global srcfile
mi_delete_breakpoints
mi_gdb_reinitialize_dir $srcdir/$subdir
mi_gdb_load ${binfile}
mi_runto main
}
# Just like gdb's "runto" proc, it will run the target to a given
# function. The big difference here between mi_runto and mi_execute_to
# is that mi_execute_to must have the inferior running already. This
# proc will (like gdb's runto) (re)start the inferior, too.
#
# FUNC is the linespec of the place to stop (it inserts a breakpoint here).
# It returns:
# -1 if test suppressed, failed, timedout
# 0 if test passed
proc mi_runto_helper {func run_or_continue} {
global suppress_flag
if { $suppress_flag } {
return -1
}
global mi_gdb_prompt expect_out
global hex decimal fullname_syntax
set test "mi runto $func"
mi_gdb_test "200-break-insert -t $func" \
"200\\^done,bkpt=\{number=\"\[0-9\]+\",type=\"breakpoint\",disp=\"del\",enabled=\"y\",addr=\"$hex\",func=\"$func\(\\\(.*\\\)\)?\",file=\".*\",line=\"\[0-9\]*\",thread-groups=\\\[\"i1\"\\\],times=\"0\",original-location=\".*\"\}" \
"breakpoint at $func"
if {![regexp {number="[0-9]+"} $expect_out(buffer) str]
|| ![scan $str {number="%d"} bkptno]} {
set bkptno {[0-9]+}
}
if {$run_or_continue == "run"} {
if { [mi_run_cmd] < 0 } {
return -1
}
} else {
mi_send_resuming_command "exec-continue" "$test"
}
mi_expect_stop "breakpoint-hit" $func ".*" ".*" "\[0-9\]+" { "" "disp=\"del\"" } $test
}
proc mi_runto {func} {
return [mi_runto_helper $func "run"]
}
# Next to the next statement
# For return values, see mi_execute_to_helper
proc mi_next { test } {
return [mi_next_to {.*} {.*} {.*} {.*} $test]
}
# Step to the next statement
# For return values, see mi_execute_to_helper
proc mi_step { test } {
return [mi_step_to {.*} {.*} {.*} {.*} $test]
}
set async "unknown"
proc mi_detect_async {} {
global async
global mi_gdb_prompt
send_gdb "show target-async\n"
gdb_expect {
-re ".*Controlling the inferior in asynchronous mode is on...*$mi_gdb_prompt$" {
set async 1
}
-re ".*$mi_gdb_prompt$" {
set async 0
}
timeout {
set async 0
}
}
return $async
}
# Wait for MI *stopped notification to appear.
# The REASON, FUNC, ARGS, FILE and LINE are regular expressions
# to match against whatever is output in *stopped. FILE may also match
# filename of a file without debug info. ARGS should not include [] the
# list of argument is enclosed in, and other regular expressions should
# not include quotes.
# If EXTRA is a list of one element, it's the regular expression
# for output expected right after *stopped, and before GDB prompt.
# If EXTRA is a list of two elements, the first element is for
# output right after *stopped, and the second element is output
# right after reason field. The regex after reason should not include
# the comma separating it from the following fields.
#
# When we fail to match output at all, -1 is returned. If FILE does
# match and the target system has no debug info for FILE return 0.
# Otherwise, the line at which we stop is returned. This is useful when
# exact line is not possible to specify for some reason -- one can pass
# the .* or "\[0-9\]*" regexps for line, and then check the line
# programmatically.
#
# Do not pass .* for any argument if you are expecting more than one stop.
proc mi_expect_stop { reason func args file line extra test } {
global mi_gdb_prompt
global hex
global decimal
global fullname_syntax
global async
global thread_selected_re
global breakpoint_re
set after_stopped ""
set after_reason ""
if { [llength $extra] == 2 } {
set after_stopped [lindex $extra 0]
set after_reason [lindex $extra 1]
set after_reason "${after_reason},"
} elseif { [llength $extra] == 1 } {
set after_stopped [lindex $extra 0]
}
if {$async} {
set prompt_re ""
} else {
set prompt_re "$mi_gdb_prompt$"
}
if { $reason == "really-no-reason" } {
gdb_expect {
-re "\\*stopped\r\n$prompt_re" {
pass "$test"
}
timeout {
fail "$test (unknown output after running)"
}
}
return
}
if { $reason == "exited-normally" } {
gdb_expect {
-re "\\*stopped,reason=\"exited-normally\"\r\n$prompt_re" {
pass "$test"
}
-re ".*$mi_gdb_prompt$" {fail "continue to end (2)"}
timeout {
fail "$test (unknown output after running)"
}
}
return
}
set args "\\\[$args\\\]"
set bn ""
if { $reason == "breakpoint-hit" } {
set bn {bkptno="[0-9]+",}
} elseif { $reason == "solib-event" } {
set bn ".*"
}
set r ""
if { $reason != "" } {
set r "reason=\"$reason\","
}
set a $after_reason
set any "\[^\n\]*"
verbose -log "mi_expect_stop: expecting: \\*stopped,${r}${a}${bn}frame=\{addr=\"$hex\",func=\"$func\",args=$args,(?:file=\"$any$file\",fullname=\"${fullname_syntax}$file\",line=\"$line\"|from=\"$file\")\}$after_stopped,thread-id=\"$decimal\",stopped-threads=$any\r\n($thread_selected_re|$breakpoint_re)*$prompt_re"
gdb_expect {
-re "\\*stopped,${r}${a}${bn}frame=\{addr=\"$hex\",func=\"$func\",args=$args,(?:file=\"$any$file\",fullname=\"${fullname_syntax}$file\",line=\"($line)\"|from=\"$file\")\}$after_stopped,thread-id=\"$decimal\",stopped-threads=$any\r\n($thread_selected_re|$breakpoint_re)*$prompt_re" {
pass "$test"
if {[array names expect_out "2,string"] != ""} {
return $expect_out(2,string)
}
# No debug info available but $file does match.
return 0
}
-re "\\*stopped,${r}${a}${bn}frame=\{addr=\"$hex\",func=\"$any\",args=\[\\\[\{\]$any\[\\\]\}\],file=\"$any\",fullname=\"${fullname_syntax}$any\",line=\"\[0-9\]*\"\}$after_stopped,thread-id=\"$decimal\",stopped-threads=$any\r\n($thread_selected_re|$breakpoint_re)*$prompt_re" {
verbose -log "got $expect_out(buffer)"
fail "$test (stopped at wrong place)"
return -1
}
-re ".*\r\n$mi_gdb_prompt$" {
verbose -log "got $expect_out(buffer)"
fail "$test (unknown output after running)"
return -1
}
timeout {
fail "$test (timeout)"
return -1
}
}
}
# Wait for MI *stopped notification related to an interrupt request to
# appear.
proc mi_expect_interrupt { test } {
global mi_gdb_prompt
global decimal
global async
if {$async} {
set prompt_re ""
} else {
set prompt_re "$mi_gdb_prompt$"
}
set r "reason=\"signal-received\",signal-name=\"0\",signal-meaning=\"Signal 0\""
set any "\[^\n\]*"
# A signal can land anywhere, just ignore the location
verbose -log "mi_expect_interrupt: expecting: \\*stopped,${r}$any\r\n$prompt_re"
gdb_expect {
-re "\\*stopped,${r}$any\r\n$prompt_re" {
pass "$test"
return 0
}
-re ".*\r\n$mi_gdb_prompt$" {
verbose -log "got $expect_out(buffer)"
fail "$test (unknown output after running)"
return -1
}
timeout {
fail "$test (timeout)"
return -1
}
}
}
# cmd should not include the number or newline (i.e. "exec-step 3", not
# "220-exec-step 3\n"
# Can not match -re ".*\r\n${mi_gdb_prompt}", because of false positives
# after the first prompt is printed.
proc mi_execute_to { cmd reason func args file line extra test } {
global suppress_flag
if { $suppress_flag } {
return -1
}
mi_send_resuming_command "$cmd" "$test"
set r [mi_expect_stop $reason $func $args $file $line $extra $test]
return $r
}
proc mi_next_to { func args file line test } {
mi_execute_to "exec-next" "end-stepping-range" "$func" "$args" \
"$file" "$line" "" "$test"
}
proc mi_step_to { func args file line test } {
mi_execute_to "exec-step" "end-stepping-range" "$func" "$args" \
"$file" "$line" "" "$test"
}
proc mi_finish_to { func args file line result ret test } {
mi_execute_to "exec-finish" "function-finished" "$func" "$args" \
"$file" "$line" \
",gdb-result-var=\"$result\",return-value=\"$ret\"" \
"$test"
}
proc mi_continue_to {func} {
mi_runto_helper $func "continue"
}
proc mi0_execute_to { cmd reason func args file line extra test } {
mi_execute_to_helper "$cmd" "$reason" "$func" "\{$args\}" \
"$file" "$line" "$extra" "$test"
}
proc mi0_next_to { func args file line test } {
mi0_execute_to "exec-next" "end-stepping-range" "$func" "$args" \
"$file" "$line" "" "$test"
}
proc mi0_step_to { func args file line test } {
mi0_execute_to "exec-step" "end-stepping-range" "$func" "$args" \
"$file" "$line" "" "$test"
}
proc mi0_finish_to { func args file line result ret test } {
mi0_execute_to "exec-finish" "function-finished" "$func" "$args" \
"$file" "$line" \
",gdb-result-var=\"$result\",return-value=\"$ret\"" \
"$test"
}
proc mi0_continue_to { bkptno func args file line test } {
mi0_execute_to "exec-continue" "breakpoint-hit\",bkptno=\"$bkptno" \
"$func" "$args" "$file" "$line" "" "$test"
}
# Creates a breakpoint and checks the reported fields are as expected
proc mi_create_breakpoint { location number disp func file line address test } {
verbose -log "Expecting: 222\\^done,bkpt=\{number=\"$number\",type=\"breakpoint\",disp=\"$disp\",enabled=\"y\",addr=\"$address\",func=\"$func\",file=\"$file\",fullname=\".*\",line=\"$line\",thread-groups=\\\[\".*\"\\\],times=\"0\",original-location=\".*\"\}"
mi_gdb_test "222-break-insert $location" \
"222\\^done,bkpt=\{number=\"$number\",type=\"breakpoint\",disp=\"$disp\",enabled=\"y\",addr=\"$address\",func=\"$func\",file=\"$file\",fullname=\".*\",line=\"$line\",thread-groups=\\\[\".*\"\\\],times=\"0\",original-location=\".*\"\}" \
$test
}
proc mi_list_breakpoints { expected test } {
set fullname ".*"
set body ""
set first 1
foreach item $expected {
if {$first == 0} {
set body "$body,"
set first 0
}
set number [lindex $item 0]
set disp [lindex $item 1]
set func [lindex $item 2]
set file [lindex $item 3]
set line [lindex $item 4]
set address [lindex $item 5]
set body "${body}bkpt=\{number=\"$number\",type=\"breakpoint\",disp=\"$disp\",enabled=\"y\",addr=\"$address\",func=\"$func\",file=\".*$file\",${fullname},line=\"$line\",thread-groups=\\\[\"i1\"\\\],times=\"0\",original-location=\".*\"\}"
set first 0
}
verbose -log "Expecting: 666\\\^done,BreakpointTable=\{nr_rows=\".\",nr_cols=\".\",hdr=\\\[\{width=\".*\",alignment=\".*\",col_name=\"number\",colhdr=\"Num\"\}.*colhdr=\"Type\".*colhdr=\"Disp\".*colhdr=\"Enb\".*colhdr=\"Address\".*colhdr=\"What\".*\\\],body=\\\[$body\\\]\}"
mi_gdb_test "666-break-list" \
"666\\\^done,BreakpointTable=\{nr_rows=\".\",nr_cols=\".\",hdr=\\\[\{width=\".*\",alignment=\".*\",col_name=\"number\",colhdr=\"Num\"\}.*colhdr=\"Type\".*colhdr=\"Disp\".*colhdr=\"Enb\".*colhdr=\"Address\".*colhdr=\"What\".*\\\],body=\\\[$body\\\]\}" \
$test
}
# Creates varobj named NAME for EXPRESSION.
# Name cannot be "-".
proc mi_create_varobj { name expression testname } {
mi_gdb_test "-var-create $name * $expression" \
"\\^done,name=\"$name\",numchild=\"\[0-9\]+\",value=\".*\",type=.*,has_more=\"0\"" \
$testname
}
proc mi_create_floating_varobj { name expression testname } {
mi_gdb_test "-var-create $name @ $expression" \
"\\^done,name=\"$name\",numchild=\"\(-1\|\[0-9\]+\)\",value=\".*\",type=.*" \
$testname
}
# Same as mi_create_varobj, but also checks the reported type
# of the varobj.
proc mi_create_varobj_checked { name expression type testname } {
mi_gdb_test "-var-create $name * $expression" \
"\\^done,name=\"$name\",numchild=\"\[0-9\]+\",value=\".*\",type=\"$type\".*" \
$testname
}
# Same as mi_create_floating_varobj, but assumes the test is creating
# a dynamic varobj that has children, so the value must be "{...}".
proc mi_create_dynamic_varobj {name expression testname} {
mi_gdb_test "-var-create $name @ $expression" \
"\\^done,name=\"$name\",numchild=\"\(-1\|\[0-9\]+\)\",value=\"{\\.\\.\\.}\",type=.*" \
$testname
}
# Deletes the specified NAME.
proc mi_delete_varobj { name testname } {
mi_gdb_test "-var-delete $name" \
"\\^done,ndeleted=.*" \
$testname
}
# Updates varobj named NAME and checks that all varobjs in EXPECTED
# are reported as updated, and no other varobj is updated.
# Assumes that no varobj is out of scope and that no varobj changes
# types.
proc mi_varobj_update { name expected testname } {
set er "\\^done,changelist=\\\["
set first 1
foreach item $expected {
set v "{name=\"$item\",in_scope=\"true\",type_changed=\"false\",has_more=\".\"}"
if {$first == 1} {
set er "$er$v"
set first 0
} else {
set er "$er,$v"
}
}
set er "$er\\\]"
verbose -log "Expecting: $er" 2
mi_gdb_test "-var-update $name" $er $testname
}
proc mi_varobj_update_with_child_type_change { name child_name new_type new_children testname } {
set v "{name=\"$child_name\",in_scope=\"true\",type_changed=\"true\",new_type=\"$new_type\",new_num_children=\"$new_children\",has_more=\".\"}"
set er "\\^done,changelist=\\\[$v\\\]"
verbose -log "Expecting: $er"
mi_gdb_test "-var-update $name" $er $testname
}
proc mi_varobj_update_with_type_change { name new_type new_children testname } {
mi_varobj_update_with_child_type_change $name $name $new_type $new_children $testname
}
# A helper that turns a key/value list into a regular expression
# matching some MI output.
proc mi_varobj_update_kv_helper {list} {
set first 1
set rx ""
foreach {key value} $list {
if {!$first} {
append rx ,
}
set first 0
if {$key == "new_children"} {
append rx "$key=\\\[$value\\\]"
} else {
append rx "$key=\"$value\""
}
}
return $rx
}
# A helper for mi_varobj_update_dynamic that computes a match
# expression given a child list.
proc mi_varobj_update_dynamic_helper {children} {
set crx ""
set first 1
foreach child $children {
if {!$first} {
append crx ,
}
set first 0
append crx "{"
append crx [mi_varobj_update_kv_helper $child]
append crx "}"
}
return $crx
}
# Update a dynamic varobj named NAME. CHILDREN is a list of children
# that have been updated; NEW_CHILDREN is a list of children that were
# added to the primary varobj. Each child is a list of key/value
# pairs that are expected. SELF is a key/value list holding
# information about the varobj itself. TESTNAME is the name of the
# test.
proc mi_varobj_update_dynamic {name testname self children new_children} {
if {[llength $new_children]} {
set newrx [mi_varobj_update_dynamic_helper $new_children]
lappend self new_children $newrx
}
set selfrx [mi_varobj_update_kv_helper $self]
set crx [mi_varobj_update_dynamic_helper $children]
set er "\\^done,changelist=\\\[\{name=\"$name\",in_scope=\"true\""
append er ",$selfrx\}"
if {"$crx" != ""} {
append er ",$crx"
}
append er "\\\]"
verbose -log "Expecting: $er"
mi_gdb_test "-var-update $name" $er $testname
}
proc mi_check_varobj_value { name value testname } {
mi_gdb_test "-var-evaluate-expression $name" \
"\\^done,value=\"$value\"" \
$testname
}
# Helper proc which constructs a child regexp for
# mi_list_varobj_children and mi_varobj_update_dynamic.
proc mi_child_regexp {children add_child} {
set children_exp {}
set whatever "\"\[^\"\]+\""
if {$add_child} {
set pre "child="
} else {
set pre ""
}
foreach item $children {
set name [lindex $item 0]
set exp [lindex $item 1]
set numchild [lindex $item 2]
if {[llength $item] == 5} {
set type [lindex $item 3]
set value [lindex $item 4]
lappend children_exp\
"$pre{name=\"$name\",exp=\"$exp\",numchild=\"$numchild\",value=\"$value\",type=\"$type\"\(,thread-id=\"\[0-9\]+\")?}"
} elseif {[llength $item] == 4} {
set type [lindex $item 3]
lappend children_exp\
"$pre{name=\"$name\",exp=\"$exp\",numchild=\"$numchild\",type=\"$type\"\(,thread-id=\"\[0-9\]+\")?}"
} else {
lappend children_exp\
"$pre{name=\"$name\",exp=\"$exp\",numchild=\"$numchild\"(,thread-id=\"\[0-9\]+\")?}"
}
}
return [join $children_exp ","]
}
# Check the results of the:
#
# -var-list-children VARNAME
#
# command. The CHILDREN parement should be a list of lists.
# Each inner list can have either 3 or 4 elements, describing
# fields that gdb is expected to report for child variable object,
# in the following order
#
# - Name
# - Expression
# - Number of children
# - Type
#
# If inner list has 3 elements, the gdb is expected to output no
# type for a child and no value.
#
# If the inner list has 4 elements, gdb output is expected to
# have no value.
#
proc mi_list_varobj_children { varname children testname } {
mi_list_varobj_children_range $varname "" "" [llength $children] $children \
$testname
}
# Like mi_list_varobj_children, but sets a subrange. NUMCHILDREN is
# the total number of children.
proc mi_list_varobj_children_range {varname from to numchildren children testname} {
set options ""
if {[llength $varname] == 2} {
set options [lindex $varname 1]
set varname [lindex $varname 0]
}
set whatever "\"\[^\"\]+\""
set children_exp_j [mi_child_regexp $children 1]
if {$numchildren} {
set expected "\\^done,numchild=\".*\",children=\\\[$children_exp_j.*\\\]"
} {
set expected "\\^done,numchild=\"0\""
}
if {"$to" == ""} {
append expected ",has_more=\"0\""
} elseif {$to >= 0 && $numchildren > $to} {
append expected ",has_more=\"1\""
} else {
append expected ",has_more=\"0\""
}
verbose -log "Expecting: $expected"
mi_gdb_test "-var-list-children $options $varname $from $to" \
$expected $testname
}
# Verifies that variable object VARNAME has NUMBER children,
# where each one is named $VARNAME.<index-of-child> and has type TYPE.
proc mi_list_array_varobj_children { varname number type testname } {
set t {}
for {set i 0} {$i < $number} {incr i} {
lappend t [list $varname.$i $i 0 $type]
}
mi_list_varobj_children $varname $t $testname
}
# A list of two-element lists. First element of each list is
# a Tcl statement, and the second element is the line
# number of source C file where the statement originates.
set mi_autotest_data ""
# The name of the source file for autotesting.
set mi_autotest_source ""
proc count_newlines { string } {
return [regexp -all "\n" $string]
}
# Prepares for running inline tests in FILENAME.
# See comments for mi_run_inline_test for detailed
# explanation of the idea and syntax.
proc mi_prepare_inline_tests { filename } {
global srcdir
global subdir
global mi_autotest_source
global mi_autotest_data
set mi_autotest_data {}
set mi_autotest_source $filename
if { ! [regexp "^/" "$filename"] } then {
set filename "$srcdir/$subdir/$filename"
}
set chan [open $filename]
set content [read $chan]
set line_number 1
while {1} {
set start [string first "/*:" $content]
if {$start != -1} {
set end [string first ":*/" $content]
if {$end == -1} {
error "Unterminated special comment in $filename"
}
set prefix [string range $content 0 $start]
set prefix_newlines [count_newlines $prefix]
set line_number [expr $line_number+$prefix_newlines]
set comment_line $line_number
set comment [string range $content [expr $start+3] [expr $end-1]]
set comment_newlines [count_newlines $comment]
set line_number [expr $line_number+$comment_newlines]
set comment [string trim $comment]
set content [string range $content [expr $end+3] \
[string length $content]]
lappend mi_autotest_data [list $comment $comment_line]
} else {
break
}
}
close $chan
}
# Helper to mi_run_inline_test below.
# Return the list of all (statement,line_number) lists
# that comprise TESTCASE. The begin and end markers
# are not included.
proc mi_get_inline_test {testcase} {
global mi_gdb_prompt
global mi_autotest_data
global mi_autotest_source
set result {}
set seen_begin 0
set seen_end 0
foreach l $mi_autotest_data {
set comment [lindex $l 0]
if {$comment == "BEGIN: $testcase"} {
set seen_begin 1
} elseif {$comment == "END: $testcase"} {
set seen_end 1
break
} elseif {$seen_begin==1} {
lappend result $l
}
}
if {$seen_begin == 0} {
error "Autotest $testcase not found"
}
if {$seen_begin == 1 && $seen_end == 0} {
error "Missing end marker for test $testcase"
}
return $result
}
# Sets temporary breakpoint at LOCATION.
proc mi_tbreak {location} {
global mi_gdb_prompt
mi_gdb_test "-break-insert -t $location" \
{\^done,bkpt=.*} \
"run to $location (set breakpoint)"
}
# Send COMMAND that must be a command that resumes
# the inferior (run/continue/next/etc) and consumes
# the "^running" output from it.
proc mi_send_resuming_command_raw {command test} {
global mi_gdb_prompt
global thread_selected_re
global library_loaded_re
send_gdb "$command\n"
gdb_expect {
-re "\\^running\r\n\\*running,thread-id=\"\[^\"\]+\"\r\n($library_loaded_re)*($thread_selected_re)?${mi_gdb_prompt}" {
# Note that lack of 'pass' call here -- this works around limitation
# in DejaGNU xfail mechanism. mi-until.exp has this:
#
# setup_kfail gdb/2104 "*-*-*"
# mi_execute_to ...
#
# and mi_execute_to uses mi_send_resuming_command. If we use 'pass' here,
# it will reset kfail, so when the actual test fails, it will be flagged
# as real failure.
return 0
}
-re "\\^error,msg=\"Displaced stepping is only supported in ARM mode\".*" {
unsupported "$test (Thumb mode)"
return -1
}
-re "\\^error,msg=.*" {
fail "$test (MI error)"
return -1
}
-re ".*${mi_gdb_prompt}" {
fail "$test (failed to resume)"
return -1
}
timeout {
fail "$test"
return -1
}
}
}
proc mi_send_resuming_command {command test} {
mi_send_resuming_command_raw -$command $test
}
# Helper to mi_run_inline_test below.
# Sets a temporary breakpoint at LOCATION and runs
# the program using COMMAND. When the program is stopped
# returns the line at which it. Returns -1 if line cannot
# be determined.
# Does not check that the line is the same as requested.
# The caller can check itself if required.
proc mi_continue_to_line {location test} {
mi_tbreak $location
mi_send_resuming_command "exec-continue" "run to $location (exec-continue)"
return [mi_get_stop_line $test]
}
# Wait until gdb prints the current line.
proc mi_get_stop_line {test} {
global mi_gdb_prompt
global async
if {$async} {
set prompt_re ""
} else {
set prompt_re "$mi_gdb_prompt$"
}
gdb_expect {
-re ".*line=\"(\[0-9\]*)\".*\r\n$prompt_re" {
return $expect_out(1,string)
}
-re ".*$mi_gdb_prompt" {
fail "wait for stop ($test)"
}
timeout {
fail "wait for stop ($test)"
}
}
}
# Run a MI test embedded in comments in a C file.
# The C file should contain special comments in the following
# three forms:
#
# /*: BEGIN: testname :*/
# /*: <Tcl statements> :*/
# /*: END: testname :*/
#
# This procedure find the begin and end marker for the requested
# test. Then, a temporary breakpoint is set at the begin
# marker and the program is run (from start).
#
# After that, for each special comment between the begin and end
# marker, the Tcl statements are executed. It is assumed that
# for each comment, the immediately preceding line is executable
# C statement. Then, gdb will be single-stepped until that
# preceding C statement is executed, and after that the
# Tcl statements in the comment will be executed.
#
# For example:
#
# /*: BEGIN: assignment-test :*/
# v = 10;
# /*: <Tcl code to check that 'v' is indeed 10 :*/
# /*: END: assignment-test :*/
#
# The mi_prepare_inline_tests function should be called before
# calling this function. A given C file can contain several
# inline tests. The names of the tests must be unique within one
# C file.
#
proc mi_run_inline_test { testcase } {
global mi_gdb_prompt
global hex
global decimal
global fullname_syntax
global mi_autotest_source
set commands [mi_get_inline_test $testcase]
set first 1
set line_now 1
foreach c $commands {
set statements [lindex $c 0]
set line [lindex $c 1]
set line [expr $line-1]
# We want gdb to be stopped at the expression immediately
# before the comment. If this is the first comment, the
# program is either not started yet or is in some random place,
# so we run it. For further comments, we might be already
# standing at the right line. If not continue till the
# right line.
if {$first==1} {
# Start the program afresh.
mi_tbreak "$mi_autotest_source:$line"
mi_run_cmd
set line_now [mi_get_stop_line "$testcase: step to $line"]
set first 0
} elseif {$line_now!=$line} {
set line_now [mi_continue_to_line "$mi_autotest_source:$line" "continue to $line"]
}
if {$line_now!=$line} {
fail "$testcase: go to line $line"
}
# We're not at the statement right above the comment.
# Execute that statement so that the comment can test
# the state after the statement is executed.
# Single-step past the line.
if { [mi_send_resuming_command "exec-next" "$testcase: step over $line"] != 0 } {
return -1
}
set line_now [mi_get_stop_line "$testcase: step over $line"]
# We probably want to use 'uplevel' so that statements
# have direct access to global variables that the
# main 'exp' file has set up. But it's not yet clear,
# will need more experience to be sure.
eval $statements
}
}
proc get_mi_thread_list {name} {
global expect_out
# MI will return a list of thread ids:
#
# -thread-list-ids
# ^done,thread-ids=[thread-id="1",thread-id="2",...],number-of-threads="N"
# (gdb)
mi_gdb_test "-thread-list-ids" \
{.*\^done,thread-ids={(thread-id="[0-9]+"(,)?)+},current-thread-id="[0-9]+",number-of-threads="[0-9]+"} \
"-thread_list_ids ($name)"
set output {}
if {[info exists expect_out(buffer)]} {
set output $expect_out(buffer)
}
set thread_list {}
if {![regexp {thread-ids=\{(thread-id="[0-9]+"(,)?)*\}} $output threads]} {
fail "finding threads in MI output ($name)"
} else {
pass "finding threads in MI output ($name)"
# Make list of console threads
set start [expr {[string first \{ $threads] + 1}]
set end [expr {[string first \} $threads] - 1}]
set threads [string range $threads $start $end]
foreach thread [split $threads ,] {
if {[scan $thread {thread-id="%d"} num]} {
lappend thread_list $num
}
}
}
return $thread_list
}
# Check that MI and the console know of the same threads.
# Appends NAME to all test names.
proc check_mi_and_console_threads {name} {
global expect_out
mi_gdb_test "-thread-list-ids" \
{.*\^done,thread-ids={(thread-id="[0-9]+"(,)*)+},current-thread-id="[0-9]+",number-of-threads="[0-9]+"} \
"-thread-list-ids ($name)"
set mi_output {}
if {[info exists expect_out(buffer)]} {
set mi_output $expect_out(buffer)
}
# GDB will return a list of thread ids and some more info:
#
# (gdb)
# -interpreter-exec console "info threads"
# ~" 4 Thread 2051 (LWP 7734) 0x401166b1 in __libc_nanosleep () at __libc_nanosleep:-1"
# ~" 3 Thread 1026 (LWP 7733) () at __libc_nanosleep:-1"
# ~" 2 Thread 2049 (LWP 7732) 0x401411f8 in __poll (fds=0x804bb24, nfds=1, timeout=2000) at ../sysdeps/unix/sysv/linux/poll.c:63"
# ~"* 1 Thread 1024 (LWP 7731) main (argc=1, argv=0xbfffdd94) at ../../../src/gdb/testsuite/gdb.mi/pthreads.c:160"
# FIXME: kseitz/2002-09-05: Don't use the hack-cli method.
mi_gdb_test "info threads" \
{.*(~".*"[\r\n]*)+.*} \
"info threads ($name)"
set console_output {}
if {[info exists expect_out(buffer)]} {
set console_output $expect_out(buffer)
}
# Make a list of all known threads to console (gdb's thread IDs)
set console_thread_list {}
foreach line [split $console_output \n] {
if {[string index $line 0] == "~"} {
# This is a line from the console; trim off "~", " ", "*", and "\""
set line [string trim $line ~\ \"\*]
if {[scan $line "%d" id] == 1} {
lappend console_thread_list $id
}
}
}
# Now find the result string from MI
set mi_result ""
foreach line [split $mi_output \n] {
if {[string range $line 0 4] == "^done"} {
set mi_result $line
}
}
if {$mi_result == ""} {
fail "finding MI result string ($name)"
} else {
pass "finding MI result string ($name)"
}
# Finally, extract the thread ids and compare them to the console
set num_mi_threads_str ""
if {![regexp {number-of-threads="[0-9]+"} $mi_result num_mi_threads_str]} {
fail "finding number of threads in MI output ($name)"
} else {
pass "finding number of threads in MI output ($name)"
# Extract the number of threads from the MI result
if {![scan $num_mi_threads_str {number-of-threads="%d"} num_mi_threads]} {
fail "got number of threads from MI ($name)"
} else {
pass "got number of threads from MI ($name)"
# Check if MI and console have same number of threads
if {$num_mi_threads != [llength $console_thread_list]} {
fail "console and MI have same number of threads ($name)"
} else {
pass "console and MI have same number of threads ($name)"
# Get MI thread list
set mi_thread_list [get_mi_thread_list $name]
# Check if MI and console have the same threads
set fails 0
foreach ct [lsort $console_thread_list] mt [lsort $mi_thread_list] {
if {$ct != $mt} {
incr fails
}
}
if {$fails > 0} {
fail "MI and console have same threads ($name)"
# Send a list of failures to the log
send_log "Console has thread ids: $console_thread_list\n"
send_log "MI has thread ids: $mi_thread_list\n"
} else {
pass "MI and console have same threads ($name)"
}
}
}
}
}
# Download shared libraries to the target.
proc mi_load_shlibs { args } {
if {![is_remote target]} {
return
}
foreach file $args {
gdb_download [shlib_target_file $file]
}
# Even if the target supplies full paths for shared libraries,
# they may not be paths for this system.
mi_gdb_test "set solib-search-path [file dirname [lindex $args 0]]" "\^done" ""
}
proc mi_reverse_list { list } {
if { [llength $list] <= 1 } {
return $list
}
set tail [lrange $list 1 [llength $list]]
set rtail [mi_reverse_list $tail]
lappend rtail [lindex $list 0]
return $rtail
}
proc mi_check_thread_states { xstates test } {
global expect_out
set states [mi_reverse_list $xstates]
set pattern ".*\\^done,threads=\\\["
foreach s $states {
set pattern "${pattern}(.*)state=\"$s\""
}
set pattern "${pattern}(,core=\"\[0-9\]*\")?\\\}\\\].*"
verbose -log "expecting: $pattern"
mi_gdb_test "-thread-info" $pattern $test
}
# Return a list of MI features supported by this gdb.
proc mi_get_features {} {
global expect_out mi_gdb_prompt
send_gdb "-list-features\n"
gdb_expect {
-re "\\^done,features=\\\[(.*)\\\]\r\n$mi_gdb_prompt$" {
regsub -all -- \" $expect_out(1,string) "" features
return [split $features ,]
}
-re ".*\r\n$mi_gdb_prompt$" {
verbose -log "got $expect_out(buffer)"
return ""
}
timeout {
verbose -log "timeout in mi_gdb_prompt"
return ""
}
}
}
# Variable Object Trees
#
# Yet another way to check varobjs. Pass mi_walk_varobj_tree a "list" of
# variables (not unlike the actual source code definition), and it will
# automagically test the children for you (by default).
#
# Example:
#
# source code:
# struct bar {
# union {
# int integer;
# void *ptr;
# };
# const int *iPtr;
# };
#
# class foo {
# public:
# int a;
# struct {
# int b;
# struct bar *c;
# };
# };
#
# foo *f = new foo (); <-- break here
#
# We want to check all the children of "f".
#
# Translate the above structures into the following tree:
#
# set tree {
# foo f {
# {} public {
# int a {}
# anonymous struct {
# {} public {
# int b {}
# {bar *} c {
# {} public {
# anonymous union {
# {} public {
# int integer {}
# {void *} ptr {}
# }
# }
# {const int *} iPtr {
# {const int} {*iPtr} {}
# }
# }
# }
# }
# }
# }
# }
# }
#
# mi_walk_varobj_tree c++ $tree
#
# If you'd prefer to walk the tree using your own callback,
# simply pass the name of the callback to mi_walk_varobj_tree.
#
# This callback should take one argument, the name of the variable
# to process. This name is the name of a global array holding the
# variable's properties (object name, type, etc).
#
# An example callback:
#
# proc my_callback {var} {
# upvar #0 $var varobj
#
# puts "my_callback: called on varobj $varobj(obj_name)"
# }
#
# The arrays created for each variable object contain the following
# members:
#
# obj_name - the object name for accessing this variable via MI
# display_name - the display name for this variable (exp="display_name" in
# the output of -var-list-children)
# type - the type of this variable (type="type" in the output
# of -var-list-children, or the special tag "anonymous"
# path_expr - the "-var-info-path-expression" for this variable
# NOTE: This member cannot be used reliably with typedefs.
# Use with caution!
# See notes inside get_path_expr for more.
# parent - the variable name of the parent varobj
# children - a list of children variable names (which are the
# names Tcl arrays, not object names)
#
# For each variable object, an array containing the above fields will
# be created under the root node (conveniently called, "root"). For example,
# a variable object with handle "OBJ.public.0_anonymous.a" will have
# a corresponding global Tcl variable named "root.OBJ.public.0_anonymous.a".
#
# Note that right now, this mechanism cannot be used for recursive data
# structures like linked lists.
namespace eval ::varobj_tree {
# An index which is appended to root varobjs to ensure uniqueness.
variable _root_idx 0
# A procedure to help with debuggging varobj trees.
# VARIABLE_NAME is the name of the variable to dump.
# CMD, if present, is the name of the callback to output the contstructed
# strings. By default, it uses expect's "send_log" command.
# TERM, if present, is a terminating character. By default it is the newline.
#
# To output to the terminal (not the expect log), use
# mi_varobj_tree_dump_variable my_variable puts ""
proc mi_varobj_tree_dump_variable {variable_name {cmd send_log} {term "\n"}} {
upvar #0 $variable_name varobj
eval "$cmd \"VAR = $variable_name$term\""
# Explicitly encode the array indices, since outputting them
# in some logical order is better than what "array names" might
# return.
foreach idx {obj_name parent display_name type path_expr} {
eval "$cmd \"\t$idx = $varobj($idx)$term\""
}
# Output children
set num [llength $varobj(children)]
eval "$cmd \"\tnum_children = $num$term\""
if {$num > 0} {
eval "$cmd \"\tchildren = $varobj(children)$term\""
}
}
# The default callback used by mi_walk_varobj_tree. This callback
# simply checks all of VAR's children. It specifically does not test
# path expressions, since that is very problematic.
#
# This procedure may be used in custom callbacks.
proc test_children_callback {variable_name} {
upvar #0 $variable_name varobj
if {[llength $varobj(children)] > 0} {
# Construct the list of children the way mi_list_varobj_children
# expects to get it:
# { {obj_name display_name num_children type} ... }
set children_list {}
foreach child $varobj(children) {
upvar #0 $child c
set clist [list [string_to_regexp $c(obj_name)] \
[string_to_regexp $c(display_name)] \
[llength $c(children)]]
if {[string length $c(type)] > 0} {
lappend clist [string_to_regexp $c(type)]
}
lappend children_list $clist
}
mi_list_varobj_children $varobj(obj_name) $children_list \
"VT: list children of $varobj(obj_name)"
}
}
# Set the properties of the varobj represented by
# PARENT_VARIABLE - the name of the parent's variable
# OBJNAME - the MI object name of this variable
# DISP_NAME - the display name of this variable
# TYPE - the type of this variable
# PATH - the path expression for this variable
# CHILDREN - a list of the variable's children
proc create_varobj {parent_variable objname disp_name \
type path children} {
upvar #0 $parent_variable parent
set var_name "root.$objname"
global $var_name
array set $var_name [list obj_name $objname]
array set $var_name [list display_name $disp_name]
array set $var_name [list type $type]
array set $var_name [list path_expr $path]
array set $var_name [list parent "$parent_variable"]
array set $var_name [list children \
[get_tree_children $var_name $children]]
return $var_name
}
# Should VARIABLE be used in path expressions? The CPLUS_FAKE_CHILD
# varobjs and anonymous structs/unions are not used for path expressions.
proc is_path_expr_parent {variable} {
upvar #0 $variable varobj
# If the varobj's type is "", it is a CPLUS_FAKE_CHILD.
# If the tail of the varobj's object name is "%d_anonymous",
# then it represents an anonymous struct or union.
if {[string length $varobj(type)] == 0 \
|| [regexp {[0-9]+_anonymous$} $varobj(obj_name)]} {
return false
}
return true
}
# Return the path expression for the variable named NAME in
# parent varobj whose variable name is given by PARENT_VARIABLE.
proc get_path_expr {parent_variable name type} {
upvar #0 $parent_variable parent
upvar #0 $parent_variable path_parent
# If TYPE is "", this is one of the CPLUS_FAKE_CHILD varobjs,
# which has no path expression. Likewsise for anonymous structs
# and unions.
if {[string length $type] == 0 \
|| [string compare $type "anonymous"] == 0} {
return ""
}
# Find the path parent variable.
while {![is_path_expr_parent $parent_variable]} {
set parent_variable $path_parent(parent)
upvar #0 $parent_variable path_parent
}
# This is where things get difficult. We do not actually know
# the real type for variables defined via typedefs, so we don't actually
# know whether the parent is a structure/union or not.
#
# So we assume everything that isn't a simple type is a compound type.
set stars ""
regexp {\*+} $parent(type) stars
set is_compound 1
if {[string index $name 0] == "*"} {
set is_compound 0
}
if {[string index $parent(type) end] == "\]"} {
# Parent is an array.
return "($path_parent(path_expr))\[$name\]"
} elseif {$is_compound} {
# Parent is a structure or union or a pointer to one.
if {[string length $stars]} {
set join "->"
} else {
set join "."
}
global root
# To make matters even more hideous, varobj.c has slightly different
# path expressions for C and C++.
set path_expr "($path_parent(path_expr))$join$name"
if {[string compare -nocase $root(language) "c"] == 0} {
return $path_expr
} else {
return "($path_expr)"
}
} else {
# Parent is a pointer.
return "*($path_parent(path_expr))"
}
}
# Process the CHILDREN (a list of varobj_tree elements) of the variable
# given by PARENT_VARIABLE. Returns a list of children variables.
proc get_tree_children {parent_variable children} {
upvar #0 $parent_variable parent
set field_idx 0
set children_list {}
foreach {type name children} $children {
if {[string compare $parent_variable "root"] == 0} {
# Root variable
variable _root_idx
incr _root_idx
set objname "$name$_root_idx"
set disp_name "$name"
set path_expr "$name"
} elseif {[string compare $type "anonymous"] == 0} {
# Special case: anonymous types. In this case, NAME will either be
# "struct" or "union".
set objname "$parent(obj_name).${field_idx}_anonymous"
set disp_name "<anonymous $name>"
set path_expr ""
set type "$name {...}"
} else {
set objname "$parent(obj_name).$name"
set disp_name $name
set path_expr [get_path_expr $parent_variable $name $type]
}
lappend children_list [create_varobj $parent_variable $objname \
$disp_name $type $path_expr $children]
incr field_idx
}
return $children_list
}
# The main procedure to call the given CALLBACK on the elements of the
# given varobj TREE. See detailed explanation above.
proc walk_tree {language tree callback} {
global root
if {[llength $tree] < 3} {
error "tree does not contain enough elements"
}
# Create root node and process the tree.
array set root [list language $language]
array set root [list obj_name "root"]
array set root [list display_name "root"]
array set root [list type "root"]
array set root [list path_expr "root"]
array set root [list parent "root"]
array set root [list children [get_tree_children root $tree]]
# Walk the tree
set all_nodes $root(children); # a stack of nodes
while {[llength $all_nodes] > 0} {
# "Pop" the name of the global variable containing this varobj's
# information from the stack of nodes.
set var_name [lindex $all_nodes 0]
set all_nodes [lreplace $all_nodes 0 0]
# Bring the global named in VAR_NAME into scope as the local variable
# VAROBJ.
upvar #0 $var_name varobj
# Append any children of VAROBJ to the list of nodes to walk.
if {[llength $varobj(children)] > 0} {
set all_nodes [concat $all_nodes $varobj(children)]
}
# If this is a root variable, create the variable object for it.
if {[string compare $varobj(parent) "root"] == 0} {
mi_create_varobj $varobj(obj_name) $varobj(display_name) \
"VT: create root varobj for $varobj(display_name)"
}
# Now call the callback for VAROBJ.
uplevel #0 $callback $var_name
}
}
}
# The default varobj tree callback, which simply tests -var-list-children.
proc mi_varobj_tree_test_children_callback {variable} {
::varobj_tree::test_children_callback $variable
}
# Walk the variable object tree given by TREE, calling the specified
# CALLBACK. By default this uses mi_varobj_tree_test_children_callback.
proc mi_walk_varobj_tree {language tree \
{callback \
mi_varobj_tree_test_children_callback}} {
::varobj_tree::walk_tree $language $tree $callback
}
Reference in New Issue View Git Blame Copy Permalink