[PATCH][gdb/testsuite] Introduce gdb_test_ext

[Tom de Vries <tdevries@suse.de>]

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(-)

diff --git a/gdb/testsuite/gdb.base/store.exp b/gdb/testsuite/gdb.base/store.exp
index 9c19ce15a7..d97b4cb962 100644
--- a/gdb/testsuite/gdb.base/store.exp
+++ b/gdb/testsuite/gdb.base/store.exp
@@ -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}"
diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index acbeb01376..dc990b370e 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -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 } {