diff options
Diffstat (limited to 'gdb/testsuite/lib/gdb.exp')
| -rw-r--r-- | gdb/testsuite/lib/gdb.exp | 186 |
1 files changed, 142 insertions, 44 deletions
diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp index a3392219bb8..dca41dc9134 100644 --- a/gdb/testsuite/lib/gdb.exp +++ b/gdb/testsuite/lib/gdb.exp @@ -1,4 +1,5 @@ -# Copyright 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000 +# Copyright 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, +# 2002, 2003 # Free Software Foundation, Inc. # This program is free software; you can redistribute it and/or modify @@ -360,50 +361,93 @@ proc gdb_continue_to_breakpoint {name} { -# gdb_test COMMAND PATTERN MESSAGE QUESTION RESPONSE +# gdb_test_multiple COMMAND MESSAGE EXPECT_ARGUMENTS # 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. +# MESSAGE is a message to be printed with the built-in failure patterns +# if one of them matches. If MESSAGE is empty COMMAND will be used. +# EXPECT_ARGUMENTS will be fed to expect in addition to the standard +# patterns. Pattern elements will be evaluated in the caller's +# context; action elements will be executed in the caller's context. +# Unlike patterns for gdb_test, these patterns should generally include +# the final newline and prompt. # # Returns: -# 1 if the test failed, -# 0 if the test passes, +# 1 if the test failed, according to a built-in failure pattern +# 0 if only user-supplied patterns matched # -1 if there was an internal error. # -proc gdb_test { args } { +proc gdb_test_multiple { command message user_code } { 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] + if { $message == "" } { + set message $command } - 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$" - } + # TCL/EXPECT WART ALERT + # Expect does something very strange when it receives a single braced + # argument. It splits it along word separators and performs substitutions. + # This means that { "[ab]" } is evaluated as "[ab]", but { "\[ab\]" } is + # evaluated as "\[ab\]". But that's not how TCL normally works; inside a + # double-quoted list item, "\[ab\]" is just a long way of representing + # "[ab]", because the backslashes will be removed by lindex. + + # Unfortunately, there appears to be no easy way to duplicate the splitting + # that expect will do from within TCL. And many places make use of the + # "\[0-9\]" construct, so we need to support that; and some places make use + # of the "[func]" construct, so we need to support that too. In order to + # get this right we have to substitute quoted list elements differently + # from braced list elements. + + # We do this roughly the same way that Expect does it. We have to use two + # lists, because if we leave unquoted newlines in the argument to uplevel + # they'll be treated as command separators, and if we escape newlines + # we mangle newlines inside of command blocks. This assumes that the + # input doesn't contain a pattern which contains actual embedded newlines + # at this point! + + regsub -all {\n} ${user_code} { } subst_code + set subst_code [uplevel list $subst_code] + + set processed_code "" + set patterns "" + set expecting_action 0 + foreach item $user_code subst_item $subst_code { + if { $item == "-n" || $item == "-notransfer" || $item == "-nocase" } { + lappend processed_code $item + continue + } + if {$item == "-indices" || $item == "-re" || $item == "-ex"} { + lappend processed_code $item + continue + } + if { $expecting_action } { + lappend processed_code "uplevel [list $item]" + set expecting_action 0 + # Cosmetic, no effect on the list. + append processed_code "\n" + continue + } + set expecting_action 1 + lappend processed_code $subst_item + if {$patterns != ""} { + append patterns "; " + } + append patterns "\"$subst_item\"" + } + + # Also purely cosmetic. + regsub -all {\r} $patterns {\\r} patterns + regsub -all {\n} $patterns {\\n} patterns if $verbose>2 then { send_user "Sending \"$command\" to gdb\n" - send_user "Looking to match \"$pattern\"\n" + send_user "Looking to match \"$patterns\"\n" send_user "Message is \"$message\"\n" } @@ -465,13 +509,14 @@ proc gdb_test { args } { } } } - gdb_expect $tmt { + + set code { -re "\\*\\*\\* DOSEXIT code.*" { if { $message != "" } { fail "$message"; } gdb_suppress_entire_file "GDB died"; - return -1; + set result -1; } -re "Ending remote debugging.*$gdb_prompt $" { if ![isnative] then { @@ -481,16 +526,9 @@ proc gdb_test { args } { 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; - } + } + append code $processed_code + append code { -re "Undefined\[a-z\]* command:.*$gdb_prompt $" { perror "Undefined command \"$command\"." fail "$message" @@ -508,7 +546,7 @@ proc gdb_test { args } { set errmsg "$command: the program exited" } fail "$errmsg" - return -1 + set result -1 } -re "EXIT code \[0-9\r\n\]+Program exited normally.*$gdb_prompt $" { if ![string match "" $message] then { @@ -517,7 +555,7 @@ proc gdb_test { args } { set errmsg "$command: the program exited" } fail "$errmsg" - return -1 + set result -1 } -re "The program is not being run.*$gdb_prompt $" { if ![string match "" $message] then { @@ -526,7 +564,7 @@ proc gdb_test { args } { set errmsg "$command: the program is no longer running" } fail "$errmsg" - return -1 + set result -1 } -re ".*$gdb_prompt $" { if ![string match "" $message] then { @@ -538,11 +576,13 @@ proc gdb_test { args } { send_gdb "\n" perror "Window too small." fail "$message" + set result -1 } -re "\\(y or n\\) " { send_gdb "n\n" perror "Got interactive prompt." fail "$message" + set result -1 } eof { perror "Process no longer exists" @@ -554,6 +594,7 @@ proc gdb_test { args } { full_buffer { perror "internal buffer is full." fail "$message" + set result -1 } timeout { if ![string match "" $message] then { @@ -562,8 +603,65 @@ proc gdb_test { args } { set result 1 } } + + set result 0 + gdb_expect $tmt $code return $result } + +# 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$" + } + + return [gdb_test_multiple $command $message { + -re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" { + if ![string match "" $message] then { + pass "$message" + } + } + -re "(${question_string})$" { + send_gdb "$response_string\n"; + exp_continue; + } + }] +} # Test that a command gives an error. For pass or fail, return # a 1 to indicate that more tests can proceed. However a timeout @@ -1134,7 +1232,7 @@ proc gdb_compile {source dest type options} { set result [target_compile $source $dest $type $options]; regsub "\[\r\n\]*$" "$result" "" result; regsub "^\[\r\n\]*" "$result" "" result; - if { $result != "" } { + if { $result != "" && [lsearch $options quiet] == -1} { clone_output "gdb compile failed, $result" } return $result; @@ -1150,7 +1248,7 @@ proc gdb_compile_pthreads {source dest type options} { 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 options_with_lib [concat $options [list libs=$lib quiet]] set ccout [gdb_compile $source $dest $type $options_with_lib] switch -regexp -- $ccout { ".*no posix threads support.*" { |