[PATCH] gdb/testsuite: introduce parse_options procedure
Simon Marchi
simon.marchi@polymtl.ca
Tue May 26 13:02:22 GMT 2020
In the testsuite, I really like when procedures take optional arguments
using shell-like options that start with dash (for example,
gdb_test_multiple). I think this leads to clearer code than using
parameters with defaults value.
For example, if one wants to specify arg3 but not arg2 when calling the
following proc:
proc some_proc { arg1 { arg2 "" } { arg3 "" } } { ... }
they would have to do:
some_proc value1 "" value3
I find it nicer when it's shell-like:
some_proc value1 -arg3 value3
some_proc -arg3 value3 value1
This patch adds a `parse_options` procedure to help doing this without
much code. See the documentation above the proc to see how it works.
I modified the gdb_test_multiple procedure to use it, and I think the
result is quite readable.
Note that because arguments to gdb_test_multiple sometimes start with a
hyphen (such as MI commands, but not only), I found it necessary to
support the typical "--" argument, which stops the processing of
options. Otherwise, parse_options would complain about the argument
being an unrecognized option of gdb_test_multiple. I added it at a few
places where I found it to be necessary.
gdb/testsuite/ChangeLog:
* lib/gdb.exp (parse_options): New proc.
(gdb_test_multiple): Handle args using parse_options.
(gdb_test): Add `--` to gdb_test_multiple call.
(gdb_test_no_output): Likewise.
* gdb.mi/list-thread-groups-available.exp: Likewise.
* gdb.mi/list-thread-groups-no-inferior.exp: Likewise.
* gdb.mi/mi-fortran-modules.exp: Likewise.
Change-Id: I8910bfba360a25ed28e5ed8c0aea165acbca996f
---
.../gdb.mi/list-thread-groups-available.exp | 2 +-
.../gdb.mi/list-thread-groups-no-inferior.exp | 2 +-
gdb/testsuite/gdb.mi/mi-fortran-modules.exp | 4 +-
gdb/testsuite/lib/gdb.exp | 198 +++++++++++++++---
4 files changed, 174 insertions(+), 32 deletions(-)
diff --git a/gdb/testsuite/gdb.mi/list-thread-groups-available.exp b/gdb/testsuite/gdb.mi/list-thread-groups-available.exp
index 697ee343d8b4..86a455a34cb1 100644
--- a/gdb/testsuite/gdb.mi/list-thread-groups-available.exp
+++ b/gdb/testsuite/gdb.mi/list-thread-groups-available.exp
@@ -58,7 +58,7 @@ set process_entry_re "{${id_re},${type_re}(,$description_re)?(,$user_re)?(,$core
# timeout (especially when running with check-read1).
set cmd "-list-thread-groups --available"
set test "list available thread groups"
-gdb_test_multiple $cmd $test -prompt "$mi_gdb_prompt" {
+gdb_test_multiple -prompt "$mi_gdb_prompt" -- $cmd $test {
-re "\\^done,groups=\\\[" {
# The beginning of the response.
exp_continue
diff --git a/gdb/testsuite/gdb.mi/list-thread-groups-no-inferior.exp b/gdb/testsuite/gdb.mi/list-thread-groups-no-inferior.exp
index beea82443ba3..e50c862ac04e 100644
--- a/gdb/testsuite/gdb.mi/list-thread-groups-no-inferior.exp
+++ b/gdb/testsuite/gdb.mi/list-thread-groups-no-inferior.exp
@@ -31,7 +31,7 @@ if [mi_gdb_start] {
# size. So we consume the output in chunks.
set test "-list-thread-groups --available"
-gdb_test_multiple $test $test {
+gdb_test_multiple -- $test $test {
-re "\}" {
exp_continue
}
diff --git a/gdb/testsuite/gdb.mi/mi-fortran-modules.exp b/gdb/testsuite/gdb.mi/mi-fortran-modules.exp
index e7ee1b96e461..3e06c058d758 100644
--- a/gdb/testsuite/gdb.mi/mi-fortran-modules.exp
+++ b/gdb/testsuite/gdb.mi/mi-fortran-modules.exp
@@ -65,7 +65,7 @@ set modmany_re \
set moduse_re \
"\{module=\"moduse\",files=\\\[\{filename=\"\[^\"\]+$srcfile\",fullname=\"\[^\"\]+$srcfile\",symbols=\\\[\{line=\"44\",name=\"moduse::check_all\",type=\"void \\(void\\)\",description=\"void moduse::check_all\\(void\\);\"\},\{line=\"49\",name=\"moduse::check_var_x\",type=\"void \\(void\\)\",description=\"void moduse::check_var_x\\(void\\);\"\}\\\]\}\\\]\}"
set state 0
-gdb_test_multiple $cmd $test -prompt $mi_gdb_prompt$ {
+gdb_test_multiple -prompt $mi_gdb_prompt$ -- $cmd $test {
-re "104\\^done,symbols=\\\[" {
if { $state == 0 } { set state 1 }
exp_continue
@@ -126,7 +126,7 @@ set moduse_re \
set cmd "107-symbol-info-module-variables"
set test "-symbol-info-module-variables"
set state 0
-gdb_test_multiple $cmd $test -prompt $mi_gdb_prompt$ {
+gdb_test_multiple -prompt $mi_gdb_prompt$ -- $cmd $test {
-re "107\\^done,symbols=\\\[" {
if { $state == 0 } { set state 1 }
exp_continue
diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index 444cea01c36a..26b55b09b3e1 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -713,23 +713,28 @@ proc gdb_internal_error_resync {} {
}
-# gdb_test_multiple COMMAND MESSAGE [ -promp PROMPT_REGEXP] [ -lbl ]
-# EXPECT_ARGUMENTS
+# gdb_test_multiple [ -prompt PROMPT_REGEXP] [ -lbl ]
+# COMMAND MESSAGE EXPECT_ARGUMENTS
# Send a command to gdb; test the result.
#
+# The following positional arguments are required:
+#
# COMMAND is the command to execute, send to GDB with send_gdb. If
# this is the null string no command is sent.
# 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.
-# -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.
# 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.
#
+# The following options are supported:
+#
+# -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, according to a built-in failure pattern
# 0 if only user-supplied patterns matched
@@ -808,7 +813,7 @@ proc gdb_internal_error_resync {} {
# }
# }
#
-proc gdb_test_multiple { command message args } {
+proc gdb_test_multiple { args } {
global verbose use_gdb_stub
global gdb_prompt pagination_prompt
global GDB
@@ -818,30 +823,20 @@ proc gdb_test_multiple { command message args } {
upvar expect_out expect_out
global any_spawn_id
- set line_by_line 0
- set prompt_regexp ""
- for {set i 0} {$i < [llength $args]} {incr i} {
- set arg [lindex $args $i]
- if { $arg == "-prompt" } {
- incr i
- set prompt_regexp [lindex $args $i]
- } elseif { $arg == "-lbl" } {
- set line_by_line 1
- } else {
- set user_code $arg
- break
- }
- }
- if { [expr $i + 1] < [llength $args] } {
- error "Too many arguments to gdb_test_multiple"
- } elseif { ![info exists user_code] } {
- error "Too few arguments to gdb_test_multiple"
+ set prompt_regexp "$gdb_prompt $"
+
+ set opt_desc {
+ { "prompt" prompt_regexp true }
+ { "lbl" line_by_line false }
}
- if { "$prompt_regexp" == "" } {
- set prompt_regexp "$gdb_prompt $"
+ set args [parse_options $args $opt_desc]
+ if { [llength $args] != 3 } {
+ error "gdb_test_multiple requires 3 positional argument (command, message and user_code), [llength $args] given)"
}
+ lassign $args command message user_code
+
if { $message == "" } {
set message $command
}
@@ -1237,7 +1232,7 @@ proc gdb_test { args } {
}
set user_code [join $user_code]
- return [gdb_test_multiple $command $message $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.
@@ -1296,7 +1291,7 @@ proc gdb_test_no_output { args } {
}
set command_regex [string_to_regexp $command]
- gdb_test_multiple $command $message {
+ gdb_test_multiple -- $command $message {
-re "^$command_regex\r\n$gdb_prompt $" {
if ![string match "" $message] then {
pass "$message"
@@ -7203,5 +7198,152 @@ proc hex_in_list { val hexlist } {
return [expr $index != -1]
}
+# A simple option parser for TCL procedures.
+#
+# This helps writing procedures that take shell-like options. Options begin
+# with a single hyphen and may require a following argument. Arguments which
+# are not options nor arguments to options are called positional arguments.
+#
+# ARGV must be a list of arguments to parse. Typically, a procedure using
+# PARSE_OPTIONS will pass in its `args` parameter (the va_list of TCL).
+#
+# OPT_DESC must be a list of options descriptions. An option description is
+# itself a list with the following elements:
+#
+# 1. Option name, without the leading hyphen
+# 2. Variable name
+# 3. Whether the option takes an argument
+#
+# When an option is provided, PARSE_OPTIONS sets the corresponding variable in
+# the context of the caller. If the option takes an argument, the following
+# element in the argument list is used as the variable value. Otherwise, the
+# variable is set to "true".
+#
+# If an option is not provided:
+#
+# - if the option does not take an argument: the variable is set to false
+# - if the option takes an argument: the variable is not set
+#
+# The latter allows checking whether an option which requires an argument was
+# given or not using `info exists var_name`. Alternatively, the calling
+# procedure may provide a default value for an option that requires an argument
+# by setting the corresponding variable prior to invoking PARSE_OPTIONS.
+#
+# Positional arguments are accumulated in a separate list, which is returned by
+# PARSE_OPTIONS.
+#
+# A positional argument "--" causes PARSE_OPTIONS to stop looking for options. All
+# arguments following it are appended the returned list.
+#
+# Here's a somewhat complete example of using PARSE_OPTIONS:
+#
+# proc some_proc { args } {
+# # Default value for -opt-with-arg-1.
+# set opt_with_arg_1 123
+#
+# set opt_desc {
+# { "opt-without-arg-1" opt_without_arg_1 false }
+# { "opt-without-arg-2" opt_without_arg_2 false }
+# { "opt-with-arg-1" opt_with_arg_1 true }
+# { "opt-with-arg-2" opt_with_arg_2 true }
+# { "opt-with-arg-3" opt_with_arg_3 true }
+# }
+#
+# set args [parse_options $args $opt_desc]
+#
+# puts "-opt-without-arg-1: $opt_without_arg_1"
+# puts "-opt-without-arg-2: $opt_without_arg_2"
+# puts "-opt-with-arg-1: $opt_with_arg_1"
+# puts "-opt-with-arg-2: $opt_with_arg_2"
+# if { ![info exists opt_with_arg_3] } {
+# puts "-opt-with-arg-3 is not specified"
+# }
+#
+# puts "positional arguments: $args"
+# }
+#
+# Calling the proc above with:
+#
+# some_proc Hello -opt-without-arg-1 World -opt-with-arg-2 arg2
+#
+# ... would print:
+
+# -opt-without-arg-1: true
+# -opt-without-arg-2: false
+# -opt-with-arg-1: 123
+# -opt-with-arg-2: arg2
+# -opt-with-arg-3 is not specified
+# positional arguments: Hello World
+
+proc parse_options { argv opt_desc } {
+ set argc [llength $argv]
+ set optc [llength $opt_desc]
+ set positional_args {}
+
+ # Initialize variables for options that don't take an argument.
+ for { set opt_idx 0 } { $opt_idx < $optc } { incr opt_idx } {
+ lassign [lindex $opt_desc $opt_idx] opt_name opt_var_name \
+ opt_requires_arg
+
+ if { !$opt_requires_arg } {
+ upvar $opt_var_name opt_var
+ set opt_var false
+ }
+ }
+
+ # For each argument...
+ for { set arg_idx 0 } { $arg_idx < $argc } { incr arg_idx } {
+ set arg [lindex $argv $arg_idx]
+
+ if { $arg == "--" } {
+ # End of options, append the remainder of arguments to list
+ # of positional arguments.
+
+ incr arg_idx
+ set remainder [lrange $argv $arg_idx end]
+ set positional_args [concat $positional_args $remainder]
+ break
+ } elseif { [string index $arg 0] == "-" } {
+ # It's an option.
+
+ # Find the option in the option array.
+ for { set opt_idx 0 } { $opt_idx < $optc } { incr opt_idx } {
+ lassign [lindex $opt_desc $opt_idx] opt_name opt_var_name \
+ opt_requires_arg
+
+ if { $arg == "-${opt_name}" } {
+ break
+ }
+ }
+
+ if { $opt_idx == $optc } {
+ error "while parsing `$arg`: unrecognized option"
+ }
+
+ if { $opt_requires_arg } {
+ # Option requires argument, consume following argument.
+ incr arg_idx
+ if { $arg_idx == $argc } {
+ error "while parsing `$arg`: option requires an argument"
+ }
+
+ set opt_arg [lindex $argv $arg_idx]
+ } else {
+ # Option requires no argument, use value "true".
+ set opt_arg true
+ }
+
+ # Set variable in the valler.
+ upvar $opt_var_name opt_var
+ set opt_var $opt_arg
+ } else {
+ # It's a positional argument, append to positional argument list.
+ lappend positional_args $arg
+ }
+ }
+
+ return $positional_args
+}
+
# Always load compatibility stuff.
load_lib future.exp
--
2.26.2
More information about the Gdb-patches
mailing list