[binutils-gdb] Support -prompt and -lbl in gdb_test

[binutils-gdb] Support -prompt and -lbl in gdb_test

[Pedro Alves]

https://sourceware.org/git/gitweb.cgi?p=binutils-gdb.git;h=c76d61da4a65eaadca861bf6c77d579a5cc3f422

commit c76d61da4a65eaadca861bf6c77d579a5cc3f422
Author: Pedro Alves <pedro@palves.net>
Date:   Tue May 17 11:16:01 2022 +0100

    Support -prompt and -lbl in gdb_test
    
    This teaches gdb_test to forward the -prompt and -lbl options to
    gdb_test_multiple.
    
    The option parsing is done with parse_args.
    
    As a cleanup, instead of using llength and lindex to get at the
    positional arguments, use lassign, and check whether the corresponding
    variable is empty.
    
    Convert gdb.base/ui-redirect.exp and gdb.xml/tdesc-reload.exp to use
    gdb_test -prompt/-lbl instead of gdb_test_multiple as examples.
    
    Change-Id: I243e1296d32c05a421ccef30b63d43a89eaeb4a0

Diff:
---
 gdb/testsuite/gdb.base/ui-redirect.exp | 10 +++---
 gdb/testsuite/gdb.xml/tdesc-reload.exp |  6 +---
 gdb/testsuite/lib/gdb.exp              | 61 +++++++++++++++++++++-------------
 3 files changed, 42 insertions(+), 35 deletions(-)

diff --git a/gdb/testsuite/gdb.base/ui-redirect.exp b/gdb/testsuite/gdb.base/ui-redirect.exp
index 13bc964f46c..4ed82ae63bf 100644
--- a/gdb/testsuite/gdb.base/ui-redirect.exp
+++ b/gdb/testsuite/gdb.base/ui-redirect.exp
@@ -117,12 +117,10 @@ with_test_prefix "debugging" {
     gdb_test "set logging enabled on" \
     "Copying output to /dev/null.*Copying debug output to /dev/null\\."
 
-    set prompt "$gdb_prompt \\\[infrun\\\] fetch_inferior_event: exit\r\n$"
-    gdb_test_multiple "continue" "continue" -prompt $prompt {
-	-re "Continuing.*\\\[infrun\\\] .*\\\[infrun\\\] .*Breakpoint \[0-9\]+, foo.*$prompt$" {
-	    pass $gdb_test_name
-	}
-    }
+    gdb_test \
+	-prompt "$gdb_prompt \\\[infrun\\\] fetch_inferior_event: exit\r\n$" \
+	"continue" \
+	"Continuing.*\\\[infrun\\\] .*\\\[infrun\\\] .*Breakpoint \[0-9\]+, foo.*"
 
     gdb_test "set debug infrun 0"
     gdb_test "set logging enabled off" "Done logging to /dev/null\\."
diff --git a/gdb/testsuite/gdb.xml/tdesc-reload.exp b/gdb/testsuite/gdb.xml/tdesc-reload.exp
index 76dd70fb6d3..6e3fe2f5304 100644
--- a/gdb/testsuite/gdb.xml/tdesc-reload.exp
+++ b/gdb/testsuite/gdb.xml/tdesc-reload.exp
@@ -68,11 +68,7 @@ if ![runto_main] then {
 
 # Run info registers just to check this appears to run fine with the
 # new target description.
-gdb_test_multiple "info all-registers" "Run info registers" -lbl {
-    -re -wrap "" {
-	pass $gdb_test_name
-    }
-}
+gdb_test -lbl "info all-registers" "" "Run info registers"
 
 # Write out the current target description.
 gdb_test_no_output "pipe maint print xml-tdesc | cat > $xml_file_3" \
diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index 0b1104bd299..97841ca19a1 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -1313,7 +1313,8 @@ proc gdb_test_multiline { name args } {
 }
 
 
-# gdb_test COMMAND PATTERN MESSAGE QUESTION RESPONSE
+# gdb_test [-prompt PROMPT_REGEXP] [-lbl]
+#          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
@@ -1331,61 +1332,73 @@ proc gdb_test_multiline { name args } {
 #   doesn't print the question.
 # RESPONSE is the response to send when QUESTION appears.
 #
+# -prompt PROMPT_REGEXP specifies a regexp matching the expected prompt
+#   after the command output.  If empty, defaults to "$gdb_prompt $".
+# -lbl specifies that line-by-line matching will be used.
+#
 # Returns:
 #    1 if the test failed,
 #    0 if the test passes,
 #   -1 if there was an internal error.
-#  
+#
 proc gdb_test { args } {
     global gdb_prompt
     upvar timeout timeout
 
+    parse_args {
+	{prompt ""}
+	{lbl}
+    }
+
+    lassign $args command pattern message question response
+
     # Can't have a question without a response.
-    if { [llength $args] == 4 || [llength $args] > 5 } {
+    if { $question != "" && $response == "" || [llength $args] > 5 } {
 	error "Unexpected arguments: $args"
     }
 
-    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]
 
-    set must_see_question 0
-    if { [llength $args] == 5 } {
-	set must_see_question 1
-	set saw_question 0
+    if { $prompt == "" } {
+	set prompt "$gdb_prompt $"
     }
 
+    set saw_question 0
+
     set user_code {}
     lappend user_code {
-	-re "\[\r\n\]*(?:$pattern)\[\r\n\]+$gdb_prompt $" {
+	-re "\[\r\n\]*(?:$pattern)\[\r\n\]+$prompt" {
 	    if ![string match "" $message] then {
-		if {$must_see_question} {
+		if { $question != "" } {
 		    gdb_assert $saw_question "$message"
 		} else {
 		    pass "$message"
 		}
-            }
-        }
+	    }
+	}
     }
 
-    if { [llength $args] == 5 } {
-	set question_string [lindex $args 3]
-	set response_string [lindex $args 4]
+    if { $question != "" } {
 	lappend user_code {
-	    -re "(${question_string})$" {
+	    -re "$question$" {
 		set saw_question 1
-		send_gdb "$response_string\n"
+		send_gdb "$response\n"
 		exp_continue
 	    }
 	}
-     }
+    }
 
     set user_code [join $user_code]
-    return [gdb_test_multiple $command $message $user_code]
+
+    set opts {}
+    lappend "-prompt $prompt"
+    if {$lbl} {
+	lappend opts "-lbl"
+    }
+
+    return [gdb_test_multiple $command $message {*}$opts $user_code]
 }
 
 # Return 1 if version MAJOR.MINOR is at least AT_LEAST_MAJOR.AT_LEAST_MINOR.