-# Copyright 1999, 2000, 2002, 2003, 2004, 2005, 2007, 2008
-# Free Software Foundation, Inc.
+# 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
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
-# Please email any bugs, comments, and/or additions to this file to:
-# bug-gdb@prep.ai.mit.edu
-
# This file was based on a file written by Fred Fish. (fnf@cygnus.com)
# Test setup routines that work with the MI interpreter.
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_uncatched_gdb_exit {} {
global GDB
- global GDBFLAGS
+ global INTERNAL_GDBFLAGS GDBFLAGS
global verbose
global gdb_spawn_id;
global gdb_prompt
return;
}
- verbose "Quitting $GDB $GDBFLAGS $MIFLAGS"
+ verbose "Quitting $GDB $INTERNAL_GDBFLAGS $GDBFLAGS $MIFLAGS"
if { [is_remote host] && [board_info host exists fileid] } {
send_gdb "999-gdb-exit\n";
# get really slow. Give gdb at least 3 minutes to start up.
#
proc default_mi_gdb_start { args } {
- global verbose
+ global verbose use_gdb_stub
global GDB
- global GDBFLAGS
+ global INTERNAL_GDBFLAGS GDBFLAGS
global gdb_prompt
global mi_gdb_prompt
global timeout
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]
}
sid_start
}
- verbose "Spawning $GDB -nw $GDBFLAGS $MIFLAGS"
+ verbose "Spawning $GDB $INTERNAL_GDBFLAGS $GDBFLAGS $MIFLAGS"
if [info exists gdb_spawn_id] {
return 0;
set mi_inferior_tty_name $spawn_out(slave,name)
}
- set res [remote_spawn host "$GDB -nw $GDBFLAGS $MIFLAGS [host_info gdb_opts]"];
+ set res [remote_spawn host "$GDB $INTERNAL_GDBFLAGS $GDBFLAGS $MIFLAGS [host_info gdb_opts]"];
if { $res < 0 || $res == "" } {
perror "Spawning $GDB failed."
return 1;
}
}
- detect_async
+ mi_detect_async
return 0;
}
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$" {
+ -re "47\\^connected.*$mi_gdb_prompt" {
verbose "Set target to $targetname";
return 0;
}
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.";
}
global loadfile
global GDB
global mi_gdb_prompt
- upvar timeout timeout
+
+ 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" ".*" ""
-re ".*$mi_gdb_prompt$"
}
send_target_sid
- gdb_expect 60 {
+ gdb_expect $loadtimeout {
-re "\\^done.*$mi_gdb_prompt$" {
}
timeout {
- perror "Unable to connect to SID target"
+ perror "Unable to connect to SID target (timeout)"
return -1
}
}
send_gdb "48-target-download\n"
- gdb_expect 10 {
+ gdb_expect $loadtimeout {
-re "48\\^done.*$mi_gdb_prompt$" {
}
timeout {
- perror "Unable to download to SID target"
+ 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 10 {
+ gdb_expect $loadtimeout {
-re "47\\^connected.*$mi_gdb_prompt$" {
}
timeout {
- perror "Unable to select sim target"
+ perror "Unable to select sim target (timeout)"
return -1
}
}
send_gdb "48-target-download\n"
- gdb_expect 10 {
+ gdb_expect $loadtimeout {
-re "48\\^done.*$mi_gdb_prompt$" {
}
timeout {
- perror "Unable to download to sim target"
+ perror "Unable to download to sim target (timeout)"
return -1
}
}
return -1
}
send_gdb "48-target-download\n"
- gdb_expect 10 {
+ gdb_expect $loadtimeout {
-re "48\\^done.*$mi_gdb_prompt$" {
}
timeout {
- perror "Unable to download to remote target"
+ perror "Unable to download to remote target (timeout)"
return -1
}
}
global verbose
global mi_gdb_prompt
global GDB expect_out
+ global inferior_exited_re async
upvar timeout timeout
set command [lindex $args 0]
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.*" {
fail "$message"
set result 1
}
- -re "Program exited with code \[0-9\]+.*$mi_gdb_prompt\[ \]*$" {
+ -re "$inferior_exited_re with code \[0-9\]+.*$mi_gdb_prompt\[ \]*$" {
if ![string match "" $message] then {
set errmsg "$message (the program exited)"
} else {
# 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 {args} {
+proc mi_run_cmd_full {use_mi_command args} {
global suppress_flag
if { $suppress_flag } {
return -1
}
- global mi_gdb_prompt
+ 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";
-re "$mi_gdb_prompt$" { }
default {
perror "gdb_init_command for target failed";
- return;
+ return -1;
}
}
}
if { [mi_gdb_target_load] < 0 } {
- return
+ return -1
}
- if [target_info exists use_gdb_stub] {
+ if $use_gdb_stub {
if [target_info exists gdb,do_reload_on_run] {
- send_gdb "220-exec-continue\n";
+ send_gdb "${run_prefix}continue\n";
gdb_expect 60 {
- -re "220\\^running\[\r\n\]+\\*running,thread-id=\"\[^\"\]+\"\r\n$mi_gdb_prompt$" {}
+ -re "${run_match}\\^running\[\r\n\]+\\*running,thread-id=\"\[^\"\]+\"\r\n$mi_gdb_prompt" {}
default {}
}
- return;
+ return 0;
}
if [target_info exists gdb,start_symbol] {
# to better handle RUN.
send_gdb "jump *$start\n"
warning "Using CLI jump command, expect run-to-main FAIL"
- return
+ return 0
}
- send_gdb "220-exec-run $args\n"
+ send_gdb "${run_prefix}run $args\n"
gdb_expect {
- -re "220\\^running\r\n(\\*running,thread-id=\"\[^\"\]+\"\r\n|=thread-created,id=\"1\"\r\n)*${mi_gdb_prompt}" {
+ -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
+ 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]
}
#
}
if {$run_or_continue == "run"} {
- mi_run_cmd
+ if { [mi_run_cmd] < 0 } {
+ return -1
+ }
} else {
mi_send_resuming_command "exec-continue" "$test"
}
}
proc mi_runto {func} {
- mi_runto_helper $func "run"
+ return [mi_runto_helper $func "run"]
}
# Next to the next statement
set async "unknown"
-proc detect_async {} {
+proc mi_detect_async {} {
global async
global mi_gdb_prompt
- send_gdb "maint show linux-async\n"
+ send_gdb "show target-async\n"
gdb_expect {
- -re ".*Controlling the GNU/Linux inferior in asynchronous mode is on...*$mi_gdb_prompt$" {
+ -re ".*Controlling the inferior in asynchronous mode is on...*$mi_gdb_prompt$" {
set async 1
}
-re ".*$mi_gdb_prompt$" {
# 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. ARGS should
-# not include [] the list of argument is enclosed in, and other
-# regular expressions should not include quotes.
+# 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
# 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. 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 .* regexp for line, and then check the line programmatically.
+# 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 decimal
global fullname_syntax
global async
+ global thread_selected_re
+ global breakpoint_re
set after_stopped ""
set after_reason ""
if {$async} {
set prompt_re ""
} else {
- set prompt_re "$mi_gdb_prompt"
+ set prompt_re "$mi_gdb_prompt$"
}
if { $reason == "really-no-reason" } {
gdb_expect {
- -re "\\*stopped\r\n$prompt_re$" {
+ -re "\\*stopped\r\n$prompt_re" {
pass "$test"
}
timeout {
if { $reason == "exited-normally" } {
gdb_expect {
- -re "\\*stopped,reason=\"exited-normally\"\r\n$prompt_re$" {
+ -re "\\*stopped,reason=\"exited-normally\"\r\n$prompt_re" {
pass "$test"
}
-re ".*$mi_gdb_prompt$" {fail "continue to end (2)"}
set bn ""
if { $reason == "breakpoint-hit" } {
set bn {bkptno="[0-9]+",}
+ } elseif { $reason == "solib-event" } {
+ set bn ".*"
}
set r ""
set a $after_reason
- verbose -log "mi_expect_stop: expecting: \\*stopped,${r}${a}${bn}thread-id=\"$decimal\",stopped-threads=.*,frame=\{addr=\"$hex\",func=\"$func\",args=$args,file=\".*$file\",fullname=\"${fullname_syntax}$file\",line=\"$line\"\}$after_stopped\r\n$prompt_re$"
+ 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}thread-id=\"$decimal\",stopped-threads=.*,frame=\{addr=\"$hex\",func=\"$func\",args=$args,file=\".*$file\",fullname=\"${fullname_syntax}$file\",line=\"($line)\"\}$after_stopped\r\n$prompt_re$" {
+ -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"
- return $expect_out(2,string)
+ 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}thread-id=\"$decimal\",stopped-threads=.*,frame=\{addr=\"$hex\",func=\".*\",args=\[\\\[\{\].*\[\\\]\}\],file=\".*\",fullname=\"${fullname_syntax}.*\",line=\"\[0-9\]*\"\}.*\r\n$prompt_re$" {
+ -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
}
}
}
+# 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"
set body ""
set first 1
- foreach item $children {
+ foreach item $expected {
if {$first == 0} {
set body "$body,"
+ set first 0
}
- set number disp func file line address
set number [lindex $item 0]
set disp [lindex $item 1]
set func [lindex $item 2]
- set line [lindex $item 3]
- set address [lindex $item 4]
- set body "$body,bkpt=\{number=\"$number\",type=\"breakpoint\",disp=\"$disp\",enabled=\"y\",addr=\"$address\",func=\"$func\",file=\"$file\",${fullname},line=\"$line\",times=\"0\",original-location=\".*\"\}"
+ 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\",times=\"0\",original-location=\".*\"\}"
set first 0
}
- verbose -log "Expecint: 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\\\]\}" \
+ 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
# 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=.*" \
+ "\\^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=\"\[0-9\]+\",value=\".*\",type=.*" \
+ "\\^done,name=\"$name\",numchild=\"\(-1\|\[0-9\]+\)\",value=\".*\",type=.*" \
$testname
}
$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" \
set er "\\^done,changelist=\\\["
set first 1
foreach item $expected {
- set v "{name=\"$item\",in_scope=\"true\",type_changed=\"false\"}"
+ set v "{name=\"$item\",in_scope=\"true\",type_changed=\"false\",has_more=\".\"}"
if {$first == 1} {
set er "$er$v"
set first 0
mi_gdb_test "-var-update $name" $er $testname
}
-proc mi_varobj_update_with_type_change { name new_type new_children testname } {
- set v "{name=\"$name\",in_scope=\"true\",type_changed=\"true\",new_type=\"$new_type\",new_num_children=\"$new_children\"}"
+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" \
$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
# 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 numchildren [llength $children]
- set children_exp {}
set whatever "\"\[^\"\]+\""
- 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\
- "child={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\
- "child={name=\"$name\",exp=\"$exp\",numchild=\"$numchild\",type=\"$type\"\(,thread-id=\"\[0-9\]+\")?}"
- } else {
- lappend children_exp\
- "child={name=\"$name\",exp=\"$exp\",numchild=\"$numchild\"(,thread-id=\"\[0-9\]+\")?}"
- }
- }
- set children_exp_j [join $children_exp ","]
+ 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" $expected $testname
+ mi_gdb_test "-var-list-children $options $varname $from $to" \
+ $expected $testname
}
# Verifies that variable object VARNAME has NUMBER children,
}
# Send COMMAND that must be a command that resumes
-# the inferiour (run/continue/next/etc) and consumes
+# 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${mi_gdb_prompt}" {
+ -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:
#
# 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 ".*${mi_gdb_prompt}" {
- fail "$test (failed to resume)"
+ -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
if {$async} {
set prompt_re ""
} else {
- set prompt_re "$mi_gdb_prompt"
+ set prompt_re "$mi_gdb_prompt$"
}
gdb_expect {
- -re ".*line=\"(.*)\".*\r\n$prompt_re$" {
+ -re ".*line=\"(\[0-9\]*)\".*\r\n$prompt_re" {
return $expect_out(1,string)
}
- -re ".*$mi_gdb_prompt$" {
+ -re ".*$mi_gdb_prompt" {
fail "wait for stop ($test)"
}
timeout {
# the state after the statement is executed.
# Single-step past the line.
- mi_send_resuming_command "exec-next" "$testcase: step over $line"
- set line_now [mi_get_stop_line "$testcase: step over $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
# ^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]+"(,)?)+},number-of-threads="[0-9]+"} \
+ {.*\^done,thread-ids={(thread-id="[0-9]+"(,)?)+},current-thread-id="[0-9]+",number-of-threads="[0-9]+"} \
"-thread_list_ids ($name)"
set output {}
global expect_out
mi_gdb_test "-thread-list-ids" \
- {.*\^done,thread-ids={(thread-id="[0-9]+"(,)*)+},number-of-threads="[0-9]+"} \
+ {.*\^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)]} {
}
}
}
+
+# 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
+}
projects / thirdparty / binutils-gdb.git / blobdiff