diff options
Diffstat (limited to 'gdb/testsuite/lib')
| -rw-r--r-- | gdb/testsuite/lib/compiler.c | 31 | ||||
| -rw-r--r-- | gdb/testsuite/lib/compiler.cc | 34 | ||||
| -rw-r--r-- | gdb/testsuite/lib/emc-support.exp | 223 | ||||
| -rw-r--r-- | gdb/testsuite/lib/gdb.exp | 1722 | ||||
| -rw-r--r-- | gdb/testsuite/lib/insight-support.exp | 310 | ||||
| -rw-r--r-- | gdb/testsuite/lib/java.exp | 105 | ||||
| -rw-r--r-- | gdb/testsuite/lib/mi-support.exp | 788 | ||||
| -rw-r--r-- | gdb/testsuite/lib/trace-support.exp | 307 |
8 files changed, 0 insertions, 3520 deletions
diff --git a/gdb/testsuite/lib/compiler.c b/gdb/testsuite/lib/compiler.c deleted file mode 100644 index 8eb0d47..0000000 --- a/gdb/testsuite/lib/compiler.c +++ /dev/null @@ -1,31 +0,0 @@ -/* Often the behavior of any particular test depends upon what compiler was - used to compile the test. As each test is compiled, this file is - preprocessed by the same compiler used to compile that specific test - (different tests might be compiled by different compilers, particularly - if compiled at different times), and used to generate a *.ci (compiler - info) file for that test. - - I.E., when callfuncs is compiled, a callfuncs.ci file will be generated, - which can then be sourced by callfuncs.exp to give callfuncs.exp access - to information about the compilation environment. - - TODO: It might be a good idea to add expect code that tests each - definition made with 'set" to see if one already exists, and if so - warn about conflicts if it is being set to something else. */ - -/* This needs to be kept in sync with whatis.c and gdb.exp(get_compiler_info). - If this ends up being hairy, we could use a common header file. */ - -#if defined (__STDC__) || defined (_AIX) -set signed_keyword_not_used 0 -#else -set signed_keyword_not_used 1 -#endif - -#if defined (__GNUC__) -set gcc_compiled __GNUC__ -#else -set gcc_compiled 0 -#endif - -return 0 diff --git a/gdb/testsuite/lib/compiler.cc b/gdb/testsuite/lib/compiler.cc deleted file mode 100644 index 5cb00f6..0000000 --- a/gdb/testsuite/lib/compiler.cc +++ /dev/null @@ -1,34 +0,0 @@ -/* Often the behavior of any particular test depends upon what compiler was - used to compile the test. As each test is compiled, this file is - preprocessed by the same compiler used to compile that specific test - (different tests might be compiled by different compilers, particularly - if compiled at different times), and used to generate a *.ci (compiler - info) file for that test. - - I.E., when callfuncs is compiled, a callfuncs.ci file will be generated, - which can then be sourced by callfuncs.exp to give callfuncs.exp access - to information about the compilation environment. - - TODO: It might be a good idea to add expect code that tests each - definition made with 'set" to see if one already exists, and if so - warn about conflicts if it is being set to something else. */ - -#if defined(__GNUC__) && (__GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 6)) -set supports_template_debugging 1 -#else -set supports_template_debugging 0 -#endif - -#if defined(__cplusplus) -set supports_template_debugging 1 -#else -set supports_template_debugging 0 -#endif - -#if defined (__GNUC__) -set gcc_compiled __GNUC__ -#else -set gcc_compiled 0 -#endif - -return 0 diff --git a/gdb/testsuite/lib/emc-support.exp b/gdb/testsuite/lib/emc-support.exp deleted file mode 100644 index 70bf2df..0000000 --- a/gdb/testsuite/lib/emc-support.exp +++ /dev/null @@ -1,223 +0,0 @@ -proc gdb_emc_readvar { varname } { - global gdb_prompt; - - set result -1; - send_gdb "print $varname\n" - gdb_expect 5 { - -re "\[$\].*= (\[0-9\]+).*$gdb_prompt $" { - set result $expect_out(1,string); - } - -re "$gdb_prompt $" { } - default { } - } - return $result; -} - -proc gdb_emc_gettpnum { testname } { - global gdb_prompt; - - if { $testname != "" } { - gdb_test "trace $testname" "" "" - } - return [gdb_emc_readvar "\$tpnum"]; -} - -proc gdb_emc_setactions { testname actionname args } { - global gdb_prompt; - - set state 0; - set status "pass"; - send_gdb "actions $actionname\n"; - set expected_result ""; - gdb_expect 5 { - -re "No tracepoint number .*$gdb_prompt $" { - fail $testname - return 1; - } - -re "Enter actions for tracepoint $actionname.*>" { - if { [llength $args] > 0 } { - set lastcommand "[lindex $args $state]"; - send_gdb "[lindex $args $state]\n"; - incr state; - set expected_result [lindex $args $state]; - incr state; - } else { - send_gdb "end\n"; - } - exp_continue; - } - -re "\(.*\[\r\n\]+)\[ \t]*> $" { - if { $expected_result != "" } { - # Remove echoed command and its associated newline. - regsub "^\[^\r\n\]+\[\r\n\]+" "$expect_out(1,string)" "" out; - # Strip off any newlines at the end of the string. - regsub "\[\r\n\]+$" "$out" "" out; - verbose "expected '$expected_result', got '$out', expect_out is '$expect_out(1,string)'"; - if ![regexp $expected_result $out] { - set status "fail"; - } - set expected_result ""; - } - if { $state < [llength $args] } { - send_gdb "[lindex $args $state]\n"; - incr state; - set expected_result [lindex $args $state]; - incr state; - } else { - send_gdb "end\n"; - set expected_result ""; - } - exp_continue; - } - -re "\(.*\)$gdb_prompt $" { - if { $expected_result != "" } { - if ![regexp $expected_result $expect_out(1,string)] { - set status "fail"; - } - set expected_result ""; - } - if { [llength $args] < $state } { - set status "fail"; - } - } - default { - set status "fail"; - } - } - if { $testname != "" } { - $status $testname; - } - if { $status == "pass" } then { - return 0; - } else { - return 1; - } -} - -# -# test collect command -# - -proc gdb_emc_tracetest_collect { arg1 msgstring } { - global decimal - global gdb_prompt; - - set teststate 0 - gdb_expect 30 { - -re "Enter actions for tracepoint $decimal.*> $" { - send_gdb "collect $arg1\n" - incr teststate; - exp_continue - } - -re "> $" { - if { $teststate == 1 } { - send_gdb "end\n" - incr teststate; - exp_continue - } else { - fail "$msgstring" - } - } - -re ".*$gdb_prompt $" { - if { $teststate == 2 } { - pass "$msgstring"; - } else { - fail "$msgstring"; - } - } - default { - fail "$msgstring (default)"; - } - } - regsub -all "(\[($@*+)\])" "collect $arg1" "\[\\1\]" arg1_regexp; - gdb_test "info tracepoints" ".*$arg1_regexp.*" "$msgstring info tracepoint" -} - -proc gdb_delete_tracepoints { } { - global gdb_prompt; - - send_gdb "delete tracepoints\n" - gdb_expect 30 { - -re "Delete all tracepoints.*y or n.*$" { - send_gdb "y\n" - exp_continue; - } - -re "$gdb_prompt $" { } - timeout { fail "delete all tracepoints (timeout)" } - } -} - - -# Send each command in the list CMDLIST to gdb. If we see the string -# "error" or "warning" from gdb, we assume an error has occured and -# return a non-zero result. All of the commands in CMDLIST are always -# sent, even if an error occurs. -# If TESTNAME is non-null, we call pass or fail with the string in TESTNAME -# depending on whether or not an error/warning has occurred. -# -proc gdb_do_cmdlist { cmdlist testname } { - global gdb_prompt; - - set status 0; - - foreach x $cmdlist { - send_gdb "$x\n"; - gdb_expect 60 { - -re "\[Ee\]rror|\[Ww\]arning" { - set status 1; - exp_continue; - } - -re "$gdb_prompt $" { } - -re "\[\r\n\]\[ \t\]*> *$" { } - } - } - if { $testname != "" } { - if { $status == 0 } { - pass "$testname"; - } else { - fail "$testname"; - } - } - return $status; -} - -# -# Given the file FILENAME, we read it as a list of commands and generate -# a list suitable for use by gdb_do_cmdlist. Lines beginning with # are -# ignored; blank lines are interpreted as empty lines to be sent to gdb. -# -proc gdb_process_cmdfile { filename } { - set id [open $filename "r"]; - if { $id < 0 } { - return ""; - } - set result {}; - while { [gets $id line] >= 0 } { - if [regexp "^#" $line] { - continue; - } - set result [concat $result [list "$line"]]; - } - close $id; - return $result; -} - -# gdb_find_c_test_baseline -# returns -1 on failure (CALLER MUST CHECK RETURN!) -proc gdb_find_c_test_baseline { } { - global gdb_prompt; - - set gdb_c_test_baseline -1; - - send_gdb "list gdb_c_test\n" - gdb_expect { - -re "void.*p5,.*void.*p6.*\[\r\n\](\[0-9\]+)\[\t \]+\{.*$gdb_prompt $" { - set gdb_c_test_baseline $expect_out(1,string) - } - -re "$gdb_prompt $" { } - default { } - } - return $gdb_c_test_baseline; -} - - diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp deleted file mode 100644 index f4ddc63..0000000 --- a/gdb/testsuite/lib/gdb.exp +++ /dev/null @@ -1,1722 +0,0 @@ -# Copyright 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000 -# 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 -# (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 - -# This file was written by Fred Fish. (fnf@cygnus.com) - -# Generic gdb subroutines that should work for any target. If these -# need to be modified for any target, it can be done with a variable -# or by passing arguments. - -load_lib libgloss.exp - -global GDB -# OBSOLETE global CHILL_LIB -# OBSOLETE global CHILL_RT0 - -# OBSOLETE if ![info exists CHILL_LIB] { -# OBSOLETE set CHILL_LIB [findfile $base_dir/../../gcc/ch/runtime/libchill.a "$base_dir/../../gcc/ch/runtime/libchill.a" [transform -lchill]] -# OBSOLETE } -# OBSOLETE verbose "using CHILL_LIB = $CHILL_LIB" 2 -# OBSOLETE if ![info exists CHILL_RT0] { -# OBSOLETE set CHILL_RT0 [findfile $base_dir/../../gcc/ch/runtime/chillrt0.o "$base_dir/../../gcc/ch/runtime/chillrt0.o" ""] -# OBSOLETE } -# OBSOLETE verbose "using CHILL_RT0 = $CHILL_RT0" 2 - -if [info exists TOOL_EXECUTABLE] { - set GDB $TOOL_EXECUTABLE; -} -if ![info exists GDB] { - if ![is_remote host] { - set GDB [findfile $base_dir/../../gdb/gdb "$base_dir/../../gdb/gdb" [transform gdb]] - } else { - set GDB [transform gdb]; - } -} -verbose "using GDB = $GDB" 2 - -global GDBFLAGS -if ![info exists GDBFLAGS] { - set GDBFLAGS "-nx" -} -verbose "using GDBFLAGS = $GDBFLAGS" 2 - -# The variable gdb_prompt is a regexp which matches the gdb prompt. -# Set it if it is not already set. -global gdb_prompt -if ![info exists gdb_prompt] then { - set gdb_prompt "\[(\]gdb\[)\]" -} - -# Needed for some tests under Cygwin. -global EXEEXT -global env - -if ![info exists env(EXEEXT)] { - set EXEEXT "" -} else { - set EXEEXT $env(EXEEXT) -} - -### Only procedures should come after this point. - -# -# gdb_version -- extract and print the version number of GDB -# -proc default_gdb_version {} { - global GDB - global GDBFLAGS - global gdb_prompt - set fileid [open "gdb_cmd" w]; - puts $fileid "q"; - close $fileid; - set cmdfile [remote_download host "gdb_cmd"]; - set output [remote_exec host "$GDB -nw --command $cmdfile"] - remote_file build delete "gdb_cmd"; - remote_file host delete "$cmdfile"; - set tmp [lindex $output 1]; - set version "" - regexp " \[0-9\]\[^ \t\n\r\]+" "$tmp" version - if ![is_remote host] { - clone_output "[which $GDB] version $version $GDBFLAGS\n" - } else { - clone_output "$GDB on remote host version $version $GDBFLAGS\n" - } -} - -proc gdb_version { } { - return [default_gdb_version]; -} - -# -# gdb_unload -- unload a file if one is loaded -# - -proc gdb_unload {} { - global verbose - global GDB - global gdb_prompt - send_gdb "file\n" - gdb_expect 60 { - -re "No executable file now\[^\r\n\]*\[\r\n\]" { exp_continue } - -re "No symbol file now\[^\r\n\]*\[\r\n\]" { exp_continue } - -re "A program is being debugged already..*Kill it.*y or n. $"\ - { send_gdb "y\n" - verbose "\t\tKilling previous program being debugged" - exp_continue - } - -re "Discard symbol table from .*y or n.*$" { - send_gdb "y\n" - exp_continue - } - -re "$gdb_prompt $" {} - timeout { - perror "couldn't unload file in $GDB (timed out)." - return -1 - } - } -} - -# 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 delete_breakpoints {} { - global gdb_prompt - - # we need a larger timeout value here or this thing just confuses - # itself. May need a better implementation if possible. - guo - # - send_gdb "delete breakpoints\n" - gdb_expect 100 { - -re "Delete all breakpoints.*y or n.*$" { - send_gdb "y\n"; - exp_continue - } - -re "$gdb_prompt $" { # This happens if there were no breakpoints - } - timeout { perror "Delete all breakpoints in delete_breakpoints (timeout)" ; return } - } - send_gdb "info breakpoints\n" - gdb_expect 100 { - -re "No breakpoints or watchpoints..*$gdb_prompt $" {} - -re "$gdb_prompt $" { perror "breakpoints not deleted" ; return } - -re "Delete all breakpoints.*or n.*$" { - send_gdb "y\n"; - exp_continue - } - timeout { perror "info breakpoints (timeout)" ; return } - } -} - - -# -# Generic run command. -# -# The second pattern below matches up to the first newline *only*. -# Using ``.*$'' could swallow up output that we attempt to match -# elsewhere. -# -proc gdb_run_cmd {args} { - global gdb_prompt - - if [target_info exists gdb_init_command] { - send_gdb "[target_info gdb_init_command]\n"; - gdb_expect 30 { - -re "$gdb_prompt $" { } - default { - perror "gdb_init_command for target failed"; - return; - } - } - } - - if [target_info exists use_gdb_stub] { - if [target_info exists gdb,do_reload_on_run] { - # Specifying no file, defaults to the executable - # currently being debugged. - if { [gdb_load ""] < 0 } { - return; - } - send_gdb "continue\n"; - gdb_expect 60 { - -re "Continu\[^\r\n\]*\[\r\n\]" {} - default {} - } - return; - } - - if [target_info exists gdb,start_symbol] { - set start [target_info gdb,start_symbol]; - } else { - set start "start"; - } - send_gdb "jump *$start\n" - set start_attempt 1; - while { $start_attempt } { - # Cap (re)start attempts at three to ensure that this loop - # always eventually fails. Don't worry about trying to be - # clever and not send a command when it has failed. - if [expr $start_attempt > 3] { - perror "Jump to start() failed (retry count exceeded)"; - return; - } - set start_attempt [expr $start_attempt + 1]; - gdb_expect 30 { - -re "Continuing at \[^\r\n\]*\[\r\n\]" { - set start_attempt 0; - } - -re "No symbol \"_start\" in current.*$gdb_prompt $" { - perror "Can't find start symbol to run in gdb_run"; - return; - } - -re "No symbol \"start\" in current.*$gdb_prompt $" { - send_gdb "jump *_start\n"; - } - -re "No symbol.*context.*$gdb_prompt $" { - set start_attempt 0; - } - -re "Line.* Jump anyway.*y or n. $" { - send_gdb "y\n" - } - -re "The program is not being run.*$gdb_prompt $" { - if { [gdb_load ""] < 0 } { - return; - } - send_gdb "jump *$start\n"; - } - timeout { - perror "Jump to start() failed (timeout)"; - return - } - } - } - if [target_info exists gdb_stub] { - gdb_expect 60 { - -re "$gdb_prompt $" { - send_gdb "continue\n" - } - } - } - return - } - send_gdb "run $args\n" -# This doesn't work quite right yet. - gdb_expect 60 { - -re "The program .* has been started already.*y or n. $" { - send_gdb "y\n" - exp_continue - } - -re "Starting program: \[^\r\n\]*" {} - } -} - -proc gdb_breakpoint { function } { - global gdb_prompt - global decimal - - send_gdb "break $function\n" - # The first two regexps are what we get with -g, the third is without -g. - gdb_expect 30 { - -re "Breakpoint \[0-9\]* at .*: file .*, line $decimal.\r\n$gdb_prompt $" {} - -re "Breakpoint \[0-9\]*: file .*, line $decimal.\r\n$gdb_prompt $" {} - -re "Breakpoint \[0-9\]* at .*$gdb_prompt $" {} - -re "$gdb_prompt $" { fail "setting breakpoint at $function" ; return 0 } - timeout { fail "setting breakpoint at $function (timeout)" ; return 0 } - } - return 1; -} - -# Set breakpoint at function and run gdb until it breaks there. -# Since this is the only breakpoint that will be set, if it stops -# at a breakpoint, we will assume it is the one we want. We can't -# just compare to "function" because it might be a fully qualified, -# single quoted C++ function specifier. - -proc runto { function } { - global gdb_prompt - global decimal - - delete_breakpoints - - if ![gdb_breakpoint $function] { - return 0; - } - - gdb_run_cmd - - # the "at foo.c:36" output we get with -g. - # the "in func" output we get without -g. - gdb_expect 30 { - -re "Break.* at .*:$decimal.*$gdb_prompt $" { - return 1 - } - -re "Breakpoint \[0-9\]*, \[0-9xa-f\]* in .*$gdb_prompt $" { - return 1 - } - -re "$gdb_prompt $" { - fail "running to $function in runto" - return 0 - } - timeout { - fail "running to $function in runto (timeout)" - return 0 - } - } - return 1 -} - -# -# runto_main -- ask gdb to run until we hit a breakpoint at main. -# The case where the target uses stubs has to be handled -# specially--if it uses stubs, assuming we hit -# breakpoint() and just step out of the function. -# -proc runto_main { } { - global gdb_prompt - global decimal - - if ![target_info exists gdb_stub] { - return [runto main] - } - - delete_breakpoints - - gdb_step_for_stub; - - return 1 -} - - -### Continue, and expect to hit a breakpoint. -### Report a pass or fail, depending on whether it seems to have -### worked. Use NAME as part of the test name; each call to -### continue_to_breakpoint should use a NAME which is unique within -### that test file. -proc gdb_continue_to_breakpoint {name} { - global gdb_prompt - set full_name "continue to breakpoint: $name" - - send_gdb "continue\n" - gdb_expect { - -re "Breakpoint .* at .*\r\n$gdb_prompt $" { - pass $full_name - } - -re ".*$gdb_prompt $" { - fail $full_name - } - timeout { - fail "$full_name (timeout)" - } - } -} - - - -# gdb_test COMMAND PATTERN MESSAGE QUESTION RESPONSE -# 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 an optional message to be printed. If this is -# omitted, then the pass/fail messages use the command string as the -# message. (If this is the empty string, then sometimes we don't -# call pass or fail at all; I don't understand this at all.) -# QUESTION is a question GDB may ask in response to COMMAND, like -# "are you sure?" -# RESPONSE is the response to send if QUESTION appears. -# -# Returns: -# 1 if the test failed, -# 0 if the test passes, -# -1 if there was an internal error. -# -proc gdb_test { args } { - global verbose - global gdb_prompt - global GDB - upvar timeout timeout - - if [llength $args]>2 then { - set message [lindex $args 2] - } else { - set message [lindex $args 0] - } - set command [lindex $args 0] - set pattern [lindex $args 1] - - 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"; - 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; - } - # since we're checking if each line of the multi-line - # command are 'accepted' by GDB here, - # we need to set -notransfer expect option so that - # command output is not lost for pattern matching - # - guo - gdb_expect 2 { - -notransfer -re "\[\r\n\]" { verbose "partial: match" 3 } - timeout { verbose "partial: timeout" 3 } - } - 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 [target_info exists gdb,timeout] { - set tmt [target_info gdb,timeout]; - } else { - if [info exists timeout] { - set tmt $timeout; - } else { - global timeout; - if [info exists timeout] { - set tmt $timeout; - } else { - set tmt 60; - } - } - } - gdb_expect $tmt { - -re "\\*\\*\\* DOSEXIT code.*" { - if { $message != "" } { - fail "$message"; - } - gdb_suppress_entire_file "GDB died"; - return -1; - } - -re "Ending remote debugging.*$gdb_prompt $" { - if ![isnative] then { - warning "Can`t communicate to remote target." - } - gdb_exit - gdb_start - set result -1 - } - -re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" { - if ![string match "" $message] then { - pass "$message" - } - set result 0 - } - -re "(${question_string})$" { - send_gdb "$response_string\n"; - exp_continue; - } - -re "Undefined\[a-z\]* command:.*$gdb_prompt $" { - perror "Undefined command \"$command\"." - fail "$message" - set result 1 - } - -re "Ambiguous command.*$gdb_prompt $" { - perror "\"$command\" is not a unique command name." - fail "$message" - set result 1 - } - -re "Program exited with code \[0-9\]+.*$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 "EXIT code \[0-9\r\n\]+Program exited normally.*$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.*$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 ".*$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 - } - } - return $result -} - -# Test that a command gives an error. For pass or fail, return -# a 1 to indicate that more tests can proceed. However a timeout -# is a serious error, generates a special fail message, and causes -# a 0 to be returned to indicate that more tests are likely to fail -# as well. - -proc test_print_reject { args } { - global gdb_prompt - global verbose - - if [llength $args]==2 then { - set expectthis [lindex $args 1] - } else { - set expectthis "should never match this bogus string" - } - set sendthis [lindex $args 0] - if $verbose>2 then { - send_user "Sending \"$sendthis\" to gdb\n" - send_user "Looking to match \"$expectthis\"\n" - } - send_gdb "$sendthis\n" - #FIXME: Should add timeout as parameter. - gdb_expect { - -re "A .* in expression.*\\.*$gdb_prompt $" { - pass "reject $sendthis" - return 1 - } - -re "Invalid syntax in expression.*$gdb_prompt $" { - pass "reject $sendthis" - return 1 - } - -re "Junk after end of expression.*$gdb_prompt $" { - pass "reject $sendthis" - return 1 - } - -re "Invalid number.*$gdb_prompt $" { - pass "reject $sendthis" - return 1 - } - -re "Invalid character constant.*$gdb_prompt $" { - pass "reject $sendthis" - return 1 - } - -re "No symbol table is loaded.*$gdb_prompt $" { - pass "reject $sendthis" - return 1 - } - -re "No symbol .* in current context.*$gdb_prompt $" { - pass "reject $sendthis" - return 1 - } - -re "Unmatched single quote.*$gdb_prompt $" { - pass "reject $sendthis" - return 1 - } - -re "A character constant must contain at least one character.*$gdb_prompt $" { - pass "reject $sendthis" - return 1 - } - -re "$expectthis.*$gdb_prompt $" { - pass "reject $sendthis" - return 1 - } - -re ".*$gdb_prompt $" { - fail "reject $sendthis" - return 1 - } - default { - fail "reject $sendthis (eof or timeout)" - return 0 - } - } -} - -# Given an input string, adds backslashes as needed to create a -# regexp that will match the string. - -proc string_to_regexp {str} { - set result $str - regsub -all {[]*+.|()^$\[]} $str {\\&} result - return $result -} - -# Same as gdb_test, but the second parameter is not a regexp, -# but a string that must match exactly. - -proc gdb_test_exact { args } { - upvar timeout timeout - - set command [lindex $args 0] - - # This applies a special meaning to a null string pattern. Without - # this, "$pattern\r\n$gdb_prompt $" will match anything, including error - # messages from commands that should have no output except a new - # prompt. With this, only results of a null string will match a null - # string pattern. - - set pattern [lindex $args 1] - if [string match $pattern ""] { - set pattern [string_to_regexp [lindex $args 0]] - } else { - set pattern [string_to_regexp [lindex $args 1]] - } - - # It is most natural to write the pattern argument with only - # embedded \n's, especially if you are trying to avoid Tcl quoting - # problems. But gdb_expect really wants to see \r\n in patterns. So - # transform the pattern here. First transform \r\n back to \n, in - # case some users of gdb_test_exact already do the right thing. - regsub -all "\r\n" $pattern "\n" pattern - regsub -all "\n" $pattern "\r\n" pattern - if [llength $args]==3 then { - set message [lindex $args 2] - } else { - set message $command - } - - return [gdb_test $command $pattern $message] -} - -proc gdb_reinitialize_dir { subdir } { - global gdb_prompt - - if [is_remote host] { - return ""; - } - send_gdb "dir\n" - gdb_expect 60 { - -re "Reinitialize source path to empty.*y or n. " { - send_gdb "y\n" - gdb_expect 60 { - -re "Source directories searched.*$gdb_prompt $" { - send_gdb "dir $subdir\n" - gdb_expect 60 { - -re "Source directories searched.*$gdb_prompt $" { - verbose "Dir set to $subdir" - } - -re "$gdb_prompt $" { - perror "Dir \"$subdir\" failed." - } - } - } - -re "$gdb_prompt $" { - perror "Dir \"$subdir\" failed." - } - } - } - -re "$gdb_prompt $" { - perror "Dir \"$subdir\" failed." - } - } -} - -# -# gdb_exit -- exit the GDB, killing the target program if necessary -# -proc default_gdb_exit {} { - global GDB - global GDBFLAGS - global verbose - global gdb_spawn_id; - - gdb_stop_suppressing_tests; - - if ![info exists gdb_spawn_id] { - return; - } - - verbose "Quitting $GDB $GDBFLAGS" - - if { [is_remote host] && [board_info host exists fileid] } { - send_gdb "quit\n"; - gdb_expect 10 { - -re "y or n" { - send_gdb "y\n"; - exp_continue; - } - -re "DOSEXIT code" { } - default { } - } - } - - if ![is_remote host] { - remote_close host; - } - unset gdb_spawn_id -} - -# -# load a file into the debugger. -# return a -1 if anything goes wrong. -# -proc gdb_file_cmd { arg } { - global verbose - global loadpath - global loadfile - global GDB - global gdb_prompt - upvar timeout timeout - - if [is_remote host] { - set arg [remote_download host $arg]; - if { $arg == "" } { - error "download failed" - return -1; - } - } - - send_gdb "file $arg\n" - gdb_expect 120 { - -re "Reading symbols from.*done.*$gdb_prompt $" { - verbose "\t\tLoaded $arg into the $GDB" - return 0 - } - -re "has no symbol-table.*$gdb_prompt $" { - perror "$arg wasn't compiled with \"-g\"" - return -1 - } - -re "A program is being debugged already.*Kill it.*y or n. $" { - send_gdb "y\n" - verbose "\t\tKilling previous program being debugged" - exp_continue - } - -re "Load new symbol table from \".*\".*y or n. $" { - send_gdb "y\n" - gdb_expect 120 { - -re "Reading symbols from.*done.*$gdb_prompt $" { - verbose "\t\tLoaded $arg with new symbol table into $GDB" - return 0 - } - timeout { - perror "(timeout) Couldn't load $arg, other program already loaded." - return -1 - } - } - } - -re "No such file or directory.*$gdb_prompt $" { - perror "($arg) No such file or directory\n" - return -1 - } - -re "$gdb_prompt $" { - perror "couldn't load $arg into $GDB." - return -1 - } - 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 - } - } -} - -# -# start gdb -- start gdb running, default procedure -# -# 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_gdb_start { } { - global verbose - global GDB - global GDBFLAGS - global gdb_prompt - global timeout - global gdb_spawn_id; - - gdb_stop_suppressing_tests; - - verbose "Spawning $GDB -nw $GDBFLAGS" - - if [info exists gdb_spawn_id] { - return 0; - } - - if ![is_remote host] { - if { [which $GDB] == 0 } then { - perror "$GDB does not exist." - exit 1 - } - } - set res [remote_spawn host "$GDB -nw $GDBFLAGS [host_info gdb_opts]"]; - if { $res < 0 || $res == "" } { - perror "Spawning $GDB failed." - return 1; - } - gdb_expect 360 { - -re "\[\r\n\]$gdb_prompt $" { - verbose "GDB initialized." - } - -re "$gdb_prompt $" { - perror "GDB never initialized." - return -1 - } - timeout { - perror "(timeout) GDB never initialized after 10 seconds." - remote_close host; - return -1 - } - } - set gdb_spawn_id -1; - # force the height to "unlimited", so no pagers get used - - send_gdb "set height 0\n" - gdb_expect 10 { - -re "$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 "set width 0\n" - gdb_expect 10 { - -re "$gdb_prompt $" { - verbose "Setting width to 0." 2 - } - timeout { - warning "Couldn't set the width to 0." - } - } - return 0; -} - -# Return a 1 for configurations for which we don't even want to try to -# test C++. - -proc skip_cplus_tests {} { - if { [istarget "d10v-*-*"] } { - return 1 - } - if { [istarget "h8300-*-*"] } { - return 1 - } - return 0 -} - -# OBSOLETE # * For crosses, the CHILL runtime doesn't build because it -# OBSOLETE # can't find setjmp.h, stdio.h, etc. -# OBSOLETE # * For AIX (as of 16 Mar 95), (a) there is no language code for -# OBSOLETE # CHILL in output_epilog in gcc/config/rs6000/rs6000.c, (b) collect2 -# OBSOLETE # does not get along with AIX's too-clever linker. -# OBSOLETE # * On Irix5, there is a bug whereby set of bool, etc., don't get -# OBSOLETE # TYPE_LOW_BOUND for the bool right because force_to_range_type doesn't -# OBSOLETE # work with stub types. -# OBSOLETE # Lots of things seem to fail on the PA, and since it's not a supported -# OBSOLETE # chill target at the moment, don't run the chill tests. - -# OBSOLETE proc skip_chill_tests {} { -# OBSOLETE if ![info exists do_chill_tests] { -# OBSOLETE return 1; -# OBSOLETE } -# OBSOLETE eval set skip_chill [expr ![isnative] || [istarget "*-*-aix*"] || [istarget "*-*-irix5*"] || [istarget "*-*-irix6*"] || [istarget "alpha-*-osf*"] || [istarget "hppa*-*-*"]] -# OBSOLETE verbose "Skip chill tests is $skip_chill" -# OBSOLETE return $skip_chill -# OBSOLETE } - -# Skip all the tests in the file if you are not on an hppa running -# hpux target. - -proc skip_hp_tests {} { - eval set skip_hp [ expr ![isnative] || ![istarget "hppa*-*-hpux*"] ] - verbose "Skip hp tests is $skip_hp" - return $skip_hp -} - -proc get_compiler_info {binfile args} { - # Create and source the file that provides information about the compiler - # used to compile the test case. - # Compiler_type can be null or c++. If null we assume c. - global srcdir - global subdir - # These two come from compiler.c. - global signed_keyword_not_used - global gcc_compiled - - if {![istarget "hppa*-*-hpux*"] && ![istarget "mips*-*-irix*"]} { - if { [llength $args] > 0 } { - if {$args == "c++"} { - if { [gdb_compile "${srcdir}/lib/compiler.cc" "${binfile}.ci" preprocess {}] != "" } { - perror "Couldn't make ${binfile}.ci file" - return 1; - } - } - } else { - if { [gdb_compile "${srcdir}/lib/compiler.c" "${binfile}.ci" preprocess {}] != "" } { - perror "Couldn't make ${binfile}.ci file" - return 1; - } - } - } else { - if { [llength $args] > 0 } { - if {$args == "c++"} { - if { [eval gdb_preprocess \ - [list "${srcdir}/lib/compiler.cc" "${binfile}.ci"] \ - $args] != "" } { - perror "Couldn't make ${binfile}.ci file" - return 1; - } - } - } elseif { $args != "f77" } { - if { [eval gdb_preprocess \ - [list "${srcdir}/lib/compiler.c" "${binfile}.ci"] \ - $args] != "" } { - perror "Couldn't make ${binfile}.ci file" - return 1; - } - } - } - - uplevel \#0 { set gcc_compiled 0 } - - if { [llength $args] == 0 || $args != "f77" } { - source ${binfile}.ci - } - - # Most compilers will evaluate comparisons and other boolean - # operations to 0 or 1. - uplevel \#0 { set true 1 } - uplevel \#0 { set false 0 } - - uplevel \#0 { set hp_cc_compiler 0 } - uplevel \#0 { set hp_aCC_compiler 0 } - uplevel \#0 { set hp_f77_compiler 0 } - uplevel \#0 { set hp_f90_compiler 0 } - if { !$gcc_compiled && [istarget "hppa*-*-hpux*"] } { - # Check for the HP compilers - set compiler [lindex [split [get_compiler $args] " "] 0] - catch "exec what $compiler" output - if [regexp ".*HP aC\\+\\+.*" $output] { - uplevel \#0 { set hp_aCC_compiler 1 } - # Use of aCC results in boolean results being displayed as - # "true" or "false" - uplevel \#0 { set true true } - uplevel \#0 { set false false } - } elseif [regexp ".*HP C Compiler.*" $output] { - uplevel \#0 { set hp_cc_compiler 1 } - } elseif [regexp ".*HP-UX f77.*" $output] { - uplevel \#0 { set hp_f77_compiler 1 } - } elseif [regexp ".*HP-UX f90.*" $output] { - uplevel \#0 { set hp_f90_compiler 1 } - } - } - - return 0; -} - -proc get_compiler {args} { - global CC CC_FOR_TARGET CXX CXX_FOR_TARGET F77_FOR_TARGET - - if { [llength $args] == 0 - || ([llength $args] == 1 && [lindex $args 0] == "") } { - set which_compiler "c" - } else { - if { $args =="c++" } { - set which_compiler "c++" - } elseif { $args =="f77" } { - set which_compiler "f77" - } else { - perror "Unknown compiler type supplied to gdb_preprocess" - return "" - } - } - - if [info exists CC_FOR_TARGET] { - if {$which_compiler == "c"} { - set compiler $CC_FOR_TARGET - } - } - - if [info exists CXX_FOR_TARGET] { - if {$which_compiler == "c++"} { - set compiler $CXX_FOR_TARGET - } - } - - if [info exists F77_FOR_TARGET] { - if {$which_compiler == "f77"} { - set compiler $F77_FOR_TARGET - } - } - - if { ![info exists compiler] } { - if { $which_compiler == "c" } { - if {[info exists CC]} { - set compiler $CC - } - } - if { $which_compiler == "c++" } { - if {[info exists CXX]} { - set compiler $CXX - } - } - if {![info exists compiler]} { - set compiler [board_info [target_info name] compiler]; - if { $compiler == "" } { - perror "get_compiler: No compiler found" - return "" - } - } - } - - return $compiler -} - -proc gdb_preprocess {source dest args} { - set compiler [get_compiler "$args"] - if { $compiler == "" } { - return 1 - } - - set cmdline "$compiler -E $source > $dest" - - verbose "Invoking $compiler -E $source > $dest" - verbose -log "Executing on local host: $cmdline" 2 - set status [catch "exec ${cmdline}" exec_output] - - set result [prune_warnings $exec_output] - regsub "\[\r\n\]*$" "$result" "" result; - regsub "^\[\r\n\]*" "$result" "" result; - if { $result != "" } { - clone_output "gdb compile failed, $result" - } - return $result; -} - -set gdb_wrapper_initialized 0 - -proc gdb_wrapper_init { args } { - global gdb_wrapper_initialized; - global gdb_wrapper_file; - global gdb_wrapper_flags; - - if { $gdb_wrapper_initialized == 1 } { return; } - - if {[target_info exists needs_status_wrapper] && \ - [target_info needs_status_wrapper] != "0"} { - set result [build_wrapper "testglue.o"]; - if { $result != "" } { - set gdb_wrapper_file [lindex $result 0]; - set gdb_wrapper_flags [lindex $result 1]; - } else { - warning "Status wrapper failed to build." - } - } - set gdb_wrapper_initialized 1 -} - -proc gdb_compile {source dest type options} { - global GDB_TESTCASE_OPTIONS; - global gdb_wrapper_file; - global gdb_wrapper_flags; - global gdb_wrapper_initialized; - - if [target_info exists gdb_stub] { - set options2 { "additional_flags=-Dusestubs" } - lappend options "libs=[target_info gdb_stub]"; - set options [concat $options2 $options] - } - if [target_info exists is_vxworks] { - set options2 { "additional_flags=-Dvxworks" } - lappend options "libs=[target_info gdb_stub]"; - set options [concat $options2 $options] - } - if [info exists GDB_TESTCASE_OPTIONS] { - lappend options "additional_flags=$GDB_TESTCASE_OPTIONS"; - } - verbose "options are $options" - verbose "source is $source $dest $type $options" - - if { $gdb_wrapper_initialized == 0 } { gdb_wrapper_init } - - if {[target_info exists needs_status_wrapper] && \ - [target_info needs_status_wrapper] != "0" && \ - [info exists gdb_wrapper_file]} { - lappend options "libs=${gdb_wrapper_file}" - lappend options "ldflags=${gdb_wrapper_flags}" - } - - set result [target_compile $source $dest $type $options]; - regsub "\[\r\n\]*$" "$result" "" result; - regsub "^\[\r\n\]*" "$result" "" result; - if { $result != "" } { - clone_output "gdb compile failed, $result" - } - return $result; -} - - -# This is just like gdb_compile, above, except that it tries compiling -# against several different thread libraries, to see which one this -# system has. -proc gdb_compile_pthreads {source dest type options} { - set built_binfile 0 - set why_msg "unrecognized error" - foreach lib {-lpthreads -lpthread -lthread} { - # This kind of wipes out whatever libs the caller may have - # set. Or maybe theirs will override ours. How infelicitous. - set options_with_lib [concat $options [list libs=$lib]] - set ccout [gdb_compile $source $dest $type $options_with_lib] - switch -regexp -- $ccout { - ".*no posix threads support.*" { - set why_msg "missing threads include file" - break - } - ".*cannot open -lpthread.*" { - set why_msg "missing runtime threads library" - } - ".*Can't find library for -lpthread.*" { - set why_msg "missing runtime threads library" - } - {^$} { - pass "successfully compiled posix threads test case" - set built_binfile 1 - break - } - } - } - if {!$built_binfile} { - unsupported "Couldn't compile $source: ${why_msg}" - return -1 - } -} - -proc send_gdb { string } { - global suppress_flag; - if { $suppress_flag } { - return "suppressed"; - } - return [remote_send host "$string"]; -} - -# -# - -proc gdb_expect { args } { - if { [llength $args] == 2 && [lindex $args 0] != "-re" } { - set gtimeout [lindex $args 0]; - set expcode [list [lindex $args 1]]; - } else { - upvar timeout timeout; - - set expcode $args; - if [target_info exists gdb,timeout] { - if [info exists timeout] { - if { $timeout < [target_info gdb,timeout] } { - set gtimeout [target_info gdb,timeout]; - } else { - set gtimeout $timeout; - } - } else { - set gtimeout [target_info gdb,timeout]; - } - } - - if ![info exists gtimeout] { - global timeout; - if [info exists timeout] { - set gtimeout $timeout; - } else { - # Eeeeew. - set gtimeout 60; - } - } - } - global suppress_flag; - global remote_suppress_flag; - if [info exists remote_suppress_flag] { - set old_val $remote_suppress_flag; - } - if [info exists suppress_flag] { - if { $suppress_flag } { - set remote_suppress_flag 1; - } - } - set code [catch \ - {uplevel remote_expect host $gtimeout $expcode} string]; - if [info exists old_val] { - set remote_suppress_flag $old_val; - } else { - if [info exists remote_suppress_flag] { - unset remote_suppress_flag; - } - } - - if {$code == 1} { - global errorInfo errorCode; - - return -code error -errorinfo $errorInfo -errorcode $errorCode $string - } elseif {$code == 2} { - return -code return $string - } elseif {$code == 3} { - return - } elseif {$code > 4} { - return -code $code $string - } -} - -# gdb_expect_list MESSAGE SENTINEL LIST -- expect a sequence of outputs -# -# Check for long sequence of output by parts. -# MESSAGE: is the test message to be printed with the test success/fail. -# SENTINEL: Is the terminal pattern indicating that output has finished. -# LIST: is the sequence of outputs to match. -# If the sentinel is recognized early, it is considered an error. -# -# Returns: -# 1 if the test failed, -# 0 if the test passes, -# -1 if there was an internal error. -# -proc gdb_expect_list {test sentinel list} { - global gdb_prompt - global suppress_flag - set index 0 - set ok 1 - if { $suppress_flag } { - set ok 0 - unresolved "${test}" - } - while { ${index} < [llength ${list}] } { - set pattern [lindex ${list} ${index}] - set index [expr ${index} + 1] - if { ${index} == [llength ${list}] } { - if { ${ok} } { - gdb_expect { - -re "${pattern}${sentinel}" { - # pass "${test}, pattern ${index} + sentinel" - } - -re "${sentinel}" { - fail "${test} (pattern ${index} + sentinel)" - set ok 0 - } - timeout { - fail "${test} (pattern ${index} + sentinel) (timeout)" - set ok 0 - } - } - } else { - # unresolved "${test}, pattern ${index} + sentinel" - } - } else { - if { ${ok} } { - gdb_expect { - -re "${pattern}" { - # pass "${test}, pattern ${index}" - } - -re "${sentinel}" { - fail "${test} (pattern ${index})" - set ok 0 - } - timeout { - fail "${test} (pattern ${index}) (timeout)" - set ok 0 - } - } - } else { - # unresolved "${test}, pattern ${index}" - } - } - } - if { ${ok} } { - pass "${test}" - return 0 - } else { - return 1 - } -} - -# -# -proc gdb_suppress_entire_file { reason } { - global suppress_flag; - - warning "$reason\n"; - set suppress_flag -1; -} - -# -# Set suppress_flag, which will cause all subsequent calls to send_gdb and -# gdb_expect to fail immediately (until the next call to -# gdb_stop_suppressing_tests). -# -proc gdb_suppress_tests { args } { - global suppress_flag; - - return; # fnf - disable pending review of results where - # testsuite ran better without this - incr suppress_flag; - - if { $suppress_flag == 1 } { - if { [llength $args] > 0 } { - warning "[lindex $args 0]\n"; - } else { - warning "Because of previous failure, all subsequent tests in this group will automatically fail.\n"; - } - } -} - -# -# Clear suppress_flag. -# -proc gdb_stop_suppressing_tests { } { - global suppress_flag; - - if [info exists suppress_flag] { - if { $suppress_flag > 0 } { - set suppress_flag 0; - clone_output "Tests restarted.\n"; - } - } else { - set suppress_flag 0; - } -} - -proc gdb_clear_suppressed { } { - global suppress_flag; - - set suppress_flag 0; -} - -proc gdb_start { } { - default_gdb_start -} - -proc gdb_exit { } { - catch default_gdb_exit -} - -# -# gdb_load -- load a file into the debugger. -# return a -1 if anything goes wrong. -# -proc gdb_load { arg } { - return [gdb_file_cmd $arg] -} - -proc gdb_continue { function } { - global decimal - - return [gdb_test "continue" ".*Breakpoint $decimal, $function .*" "continue to $function"]; -} - -proc default_gdb_init { args } { - global gdb_wrapper_initialized - - gdb_clear_suppressed; - - # Make sure that the wrapper is rebuilt - # with the appropriate multilib option. - set gdb_wrapper_initialized 0 - - # Uh, this is lame. Really, really, really lame. But there's this *one* - # testcase that will fail in random places if we don't increase this. - match_max -d 20000 - - # We want to add the name of the TCL testcase to the PASS/FAIL messages. - if { [llength $args] > 0 } { - global pf_prefix - - set file [lindex $args 0]; - - set pf_prefix "[file tail [file dirname $file]]/[file tail $file]:"; - } - global gdb_prompt; - if [target_info exists gdb_prompt] { - set gdb_prompt [target_info gdb_prompt]; - } else { - set gdb_prompt "\\(gdb\\)" - } -} - -proc gdb_init { args } { - return [eval default_gdb_init $args]; -} - -proc gdb_finish { } { - gdb_exit; -} - -global debug_format -set debug_format "unknown" - -# Run the gdb command "info source" and extract the debugging format -# information from the output and save it in debug_format. - -proc get_debug_format { } { - global gdb_prompt - global verbose - global expect_out - global debug_format - - set debug_format "unknown" - send_gdb "info source\n" - gdb_expect 10 { - -re "Compiled with (.*) debugging format.\r\n.*$gdb_prompt $" { - set debug_format $expect_out(1,string) - verbose "debug format is $debug_format" - return 1; - } - -re "No current source file.\r\n$gdb_prompt $" { - perror "get_debug_format used when no current source file" - return 0; - } - -re "$gdb_prompt $" { - warning "couldn't check debug format (no valid response)." - return 1; - } - timeout { - warning "couldn't check debug format (timed out)." - return 1; - } - } -} - -# Return true if FORMAT matches the debug format the current test was -# compiled with. FORMAT is a shell-style globbing pattern; it can use -# `*', `[...]', and so on. -# -# This function depends on variables set by `get_debug_format', above. - -proc test_debug_format {format} { - global debug_format - - return [expr [string match $format $debug_format] != 0] -} - -# Like setup_xfail, but takes the name of a debug format (DWARF 1, -# COFF, stabs, etc). If that format matches the format that the -# current test was compiled with, then the next test is expected to -# fail for any target. Returns 1 if the next test or set of tests is -# expected to fail, 0 otherwise (or if it is unknown). Must have -# previously called get_debug_format. -proc setup_xfail_format { format } { - set ret [test_debug_format $format]; - - if {$ret} then { - setup_xfail "*-*-*" - } - return $ret; -} - -proc gdb_step_for_stub { } { - global gdb_prompt; - - if ![target_info exists gdb,use_breakpoint_for_stub] { - if [target_info exists gdb_stub_step_command] { - set command [target_info gdb_stub_step_command]; - } else { - set command "step"; - } - send_gdb "${command}\n"; - set tries 0; - gdb_expect 60 { - -re "(main.* at |.*in .*start).*$gdb_prompt" { - return; - } - -re ".*$gdb_prompt" { - incr tries; - if { $tries == 5 } { - fail "stepping out of breakpoint function"; - return; - } - send_gdb "${command}\n"; - exp_continue; - } - default { - fail "stepping out of breakpoint function"; - return; - } - } - } - send_gdb "where\n"; - gdb_expect { - -re "main\[^\r\n\]*at \(\[^:]+\):\(\[0-9\]+\)" { - set file $expect_out(1,string); - set linenum [expr $expect_out(2,string) + 1]; - set breakplace "${file}:${linenum}"; - } - default {} - } - send_gdb "break ${breakplace}\n"; - gdb_expect 60 { - -re "Breakpoint (\[0-9\]+) at.*$gdb_prompt" { - set breakpoint $expect_out(1,string); - } - -re "Breakpoint (\[0-9\]+): file.*$gdb_prompt" { - set breakpoint $expect_out(1,string); - } - default {} - } - send_gdb "continue\n"; - gdb_expect 60 { - -re "Breakpoint ${breakpoint},.*$gdb_prompt" { - gdb_test "delete $breakpoint" ".*" ""; - return; - } - default {} - } -} - -### gdb_get_line_number TEXT [FILE] -### -### Search the source file FILE, and return the line number of a line -### containing TEXT. Use this function instead of hard-coding line -### numbers into your test script. -### -### Specifically, this function uses GDB's "search" command to search -### FILE for the first line containing TEXT, and returns its line -### number. Thus, FILE must be a source file, compiled into the -### executable you are running. If omitted, FILE defaults to the -### value of the global variable `srcfile'; most test scripts set -### `srcfile' appropriately at the top anyway. -### -### Use this function to keep your test scripts independent of the -### exact line numbering of the source file. Don't write: -### -### send_gdb "break 20" -### -### This means that if anyone ever edits your test's source file, -### your test could break. Instead, put a comment like this on the -### source file line you want to break at: -### -### /* breakpoint spot: frotz.exp: test name */ -### -### and then write, in your test script (which we assume is named -### frotz.exp): -### -### send_gdb "break [gdb_get_line_number "frotz.exp: test name"]\n" -### -### (Yes, Tcl knows how to handle the nested quotes and brackets. -### Try this: -### $ tclsh -### % puts "foo [lindex "bar baz" 1]" -### foo baz -### % -### Tcl is quite clever, for a little stringy language.) - -proc gdb_get_line_number {text {file /omitted/}} { - global gdb_prompt; - global srcfile; - - if {! [string compare $file /omitted/]} { - set file $srcfile - } - - set result -1; - gdb_test "list ${file}:1,1" ".*" "" - send_gdb "search ${text}\n" - gdb_expect { - -re "\[\r\n\]+(\[0-9\]+)\[ \t\].*${text}.*$gdb_prompt $" { - set result $expect_out(1,string) - } - -re ".*$gdb_prompt $" { - fail "find line number containing \"${text}\"" - } - timeout { - fail "find line number containing \"${text}\" (timeout)" - } - } - return $result; -} - -# gdb_continue_to_end: -# The case where the target uses stubs has to be handled specially. If a -# stub is used, we set a breakpoint at exit because we cannot rely on -# exit() behavior of a remote target. -# -# mssg is the error message that gets printed. - -proc gdb_continue_to_end {mssg} { - if [target_info exists use_gdb_stub] { - if {![gdb_breakpoint "exit"]} { - return 0 - } - gdb_test "continue" "Continuing..*Breakpoint .*exit.*" \ - "continue until exit at $mssg" - } else { - # Continue until we exit. Should not stop again. - # Don't bother to check the output of the program, that may be - # extremely tough for some remote systems. - gdb_test "continue"\ - "Continuing.\[\r\n0-9\]+(... EXIT code 0\[\r\n\]+|)Program exited normally\\..*"\ - "continue until exit at $mssg" - } -} - -proc rerun_to_main {} { - global gdb_prompt - - if [target_info exists use_gdb_stub] { - gdb_run_cmd - gdb_expect { - -re ".*Breakpoint .*main .*$gdb_prompt $"\ - {pass "rerun to main" ; return 0} - -re "$gdb_prompt $"\ - {fail "rerun to main" ; return 0} - timeout {fail "(timeout) rerun to main" ; return 0} - } - } else { - send_gdb "run\n" - gdb_expect { - -re "Starting program.*$gdb_prompt $"\ - {pass "rerun to main" ; return 0} - -re "$gdb_prompt $"\ - {fail "rerun to main" ; return 0} - timeout {fail "(timeout) rerun to main" ; return 0} - } - } -} - -# Print a message and return true if a test should be skipped -# due to lack of floating point suport. - -proc gdb_skip_float_test { msg } { - if [target_info exists gdb,skip_float_tests] { - verbose "Skipping test '$msg': no float tests."; - return 1; - } - return 0; -} - -# Print a message and return true if a test should be skipped -# due to lack of stdio support. - -proc gdb_skip_stdio_test { msg } { - if [target_info exists gdb,noinferiorio] { - verbose "Skipping test '$msg': no inferior i/o."; - return 1; - } - return 0; -} - -proc gdb_skip_bogus_test { msg } { - return 0; -} - diff --git a/gdb/testsuite/lib/insight-support.exp b/gdb/testsuite/lib/insight-support.exp deleted file mode 100644 index 42d14a9..0000000 --- a/gdb/testsuite/lib/insight-support.exp +++ /dev/null @@ -1,310 +0,0 @@ -# GDB Testsuite Support for Insight. -# -# Copyright 2001 Red Hat, Inc. -# -# This program is free software; you can redistribute it and/or modify it -# under the terms of the GNU General Public License (GPL) as published by -# the Free Software Foundation; either version 2 of the License, or (at -# your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. - -# Initializes the display for gdbtk testing. -# Returns 1 if tests should run, 0 otherwise. -proc gdbtk_initialize_display {} { - global _using_windows - - # This is hacky, but, we don't have much choice. When running - # expect under Windows, tcl_platform(platform) is "unix". - if {![info exists _using_windows]} { - set _using_windows [expr {![catch {exec cygpath --help}]}] - } - - if {![_gdbtk_xvfb_init]} { - if {$_using_windows} { - untested "No GDB_DISPLAY -- skipping tests" - } else { - untested "No GDB_DISPLAY or Xvfb -- skipping tests" - } - - return 0 - } - - return 1 -} - -# From dejagnu: -# srcdir = testsuite src dir (e.g., devo/gdb/testsuite) -# objdir = testsuite obj dir (e.g., gdb/testsuite) -# subdir = subdir of testsuite (e.g., gdb.gdbtk) -# -# To gdbtk: -# env(DEFS)=the "defs" files (e.g., devo/gdb/testsuite/gdb.gdbtk/defs) -# env(SRCDIR)=directory containing the test code (e.g., *.test) -# env(OBJDIR)=directory which contains any executables -# (e.g., gdb/testsuite/gdb.gdbtk) -proc gdbtk_start {test} { - global verbose - global GDB - global GDBFLAGS - global env srcdir subdir objdir - - gdb_stop_suppressing_tests; - - verbose "Starting $GDB -nx -q --tclcommand=$test" - - set real_test [which $test] - if {$real_test == 0} { - perror "$test is not found" - exit 1 - } - - if {![is_remote host]} { - if { [which $GDB] == 0 } { - perror "$GDB does not exist." - exit 1 - } - } - - set wd [pwd] - - # Find absolute path to test - set test [to_tcl_path -abs $test] - - # Set some environment variables - cd $srcdir - set abs_srcdir [pwd] - set env(DEFS) [to_tcl_path -abs [file join $abs_srcdir $subdir defs]] - - cd $wd - cd [file join $objdir $subdir] - set env(OBJDIR) [pwd] - cd $wd - - # Set info about target into env - _gdbtk_export_target_info - - set env(SRCDIR) $abs_srcdir - set env(GDBTK_VERBOSE) 1 - set env(GDBTK_LOGFILE) [to_tcl_path [file join $objdir gdb.log]] - - set err [catch {exec $GDB -nx -q --tclcommand=$test} res] - if { $err } { - perror "Execing $GDB failed: $res" - append res "\nERROR gdb-crash" - } - return $res -} - -# Start xvfb when using it. -# The precedence is: -# 1. If GDB_DISPLAY is set (and not ""), use it -# 2. If Xvfb exists, use it (not on cygwin) -# 3. Skip tests -proc _gdbtk_xvfb_init {} { - global env spawn_id _xvfb_spawn_id _using_windows - - if {[info exists env(GDB_DISPLAY)]} { - if {$env(GDB_DISPLAY) != ""} { - set env(DISPLAY) $env(GDB_DISPLAY) - } else { - # Suppress tests - return 0 - } - } elseif {!$_using_windows && [which Xvfb] != 0} { - set screen ":[getpid]" - set pid [spawn Xvfb $screen -ac] - set _xvfb_spawn_id $spawn_id - set env(DISPLAY) localhost$screen - } else { - # No Xvfb found -- skip test - return 0 - } - - return 1 -} - -# Kill xvfb -proc _gdbtk_xvfb_exit {} { - global objdir subdir env _xvfb_spawn_id - - if {[info exists _xvfb_spawn_id]} { - exec kill [exp_pid -i $_xvfb_spawn_id] - wait -i $_xvfb_spawn_id - } -} - -# help proc for setting tcl-style paths from unix-style paths -# pass "-abs" to make it an absolute path -proc to_tcl_path {unix_path {arg {}}} { - global _using_windows - - if {[string compare $unix_path "-abs"] == 0} { - set unix_path $arg - set wd [pwd] - cd [file dirname $unix_path] - set dirname [pwd] - set unix_name [file join $dirname [file tail $unix_path]] - cd $wd - } - - if {$_using_windows} { - set unix_path [exec cygpath -aw $unix_path] - set unix_path [join [split $unix_path \\] /] - } - - return $unix_path -} - -# Set information about the target into the environment -# variable TARGET_INFO. This array will contain a list -# of commands that are necessary to run a target. -# -# This is mostly devined from how dejagnu works, what -# procs are defined, and analyzing unix.exp, monitor.exp, -# and sim.exp. -# -# Array elements exported: -# Index Meaning -# ----- ------- -# init list of target/board initialization commands -# target target command for target/board -# load load command for target/board -# run run command for target_board -proc _gdbtk_export_target_info {} { - global env - - # Figure out what "target class" the testsuite is using, - # i.e., sim, monitor, native - if {[string compare [info proc gdb_target_monitor] gdb_target_monitor] == 0} { - # Using a monitor/remote target - set target monitor - } elseif {[string compare [info proc gdb_target_sim] gdb_target_sim] == 0} { - # Using a simulator target - set target simulator - } elseif {[string compare [info proc gdb_target_sid] gdb_target_sid] == 0} { - # Using sid - set target sid - } else { - # Assume native - set target native - } - - # Now setup the array to be exported. - set info(init) {} - set info(target) {} - set info(load) {} - set info(run) {} - - switch $target { - simulator { - set opts "[target_info gdb,target_sim_options]" - set info(target) "target sim $opts" - set info(load) "load" - set info(run) "run" - } - - monitor { - # Setup options for the connection - if {[target_info exists baud]} { - lappend info(init) "set remotebaud [target_info baud]" - } - if {[target_info exists binarydownload]} { - lappend info(init) "set remotebinarydownload [target_info binarydownload]" - } - if {[target_info exists disable_x_packet]} { - lappend info(init) "set remote X-packet disable" - } - if {[target_info exists disable_z_packet]} { - lappend info(init) "set remote Z-packet disable" - } - - # Get target name and connection info - if {[target_info exists gdb_protocol]} { - set targetname "[target_info gdb_protocol]" - } else { - set targetname "not_specified" - } - if {[target_info exists gdb_serial]} { - set serialport "[target_info gdb_serial]" - } elseif {[target_info exists netport]} { - set serialport "[target_info netport]" - } else { - set serialport "[target_info serial]" - } - - set info(target) "target $targetname $serialport" - set info(load) "load" - set info(run) "continue" - } - - sid { - # We must start sid first, since Insight won't have a clue - # about how to do this. - sid_start - set info(target) "target [target_info gdb_protocol] [target_info netport]" - set info(load) "load" - set info(run) "continue" - } - - native { - set info(run) "run" - } - } - - # Export the array to the environment - set env(TARGET_INFO) [array get info] -} - -# gdbtk tests call this function to print out the results of the -# tests. The argument is a proper list of lists of the form: -# {status name description msg}. All of these things typically -# come from the testsuite harness. -proc gdbtk_analyze_results {results} { - foreach test $results { - set status [lindex $test 0] - set name [lindex $test 1] - set description [lindex $test 2] - set msg [lindex $test 3] - - switch $status { - PASS { - pass "$description ($name)" - } - - FAIL { - fail "$description ($name)" - } - - ERROR { - perror "$name" - } - - XFAIL { - xfail "$description ($name)" - } - - XPASS { - xpass "$description ($name)" - } - } - } -} - -proc gdbtk_done {{results {}}} { - global _xvfb_spawn_id - gdbtk_analyze_results $results - - # Kill off xvfb if using it - if {[info exists _xvfb_spawn_id]} { - _gdbtk_xvfb_exit - } - - # Yich. If we're using sid, we must kill it - if {[string compare [info proc gdb_target_sid] gdb_target_sid] == 0} { - sid_exit - } -} diff --git a/gdb/testsuite/lib/java.exp b/gdb/testsuite/lib/java.exp deleted file mode 100644 index bcfd27c..0000000 --- a/gdb/testsuite/lib/java.exp +++ /dev/null @@ -1,105 +0,0 @@ -# Copyright (C) 1998, 1999 Red Hat, Inc. - -load_lib "libgloss.exp" - -# GCJ_UNDER_TEST is the compiler under test. - -global tmpdir - -if ![info exists tmpdir] { - set tmpdir "/tmp" -} - -set java_initialized 0 - -# -# Build the status wrapper library as needed. -# -proc java_init { args } { - global wrapper_file; - global wrap_compile_flags; - global java_initialized - global GCJ_UNDER_TEST - global TOOL_EXECUTABLE - global env - - if { $java_initialized == 1 } { return; } - - if ![info exists GCJ_UNDER_TEST] { - if [info exists TOOL_EXECUTABLE] { - set GCJ_UNDER_TEST $TOOL_EXECUTABLE; - } else { - if [info exists env(GCJ)] { - set GCJ_UNDER_TEST $env(GCJ) - } else { - global tool_root_dir - - if ![is_remote host] { - set file [lookfor_file $tool_root_dir gcj]; - if { $file == "" } { - set file [lookfor_file $tool_root_dir gcc/gcj]; - } - if { $file != "" } { - set CC "$file -B[file dirname $file]/ --specs=$tool_root_dir/$target_alias/libjava/libgcj-test.spec"; - } else { - set CC [transform gcj]; - } - } else { - set CC [transform gcj] - } - set GCJ_UNDER_TEST $CC - } - } - } - - set wrapper_file ""; - set wrap_compile_flags ""; - if [target_info exists needs_status_wrapper] { - set result [build_wrapper "testglue.o"]; - if { $result != "" } { - set wrapper_file [lindex $result 0]; - set wrap_compile_flags [lindex $result 1]; - } else { - warning "Status wrapper failed to build." - } - } - - set java_initialized 1 -} - -# -# Run the test specified by srcfile and resultfile. compile_args and -# exec_args are options telling this proc how to work. -# -proc compile_java_from_source { srcfile binfile compile_args } { - global GCJ_UNDER_TEST - global runtests - global java_initialized - - if { $java_initialized != 1 } { java_init } - - set errname [file rootname [file tail $srcfile]] - if {! [runtest_file_p $runtests $errname]} { - return - } - - set args "compiler=$GCJ_UNDER_TEST" - lappend args "additional_flags=--main=[file rootname [file tail $srcfile]]" - if { $compile_args != "" } { - lappend args "additional_flags=$compile_args" - } - - if { $compile_args != "" } { - set errname "$errname $compile_args" - } - - set x [target_compile $srcfile ${binfile} ${binfile} $args] - if { $x != "" } { - verbose "target_compile failed: $x" 2 - return "$errname compilation from source"; - } -} - -# Local Variables: -# tcl-indent-level:4 -# End: diff --git a/gdb/testsuite/lib/mi-support.exp b/gdb/testsuite/lib/mi-support.exp deleted file mode 100644 index d3861e1..0000000 --- a/gdb/testsuite/lib/mi-support.exp +++ /dev/null @@ -1,788 +0,0 @@ -# Copyright 1999, 2000 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 -# (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 - -# 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" -} - -set MIFLAGS "-i=mi" - -# -# 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 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 $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 -} - -# -# start gdb -- start gdb running, default procedure -# -# 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 mi_gdb_start { } { - global verbose - global GDB - global GDBFLAGS - global gdb_prompt - global mi_gdb_prompt - global timeout - global gdb_spawn_id; - global MIFLAGS - - gdb_stop_suppressing_tests; - - # Start SID. - if { [info procs sid_start] != "" } { - verbose "Spawning SID" - sid_start - } - - verbose "Spawning $GDB -nw $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 - } - } - set res [remote_spawn host "$GDB -nw $GDBFLAGS $MIFLAGS [host_info gdb_opts]"]; - if { $res < 0 || $res == "" } { - perror "Spawning $GDB failed." - return 1; - } - gdb_expect { - -re ".*$mi_gdb_prompt$" { - 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; - 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." - } - } - - return 0; -} - -# 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 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=\\\[\\\]\}" {} - -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 suppress_flag - if { $suppress_flag } { - return - } - - if [is_remote host] { - return ""; - } - - 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)"} - } - - 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." - } - } -} - -# -# load a file into the debugger. -# return a -1 if anything goes wrong. -# -proc mi_gdb_load { arg } { - global verbose - global loadpath - global loadfile - global GDB - global mi_gdb_prompt - upvar timeout timeout - - # ``gdb_unload'' - - # ``gdb_file_cmd'' -# 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" - # All OK - } - -re "has no symbol-table.*$mi_gdb_prompt$" { - perror "$arg wasn't compiled with \"-g\"" - return -1 - } - -re "A program is being debugged already.*Kill it.*y or n. $" { - send_gdb "y\n" - verbose "\t\tKilling previous program being debugged" - exp_continue - } - -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 are just giving the prompt back for now - # All OK - } - 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 - } - } - - # ``load'' - if { [info procs send_target_sid] != "" } { - # For SID, things get complex - send_target_sid - gdb_expect 60 { - -re "\\^done,.*$mi_gdb_prompt$" { - } - timeout { - perror "Unable to connect to SID target" - return -1 - } - } - send_gdb "48-target-download\n" - gdb_expect 10 { - -re "48\\^done.*$mi_gdb_prompt$" { - } - timeout { - perror "Unable to download to SID target" - 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 { - -re "47\\^connected.*$mi_gdb_prompt$" { - } - timeout { - perror "Unable to select sim target" - return -1 - } - } - send_gdb "48-target-download\n" - gdb_expect 10 { - -re "48\\^done.*$mi_gdb_prompt$" { - } - timeout { - perror "Unable to download to sim target" - return -1 - } - } - } - return 0 -} - -# mi_gdb_test COMMAND PATTERN MESSAGE -- 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 an optional message to be printed. If this is -# omitted, then the pass/fail messages use the command string as the -# message. (If this is the empty string, then sometimes we don't -# call pass or fail at all; I don't understand this at all.) -# -# 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 - upvar timeout timeout - - if [llength $args]>2 then { - set message [lindex $args 2] - } else { - set message [lindex $args 0] - } - set command [lindex $args 0] - set pattern [lindex $args 1] - - 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"; - 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; - } - } - 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 "(${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 "\[\r\n\]*($pattern)\[\r\n\]+$mi_gdb_prompt\[ \]*$" { - if ![string match "" $message] then { - pass "$message" - } - set result 0 - } - -re "Program exited 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 - } - } - 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 {args} { - global suppress_flag - if { $suppress_flag } { - return -1 - } - global mi_gdb_prompt - - 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; - } - } - } - - if [target_info exists use_gdb_stub] { - if [target_info exists gdb,do_reload_on_run] { - # Specifying no file, defaults to the executable - # currently being debugged. - if { [mi_gdb_load ""] < 0 } { - return; - } - send_gdb "000-exec-continue\n"; - gdb_expect 60 { - -re "Continu\[^\r\n\]*\[\r\n\]" {} - default {} - } - return; - } - - 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 - } - - send_gdb "000-exec-run $args\n" - gdb_expect { - -re "000\\^running\r\n${mi_gdb_prompt}" { - } - timeout { - perror "Unable to start target" - return - } - } - # NOTE: Shortly after this there will be a ``000*stopping,...(gdb)'' -} - -# -# 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 mi_gdb_prompt - global hex - global decimal - global srcdir - global subdir - global binfile - global srcfile - - set test "mi run-to-main" - mi_delete_breakpoints - mi_gdb_reinitialize_dir $srcdir/$subdir - mi_gdb_load ${binfile} - - mi_gdb_test "200-break-insert main" \ - "200\\^done,bkpt=\{number=\"1\",type=\"breakpoint\",disp=\"keep\",enabled=\"y\",addr=\"$hex\",func=\"main\",file=\".*\",line=\"\[0-9\]*\",times=\"0\"\}" \ - "breakpoint at main" - - mi_run_cmd - gdb_expect { - -re "000\\*stopped,reason=\"breakpoint-hit\",bkptno=\"1\",thread-id=\"$decimal\",frame=\{addr=\"$hex\",func=\"main\",args=\(\\\[\\\]\|\{\}\),file=\".*\",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 - } - } -} - - -# Next to the next statement - -proc mi_next { test } { - global suppress_flag - if { $suppress_flag } { - return -1 - } - global mi_gdb_prompt - send_gdb "220-exec-next\n" - gdb_expect { - -re "220\\^running\r\n${mi_gdb_prompt}220\\*stopped,reason=\"end-stepping-range\",thread-id=\"$decimal\",frame=\{addr=\"$hex\",func=\".*\",args=\[\\\[\{].*[\\\]\}\],file=\".*\",line=\"\[0-9\]*\"\}\r\n$mi_gdb_prompt$" { - pass "$test" - return 0 - } - timeout { - fail "$test" - return -1 - } - } -} - - -# Step to the next statement - -proc mi_step { test } { - global suppress_flag - if { $suppress_flag } { - return -1 - } - global mi_gdb_prompt - send_gdb "220-exec-step\n" - gdb_expect { - -re "220\\^running\r\n${mi_gdb_prompt}220\\*stopped,reason=\"end-stepping-range\",thread-id=\"$decimal\",frame=\{addr=\"$hex\",func=\".*\",args=\[\\\[\{\].*\[\\\]\}\],file=\".*\",line=\"\[0-9\]*\"\}\r\n$mi_gdb_prompt$" { - pass "$test" - return 0 - } - timeout { - fail "$test" - 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_run_to_helper { cmd reason func args file line extra test } { - global suppress_flag - if { $suppress_flag } { - return -1 - } - global mi_gdb_prompt - global hex - global decimal - send_gdb "220-$cmd\n" - 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\",line=\"$line\"\}$extra\r\n$mi_gdb_prompt$" { - pass "$test" - return 0 - } - -re "220\\^running\r\n${mi_gdb_prompt}220\\*stopped,reason=\"$reason\",thread-id=\"$decimal\",frame=\{addr=\"$hex\",func=\".*\",args=\[\\\[\{\].*\[\\\]\}\],file=\".*\",line=\"\[0-9\]*\"\}.*\r\n$mi_gdb_prompt$" { - fail "$test (stopped at wrong place)" - return -1 - } - -re "220\\^running\r\n${mi_gdb_prompt}.*\r\n${mi_gdb_prompt}$" { - fail "$test (unknown output after running)" - return -1 - } - timeout { - fail "$test (timeout)" - return -1 - } - } -} - -proc mi_run_to { cmd reason func args file line extra test } { - mi_run_to_helper "$cmd" "$reason" "$func" "\\\[$args\\\]" \ - "$file" "$line" "$extra" "$test" -} - -proc mi_next_to { func args file line test } { - mi_run_to "exec-next" "end-stepping-range" "$func" "$args" \ - "$file" "$line" "" "$test" -} - -proc mi_step_to { func args file line test } { - mi_run_to "exec-step" "end-stepping-range" "$func" "$args" \ - "$file" "$line" "" "$test" -} - -proc mi_finish_to { func args file line result ret test } { - mi_run_to "exec-finish" "function-finished" "$func" "$args" \ - "$file" "$line" \ - ",gdb-result-var=\"$result\",return-value=\"$ret\"" \ - "$test" -} - -proc mi_continue_to { bkptno func args file line test } { - mi_run_to "exec-continue" "breakpoint-hit\",bkptno=\"$bkptno" \ - "$func" "$args" "$file" "$line" "" "$test" -} - -proc mi0_run_to { cmd reason func args file line extra test } { - mi_run_to_helper "$cmd" "$reason" "$func" "\{$args\}" \ - "$file" "$line" "$extra" "$test" -} - -proc mi0_next_to { func args file line test } { - mi0_run_to "exec-next" "end-stepping-range" "$func" "$args" \ - "$file" "$line" "" "$test" -} - -proc mi0_step_to { func args file line test } { - mi0_run_to "exec-step" "end-stepping-range" "$func" "$args" \ - "$file" "$line" "" "$test" -} - -proc mi0_finish_to { func args file line result ret test } { - mi0_run_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_run_to "exec-continue" "breakpoint-hit\",bkptno=\"$bkptno" \ - "$func" "$args" "$file" "$line" "" "$test" -} diff --git a/gdb/testsuite/lib/trace-support.exp b/gdb/testsuite/lib/trace-support.exp deleted file mode 100644 index 4765791..0000000 --- a/gdb/testsuite/lib/trace-support.exp +++ /dev/null @@ -1,307 +0,0 @@ -# Copyright (C) 1998 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 -# (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 - - -# -# Support procedures for trace testing -# - - -# -# Procedure: gdb_target_supports_trace -# Returns true if GDB is connected to a target that supports tracing. -# Allows tests to abort early if not running on a trace-aware target. -# - -proc gdb_target_supports_trace { } { - global gdb_prompt - - send_gdb "tstatus\n" - gdb_expect { - -re "\[Tt\]race can only be run on.*$gdb_prompt $" { - return 0 - } - -re "\[Tt\]race can not be run on.*$gdb_prompt $" { - return 0 - } - -re "\[Tt\]arget does not support.*$gdb_prompt $" { - return 0 - } - -re ".*\[Ee\]rror.*$gdb_prompt $" { - return 0 - } - -re ".*\[Ww\]arning.*$gdb_prompt $" { - return 0 - } - -re ".*$gdb_prompt $" { - return 1 - } - timeout { - return 0 - } - } -} - - -# -# Procedure: gdb_delete_tracepoints -# Many of the tests depend on setting tracepoints at various places and -# running until that tracepoint is reached. At times, we want to start -# with a clean slate with respect to tracepoints, so this utility proc -# lets us do this without duplicating this code everywhere. -# - -proc gdb_delete_tracepoints {} { - global gdb_prompt - - send_gdb "delete tracepoints\n" - gdb_expect 30 { - -re "Delete all tracepoints.*y or n.*$" { - send_gdb "y\n"; - exp_continue - } - -re ".*$gdb_prompt $" { # This happens if there were no tracepoints } - timeout { - perror "Delete all tracepoints in delete_tracepoints (timeout)" - return - } - } - send_gdb "info tracepoints\n" - gdb_expect 30 { - -re "No tracepoints.*$gdb_prompt $" {} - -re "$gdb_prompt $" { perror "tracepoints not deleted" ; return } - timeout { perror "info tracepoints (timeout)" ; return } - } -} - -# -# Procedure: gdb_trace_setactions -# Define actions for a tracepoint. -# Arguments: -# testname -- identifying string for pass/fail output -# tracepoint -- to which tracepoint do these actions apply? (optional) -# args -- list of actions to be defined. -# Returns: -# zero -- success -# non-zero -- failure - -proc gdb_trace_setactions { testname tracepoint args } { - global gdb_prompt; - - set state 0; - set passfail "pass"; - send_gdb "actions $tracepoint\n"; - set expected_result ""; - gdb_expect 5 { - -re "No tracepoint number .*$gdb_prompt $" { - fail $testname - return 1; - } - -re "Enter actions for tracepoint $tracepoint.*>" { - if { [llength $args] > 0 } { - set lastcommand "[lindex $args $state]"; - send_gdb "[lindex $args $state]\n"; - incr state; - set expected_result [lindex $args $state]; - incr state; - } else { - send_gdb "end\n"; - } - exp_continue; - } - -re "\(.*\)\[\r\n\]+\[ \t]*> $" { - if { $expected_result != "" } { - regsub "^\[^\r\n\]+\[\r\n\]+" "$expect_out(1,string)" "" out; - if ![regexp $expected_result $out] { - set passfail "fail"; - } - set expected_result ""; - } - if { $state < [llength $args] } { - send_gdb "[lindex $args $state]\n"; - incr state; - set expected_result [lindex $args $state]; - incr state; - } else { - send_gdb "end\n"; - set expected_result ""; - } - exp_continue; - } - -re "\(.*\)$gdb_prompt $" { - if { $expected_result != "" } { - if ![regexp $expected_result $expect_out(1,string)] { - set passfail "fail"; - } - set expected_result ""; - } - if { [llength $args] < $state } { - set passfail "fail"; - } - } - default { - set passfail "fail"; - } - } - if { $testname != "" } { - $passfail $testname; - } - if { $passfail == "pass" } then { - return 0; - } else { - return 1; - } -} - -# -# Procedure: gdb_tfind_test -# Find a specified trace frame. -# Arguments: -# testname -- identifying string for pass/fail output -# tfind_arg -- frame (line, PC, etc.) identifier -# exp_res -- Expected result of frame test -# args -- Test expression -# Returns: -# zero -- success -# non-zero -- failure -# - -proc gdb_tfind_test { testname tfind_arg exp_res args } { - global gdb_prompt; - - if { "$args" != "" } { - set expr "$exp_res"; - set exp_res "$args"; - } else { - set expr "(int) \$trace_frame"; - } - set passfail "fail"; - - gdb_test "tfind $tfind_arg" "" "" - send_gdb "printf \"x \%d x\\n\", $expr\n"; - gdb_expect 10 { - -re "x (-*\[0-9\]+) x" { - if { $expect_out(1,string) == $exp_res } { - set passfail "pass"; - } - exp_continue; - } - -re "$gdb_prompt $" { } - } - $passfail "$testname"; - if { $passfail == "pass" } then { - return 0; - } else { - return 1; - } -} - -# -# Procedure: gdb_readexpr -# Arguments: -# gdb_expr -- the expression whose value is desired -# Returns: -# the value of gdb_expr, as evaluated by gdb. -# [FIXME: returns -1 on error, which is sometimes a legit value] -# - -proc gdb_readexpr { gdb_expr } { - global gdb_prompt; - - set result -1; - send_gdb "print $gdb_expr\n" - gdb_expect 5 { - -re "\[$\].*= (\[0-9\]+).*$gdb_prompt $" { - set result $expect_out(1,string); - } - -re "$gdb_prompt $" { } - default { } - } - return $result; -} - -# -# Procedure: gdb_gettpnum -# Arguments: -# tracepoint (optional): if supplied, set a tracepoint here. -# Returns: -# the tracepoint ID of the most recently set tracepoint. -# - -proc gdb_gettpnum { tracepoint } { - global gdb_prompt; - - if { $tracepoint != "" } { - gdb_test "trace $tracepoint" "" "" - } - return [gdb_readexpr "\$tpnum"]; -} - - -# -# Procedure: gdb_find_function_baseline -# Arguments: -# func_name -- name of source function -# Returns: -# Sourcefile line of function definition (open curly brace), -# or -1 on failure. Caller must check return value. -# Note: -# Works only for open curly brace at beginning of source line! -# - -proc gdb_find_function_baseline { func_name } { - global gdb_prompt; - - set baseline -1; - - send_gdb "list $func_name\n" -# gdb_expect { -# -re "\[\r\n\]\[\{\].*$gdb_prompt $" { -# set baseline 1 -# } -# } -} - -# -# Procedure: gdb_find_function_baseline -# Arguments: -# filename: name of source file of desired function. -# Returns: -# Sourcefile line of function definition (open curly brace), -# or -1 on failure. Caller must check return value. -# Note: -# Works only for open curly brace at beginning of source line! -# - -proc gdb_find_recursion_test_baseline { filename } { - global gdb_prompt; - - set baseline -1; - - gdb_test "list $filename:1" "" "" - send_gdb "search gdb_recursion_test line 0\n" - gdb_expect { - -re "(\[0-9\]+)\[\t \]+\{.*line 0.*$gdb_prompt $" { - set baseline $expect_out(1,string); - } - -re "$gdb_prompt $" { } - default { } - } - return $baseline; -} |