Fix Tcl quoting in gdb_assert

Message ID 20230215215828.1337884-1-tromey@adacore.com
State New
Headers
Series Fix Tcl quoting in gdb_assert |

Commit Message

Tom Tromey Feb. 15, 2023, 9:58 p.m. UTC
  The gdb_assert proc under-quotes the expression that is passed in.
This leads to weird code in a couple of spots that tries to
compensate:

    gdb_assert {{$all_regs eq $completed_regs}} ...

The fix is to add a bit of quoting when evaluating the expression.
---
 gdb/testsuite/gdb.base/completion.exp           | 2 +-
 gdb/testsuite/gdb.base/step-over-no-symbols.exp | 6 +++---
 gdb/testsuite/lib/gdb.exp                       | 2 +-
 3 files changed, 5 insertions(+), 5 deletions(-)
  

Comments

Simon Marchi Feb. 16, 2023, 4:06 p.m. UTC | #1
On 2/15/23 16:58, Tom Tromey via Gdb-patches wrote:
> The gdb_assert proc under-quotes the expression that is passed in.
> This leads to weird code in a couple of spots that tries to
> compensate:
> 
>     gdb_assert {{$all_regs eq $completed_regs}} ...
> 
> The fix is to add a bit of quoting when evaluating the expression.
> ---
>  gdb/testsuite/gdb.base/completion.exp           | 2 +-
>  gdb/testsuite/gdb.base/step-over-no-symbols.exp | 6 +++---
>  gdb/testsuite/lib/gdb.exp                       | 2 +-
>  3 files changed, 5 insertions(+), 5 deletions(-)
> 
> diff --git a/gdb/testsuite/gdb.base/completion.exp b/gdb/testsuite/gdb.base/completion.exp
> index 1533acbf4f9..4686e6f8f34 100644
> --- a/gdb/testsuite/gdb.base/completion.exp
> +++ b/gdb/testsuite/gdb.base/completion.exp
> @@ -159,7 +159,7 @@ foreach {-> reg} [regexp -all -inline -line {^info registers (\w+\S*)} $regs_out
>      lappend completed_regs $reg
>  }
>  set completed_regs [join [lsort $completed_regs]]
> -gdb_assert {{$all_regs eq $completed_regs}} "complete 'info registers '"
> +gdb_assert {$all_regs eq $completed_regs} "complete 'info registers '"
>  
>  # Tests below are about tab-completion, which doesn't work if readline
>  # library isn't used.  Check it first.
> diff --git a/gdb/testsuite/gdb.base/step-over-no-symbols.exp b/gdb/testsuite/gdb.base/step-over-no-symbols.exp
> index 00b32deacf7..1136b47571b 100644
> --- a/gdb/testsuite/gdb.base/step-over-no-symbols.exp
> +++ b/gdb/testsuite/gdb.base/step-over-no-symbols.exp
> @@ -76,9 +76,9 @@ proc test_step_over { displaced } {
>  
>      set after_addr [get_pc "get after PC"]
>  
> -    gdb_assert {{[regexp "^${hex}$" $before_addr] \
> -		 && [regexp "^${hex}$" $after_addr] \
> -		 && $before_addr != $after_addr}} "advanced"
> +    gdb_assert {[regexp "^${hex}$" $before_addr] \
> +		    && [regexp "^${hex}$" $after_addr] \
> +		    && $before_addr != $after_addr} "advanced"
>  }
>  
>  foreach displaced { "off" "on" "auto" } {
> diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
> index e48228ed4f6..ecd6ca0a8ef 100644
> --- a/gdb/testsuite/lib/gdb.exp
> +++ b/gdb/testsuite/lib/gdb.exp
> @@ -1947,7 +1947,7 @@ proc gdb_assert { condition {message ""} } {
>  	set message $condition
>      }
>  
> -    set code [catch {uplevel 1 expr $condition} res]
> +    set code [catch {uplevel 1 [list expr $condition]} res]

I don't understand why this would be needed.  The doc of uplevel says:

    All of the arg arguments are concatenated as if they had been passed
    to concat

So uplevel should end up executing "expr $condition" just fine, it
should concatenate "expr" with $condition and evaluate that.  But I see
that when I remove your fix, gdb.base/completion.exp gives:

    WARNING: While evaluating expression in gdb_assert: invalid bareword "ah"
    in expression "ah al all ax bh bl bp bp...";
    should be "$ah" or "{ah}" or "ah(...)" or ...

If I add a `puts "expr $condition"` in gdb_assert, I see it passes this
to uplevel:

  expr $all_regs eq $completed_regs

When trying the same kind of thing with tclsh, I see the same message:

    $ rlwrap tclsh
    % set a allo
    allo
    % set b bonjour
    bonjour
    % expr $a eq $b
    invalid bareword "allo"
    in expression "allo eq bonjour";
    should be "$allo" or "{allo}" or "allo(...)" or ...

What happens above is that $a and $b are expanded before expr is called,
expr receives "allo" and "bonjour" literally, and it doesn't like that
(I don't know why).  It seems like expr wants to receive '$a' and '$b'
and to the expansion itself:

    % expr {$a eq $b}
    0

So, I'm not saying your fix is wrong, I am just saying I don't
understand the situation.

Simon
  
Tom Tromey Feb. 16, 2023, 6:12 p.m. UTC | #2
>>>>> "Simon" == Simon Marchi <simark@simark.ca> writes:

>> -    set code [catch {uplevel 1 expr $condition} res]
>> +    set code [catch {uplevel 1 [list expr $condition]} res]

Simon> I don't understand why this would be needed.  The doc of uplevel says:

Simon>     All of the arg arguments are concatenated as if they had been passed
Simon>     to concat

"concat" is simple string concatenation, but "list" also supplies list
quoting.

Here's a simple example:

    % set text "hello Simon"          
    hello Simon
    % uplevel 0 puts $text
    can not find channel named "hello"
    % uplevel 0 [list puts $text]
    hello Simon

Or more directly:

    % concat puts $text
    puts hello Simon
    % list puts $text
    puts {hello Simon}

Here you can see the result of the [concat] isn't a valid command.

Simon> So, I'm not saying your fix is wrong, I am just saying I don't
Simon> understand the situation.

This part of Tcl has always confused people, you're not alone.  But
basically, for eval-like things you normally want to quote with [list].

I'm not totally sure why it works the way it does, but it might be
because Tcl didn't have a "splat" operator in the early days, so
un-quoting a list to write something like "apply" was more of a pain.

Tom
  
Tom Tromey Feb. 23, 2023, 6:11 p.m. UTC | #3
Simon> So, I'm not saying your fix is wrong, I am just saying I don't
Simon> understand the situation.

I have some other patches that depend on this change, so I am wondering
if you feel comfortable ok'ing it now.

thanks,
Tom
  
Simon Marchi Feb. 23, 2023, 7:16 p.m. UTC | #4
On 2/23/23 13:11, Tom Tromey via Gdb-patches wrote:
> Simon> So, I'm not saying your fix is wrong, I am just saying I don't
> Simon> understand the situation.
> 
> I have some other patches that depend on this change, so I am wondering
> if you feel comfortable ok'ing it now.

Yes that's fine, thanks for your explanation.

Simon
  

Patch

diff --git a/gdb/testsuite/gdb.base/completion.exp b/gdb/testsuite/gdb.base/completion.exp
index 1533acbf4f9..4686e6f8f34 100644
--- a/gdb/testsuite/gdb.base/completion.exp
+++ b/gdb/testsuite/gdb.base/completion.exp
@@ -159,7 +159,7 @@  foreach {-> reg} [regexp -all -inline -line {^info registers (\w+\S*)} $regs_out
     lappend completed_regs $reg
 }
 set completed_regs [join [lsort $completed_regs]]
-gdb_assert {{$all_regs eq $completed_regs}} "complete 'info registers '"
+gdb_assert {$all_regs eq $completed_regs} "complete 'info registers '"
 
 # Tests below are about tab-completion, which doesn't work if readline
 # library isn't used.  Check it first.
diff --git a/gdb/testsuite/gdb.base/step-over-no-symbols.exp b/gdb/testsuite/gdb.base/step-over-no-symbols.exp
index 00b32deacf7..1136b47571b 100644
--- a/gdb/testsuite/gdb.base/step-over-no-symbols.exp
+++ b/gdb/testsuite/gdb.base/step-over-no-symbols.exp
@@ -76,9 +76,9 @@  proc test_step_over { displaced } {
 
     set after_addr [get_pc "get after PC"]
 
-    gdb_assert {{[regexp "^${hex}$" $before_addr] \
-		 && [regexp "^${hex}$" $after_addr] \
-		 && $before_addr != $after_addr}} "advanced"
+    gdb_assert {[regexp "^${hex}$" $before_addr] \
+		    && [regexp "^${hex}$" $after_addr] \
+		    && $before_addr != $after_addr} "advanced"
 }
 
 foreach displaced { "off" "on" "auto" } {
diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index e48228ed4f6..ecd6ca0a8ef 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -1947,7 +1947,7 @@  proc gdb_assert { condition {message ""} } {
 	set message $condition
     }
 
-    set code [catch {uplevel 1 expr $condition} res]
+    set code [catch {uplevel 1 [list expr $condition]} res]
     if {$code == 1} {
 	# If code is 1 (TCL_ERROR), it means evaluation failed and res contains
 	# an error message.  Print the error message, and set res to 0 since we