-# Copyright 1999, 2000, 2002, 2003, 2004, 2005, 2007
-# 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
-# the Free Software Foundation; either version 2 of the License, or
+# 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, write to the Free Software
-# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-# Please email any bugs, comments, and/or additions to this file to:
-# bug-gdb@prep.ai.mit.edu
+# 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)
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";
}
#
-# mi_gdb_start [INFERIOR_PTY] -- start gdb running, default procedure
+# 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.
# tests on different hosts all using the same server, things can
# get really slow. Give gdb at least 3 minutes to start up.
#
-proc mi_gdb_start { args } {
- global verbose
+proc default_mi_gdb_start { args } {
+ 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;
}
verbose "GDB initialized."
}
- -re ".*$gdb_prompt $" {
- untested "Skip mi tests (got non-mi prompt)."
- remote_close host;
- return -1;
- }
-re ".*unrecognized option.*for a complete list of options." {
untested "Skip mi tests (not compiled with mi support)."
remote_close host;
}
}
+ 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
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=\\\[\\\]\}" {}
+ -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.*$" {
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$" {
+ -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";
}
verbose "Set target to $targetname";
return 0;
}
- -re "Remote debugging using .*$serialport.*$mi_gdb_prompt$" {
+ -re "Remote debugging using .*$serialport_re.*$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" ".*" ""
set res [gdbserver_gdb_load]
set protocol [lindex $res 0]
set gdbport [lindex $res 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 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.*" {
if { $message != "" } {
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 {
# If the GDB output matched, compare the inferior output.
if { $result == 0 } {
if [ info exists ipattern ] {
- global mi_inferior_spawn_id
- expect {
- -i $mi_inferior_spawn_id -re "$ipattern" {
- pass "inferior_output:$message"
- }
- timeout {
- fail "inferior output timeout"
- set result 1
+ 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"
}
}
}
# 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 "000-exec-continue\n";
+ send_gdb "${run_prefix}continue\n";
gdb_expect 60 {
- -re "000\\^running\[\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 "000-exec-run $args\n"
+ send_gdb "${run_prefix}run $args\n"
gdb_expect {
- -re "000\\^running\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]
}
#
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\]*\",times=\"0\"\}" \
+ "200\\^done,bkpt=\{number=\"\[0-9\]+\",type=\"breakpoint\",disp=\"del\",enabled=\"y\",addr=\"$hex\",func=\"$func\(\\\(.*\\\)\)?\",file=\".*\",line=\"\[0-9\]*\",times=\"0\",original-location=\".*\"\}" \
"breakpoint at $func"
if {![regexp {number="[0-9]+"} $expect_out(buffer) str]
}
if {$run_or_continue == "run"} {
- mi_run_cmd
- } else {
- send_gdb "000-exec-continue\n"
- gdb_expect {
- -re "000\\^running\r\n${mi_gdb_prompt}" {
- }
- timeout {
- fail "$test"
- return -1
- }
+ if { [mi_run_cmd] < 0 } {
+ return -1
}
+ } else {
+ mi_send_resuming_command "exec-continue" "$test"
}
- gdb_expect {
- -re ".*000\\*stopped,thread-id=\"$decimal\",frame=\{addr=\"$hex\",func=\"$func\",args=\(\\\[.*\\\]\|\{.*\}\),file=\".*\",fullname=\"${fullname_syntax}.*\",line=\"\[0-9\]*\"\}\r\n$mi_gdb_prompt$" {
- pass "$test"
- return 0
- }
- -re ".*$mi_gdb_prompt$" {
- fail "$test (2)"
- }
- timeout {
- fail "$test (timeout)"
- return -1
- }
- }
+ mi_expect_stop "breakpoint-hit" $func ".*" ".*" "\[0-9\]+" { "" "disp=\"del\"" } $test
}
proc mi_runto {func} {
- mi_runto_helper $func "run"
+ return [mi_runto_helper $func "run"]
}
# Next to the next statement
return [mi_step_to {.*} {.*} {.*} {.*} $test]
}
-# cmd should not include the number or newline (i.e. "exec-step 3", not
-# "220-exec-step 3\n"
+set async "unknown"
-# Can not match -re ".*\r\n${mi_gdb_prompt}", because of false positives
-# after the first prompt is printed.
+proc mi_detect_async {} {
+ global async
+ global mi_gdb_prompt
-proc mi_execute_to_helper { cmd reason func args file line extra test } {
- global suppress_flag
- if { $suppress_flag } {
- return -1
+ 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
- send_gdb "220-$cmd\n"
+ 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 "220\\^running\r\n${mi_gdb_prompt}.*220\\*stopped,reason=\"$reason\",thread-id=\"$decimal\",frame=\{addr=\"$hex\",func=\"$func\",args=$args,file=\".*$file\",fullname=\"${fullname_syntax}$file\",line=\"$line\"\}$extra\r\n$mi_gdb_prompt$" {
+ -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 "220\\^running\r\n${mi_gdb_prompt}.*220\\*stopped,reason=\"$reason\",thread-id=\"$decimal\",frame=\{addr=\"$hex\",func=\".*\",args=\[\\\[\{\].*\[\\\]\}\],file=\".*\",fullname=\"${fullname_syntax}.*\",line=\"\[0-9\]*\"\}.*\r\n$mi_gdb_prompt$" {
+ -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 "220\\^running\r\n${mi_gdb_prompt}.*\r\n${mi_gdb_prompt}$" {
+ -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
}
}
}
+# 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 } {
- mi_execute_to_helper "$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 } {
"$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\",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\",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\",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=.*" \
+ "\\^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
}
set er "\\^done,changelist=\\\["
set first 1
foreach item $expected {
- set v "{name=\"$item\",in_scope=\"true\",type_changed=\"false\"}"
- if {$first} {
+ 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"
}
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" \
$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
# - Type
#
# If inner list has 3 elements, the gdb is expected to output no
-# type for a child.
+# 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
+}
- set numchildren [llength $children]
- set children_exp {}
- set whatever "\"\[^\"\]+\""
+# 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]
+ }
- foreach item $children {
+ set whatever "\"\[^\"\]+\""
- set name [lindex $item 0]
- set exp [lindex $item 1]
- set numchild [lindex $item 2]
- if {[llength $item] == 4} {
- set type [lindex $item 3]
+ set children_exp_j [mi_child_regexp $children 1]
+ if {$numchildren} {
+ set expected "\\^done,numchild=\".*\",children=\\\[$children_exp_j.*\\\]"
+ } {
+ set expected "\\^done,numchild=\"0\""
+ }
- lappend children_exp\
- "child={name=\"$name\",exp=\"$exp\",numchild=\"$numchild\",type=\"$type\"}"
- } else {
- lappend children_exp\
- "child={name=\"$name\",exp=\"$exp\",numchild=\"$numchild\"}"
- }
+ if {"$to" == ""} {
+ append expected ",has_more=\"0\""
+ } elseif {$to >= 0 && $numchildren > $to} {
+ append expected ",has_more=\"1\""
+ } else {
+ append expected ",has_more=\"0\""
}
- set children_exp_j [join $children_exp ","]
- set expected "\\^done,numchild=\"$numchildren\",children=\\\[$children_exp_j\\\]"
verbose -log "Expecting: $expected"
- mi_gdb_test "-var-list-children $varname" $expected $testname
+ 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
}
# 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 {command test} {
+proc mi_send_resuming_command_raw {command test} {
global mi_gdb_prompt
+ global thread_selected_re
+ global library_loaded_re
- send_gdb "220-$command\n"
+ send_gdb "$command\n"
gdb_expect {
- -re "220\\^running\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:
+ #
+ # 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
+ 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
# 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 command} {
+proc mi_continue_to_line {location test} {
mi_tbreak $location
mi_send_resuming_command "exec-continue" "run to $location (exec-continue)"
- return [mi_wait_for_stop]
+ return [mi_get_stop_line $test]
}
# Wait until gdb prints the current line.
-proc mi_wait_for_stop {test} {
+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=\"(.*)\".*\r\n$mi_gdb_prompt$" {
+ -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 {
# Start the program afresh.
mi_tbreak "$mi_autotest_source:$line"
mi_run_cmd
- set line_now [mi_wait_for_stop "$testcase: step to $line"]
+ 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"]
+ set line_now [mi_continue_to_line "$mi_autotest_source:$line" "continue to $line"]
}
if {$line_now!=$line} {
# 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_wait_for_stop "$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
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
+}
projects / thirdparty / binutils-gdb.git / blobdiff