[gdb/testsuite] Introduce gdb_test_ext
Commit Message
Hi,
In commit 25e5c20918 "[gdb/testsuite] Allow some tests in gdb.base/store.exp
to be unsupported" we replace a gdb_test:
...
gdb_test "print l" " = ${l}" \
"${prefix}; print old l, expecting ${l}"
...
with a gdb_test_multiple:
...
set supported 1
set test "${prefix}; print old l, expecting ${l}"
gdb_test_multiple "print l" "$test" {
-re " = <optimized out>\r\n$gdb_prompt $" {
unsupported $test
set supported 0
}
-re " = ${l}\r\n$gdb_prompt $" {
pass $test
}
}
...
in order to handle the UNSUPPORTED case.
This has the drawback that we have to be explicit about the gdb_prompt, and
move the gdb_test arguments around to fit the gdb_test_multiple format.
Introduce a new proc gdb_test_ext that behaves as gdb_test, but also allows
extension, allowing us to rewrite the gdb_test_multiple above in a form
resembling the original gdb_test:
...
set supported 1
gdb_test_ext "print l" " = ${l}" \
"${prefix}; print old l, expecting ${l}" \
-- [list "unsupported" " = <optimized out>" "set supported 0"]
...
Tested on x86_64-linux.
OK for trunk?
Thanks,
- Tom
[gdb/testsuite] Introduce gdb_test_ext
gdb/testsuite/ChangeLog:
2019-09-19 Tom de Vries <tdevries@suse.de>
* lib/gdb.exp (gdb_test_ext): New proc.
* gdb.base/store.exp: Use gdb_test_ext.
---
gdb/testsuite/gdb.base/store.exp | 24 +++----------
gdb/testsuite/lib/gdb.exp | 77 ++++++++++++++++++++++++++++++++++++++++
2 files changed, 81 insertions(+), 20 deletions(-)
@@ -56,16 +56,8 @@ proc check_set { t l r new add } {
}
set supported 1
- set test "${prefix}; print old l, expecting ${l}"
- gdb_test_multiple "print l" "$test" {
- -re " = <optimized out>\r\n$gdb_prompt $" {
- unsupported $test
- set supported 0
- }
- -re " = ${l}\r\n$gdb_prompt $" {
- pass $test
- }
- }
+ gdb_test_ext "print l" " = ${l}" "${prefix}; print old l, expecting ${l}" \
+ -- [list "unsupported" " = <optimized out>" "set supported 0"]
if { $supported } {
gdb_test "print r" " = ${r}" \
"${prefix}; print old r, expecting ${r}"
@@ -102,16 +94,8 @@ proc up_set { t l r new } {
"${prefix}; up"
set supported 1
- set test "${prefix}; print old l, expecting ${l}"
- gdb_test_multiple "print l" "$test" {
- -re " = <optimized out>\r\n$gdb_prompt $" {
- unsupported $test
- set supported 0
- }
- -re " = ${l}\r\n$gdb_prompt $" {
- pass $test
- }
- }
+ gdb_test_ext "print l" " = ${l}" "${prefix}; print old l, expecting ${l}" \
+ -- [list "unsupported" " = <optimized out>" "set supported 0"]
if { $supported } {
gdb_test "print r" " = ${r}" \
"${prefix}; print old r, expecting ${r}"
@@ -1103,6 +1103,83 @@ proc gdb_test { args } {
}]
}
+# As gdb_test, but with additional parameters, listed after a "--" separator.
+# Handled extra parameters:
+# - [list "unsupported" <pattern> [<code>]]
+# The idea is to prevent the need to rewrite gdb_test into gdb_test_multiple
+# if some modification is needed.
+proc gdb_test_ext { args } {
+ global gdb_prompt
+ upvar timeout timeout
+
+ # Find the '--' separator.
+ set pos -1
+ set index 0
+ while { $index < [llength $args] } {
+ if { [lindex $args $index] == "--" } {
+ set pos $index
+ break
+ }
+ set index [expr $index + 1]
+ }
+ if { $pos == -1 } {
+ error "No -- argument found"
+ }
+
+ if { $pos > 2 } then {
+ set message [lindex $args 2]
+ } else {
+ set message [lindex $args 0]
+ }
+ set command [lindex $args 0]
+ set pattern [lindex $args 1]
+
+ set user_code {}
+ lappend user_code {
+ -re "\[\r\n\]*(?:$pattern)\[\r\n\]+$gdb_prompt $" {
+ if ![string match "" $message] then {
+ pass "$message"
+ }
+ }
+ }
+
+ if { $pos == 5 } {
+ set question_string [lindex $args 3]
+ set response_string [lindex $args 4]
+ lappend user_code {
+ -re "(${question_string})$" {
+ send_gdb "$response_string\n"
+ exp_continue
+ }
+ }
+ }
+
+ set index [expr $pos + 1]
+ while { $index < [llength $args] } {
+ set arg [lindex $args $index]
+ set index [expr $index + 1]
+ set kind [lindex $arg 0]
+ switch $kind {
+ "unsupported" {
+ set unsupported_pattern [lindex $arg 1]
+ set unsupported_code [lindex $arg 2]
+ if { $unsupported_code == "" } {
+ set unsupported_code "expr true"
+ }
+ lappend user_code {
+ -re "\[\r\n\]*(?:$unsupported_pattern)\[\r\n\]+$gdb_prompt $" {
+ unsupported $message
+ eval uplevel $unsupported_code
+ }
+ }
+ }
+ }
+ }
+
+ set user_code [join $user_code " "]
+ return [gdb_test_multiple $command $message $user_code]
+}
+
# Return 1 if version MAJOR.MINOR is at least AT_LEAST_MAJOR.AT_LEAST_MINOR.
proc version_at_least { major minor at_least_major at_least_minor} {
if { $major > $at_least_major } {