gdb: fix debug expression dumping of function call expressions

In commit:

  commit 6d81691950f8c4be4a49a85a672255c140e82468
  CommitDate: Sat Sep 19 09:44:58 2020 +0100

    gdb/fortran: Move Fortran expression handling into f-lang.c

A bug was introduced that broke GDB's ability to perform debug dumps
of expressions containing function calls.  For example this would no
longer work:

  (gdb) set debug expression 1
  (gdb) print call_me (&val)
  Dump of expression @ 0x4eced60, before conversion to prefix form:
  	Language c, 12 elements, 16 bytes each.
  	Index                Opcode         Hex Value  String Value
  	    0          OP_VAR_VALUE  40  (...............
  	    1          OP_M2_STRING  79862864  P...............
  	    2   unknown opcode: 224  79862240  ................
  	    3          OP_VAR_VALUE  40  (...............
  	    4          OP_VAR_VALUE  40  (...............
  	    5         OP_RUST_ARRAY  79861600  `...............
  	    6     UNOP_PREDECREMENT  79861312  @...............
  	    7          OP_VAR_VALUE  40  (...............
  	    8             UNOP_ADDR  61  =...............
  	    9            OP_FUNCALL  46  ................
  	   10             BINOP_ADD  1  ................
  	   11            OP_FUNCALL  46  ................
  Dump of expression @ 0x4eced60, after conversion to prefix form:
  Expression: `call_me (&main::val, VAL(Aborted (core dumped)

The situation was even worse for Fortran function calls, or array
indexes, which both make use of the same expression opcode.

The problem was that in a couple of places the index into the
expression array was handled incorrectly causing GDB to interpret
elements incorrectly.  These issues are fixed in this commit.

There are already some tests to check GDB when 'set debug expression
1' is set, these can be found in gdb.*/debug-expr.exp.  Unfortunately
the cases above were not covered.

In this commit I have cleaned up all of the debug-expr.exp files a
little, there was a helper function that had clearly been copied into
each file, this is now moved into lib/gdb.exp.

I've added a gdb.fortran/debug-expr.exp test file, and extended
gdb.base/debug-expr.exp to cover the function call case.

gdb/ChangeLog:

	* expprint.c (print_subexp_funcall): Increment expression position
	after reading argument count.
	* f-lang.c (print_subexp_f): Skip over opcode before calling
	common function.
	(dump_subexp_body_f): Likewise.

gdb/testsuite/ChangeLog:

	* gdb.base/debug-expr.c: Add extra function to allow for an
	additional test.
	* gdb.base/debug-expr.exp (test_debug_expr): Delete, replace calls
	to this proc with gdb_test_debug_expr.  Add an extra test.
	* gdb.cp/debug-expr.exp (test_debug_expr): Delete, replace calls
	to this proc with gdb_test_debug_expr, give the tests names
	* gdb.dlang/debug-expr.exp (test_debug_expr): Delete, replace
	calls to this proc with gdb_test_debug_expr, give the tests names
	* gdb.fortran/debug-expr.exp: New file.
	* gdb.fortran/debug-expr.f90: New file.
	* lib/gdb.exp (gdb_test_debug_expr): New proc.

11 files changed, 160 insertions, 55 deletions

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 93de188..67a151b 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,3 +1,11 @@
+2020-11-06  Andrew Burgess  <andrew.burgess@embecosm.com>
+
+	* expprint.c (print_subexp_funcall): Increment expression position
+	after reading argument count.
+	* f-lang.c (print_subexp_f): Skip over opcode before calling
+	common function.
+	(dump_subexp_body_f): Likewise.
+
 2020-11-06  Romain Geissler  <romain.geissler@amadeus.com>
 
 	PR python/26832
diff --git a/gdb/expprint.c b/gdb/expprint.c
index f4668aa..29e6237 100644
--- a/gdb/expprint.c
+++ b/gdb/expprint.c
@@ -60,8 +60,8 @@ void
 print_subexp_funcall (struct expression *exp, int *pos,
 		      struct ui_file *stream)
 {
-  (*pos) += 2;
   unsigned nargs = longest_to_int (exp->elts[*pos].longconst);
+  (*pos) += 2;
   print_subexp (exp, pos, stream, PREC_SUFFIX);
   fputs_filtered (" (", stream);
   for (unsigned tem = 0; tem < nargs; tem++)
diff --git a/gdb/f-lang.c b/gdb/f-lang.c
index d3391d9..b775fae 100644
--- a/gdb/f-lang.c
+++ b/gdb/f-lang.c
@@ -614,6 +614,7 @@ print_subexp_f (struct expression *exp, int *pos,
       return;
 
     case OP_F77_UNDETERMINED_ARGLIST:
+      (*pos)++;
       print_subexp_funcall (exp, pos, stream);
       return;
     }
@@ -660,7 +661,7 @@ dump_subexp_body_f (struct expression *exp,
       break;
 
     case OP_F77_UNDETERMINED_ARGLIST:
-      return dump_subexp_body_funcall (exp, stream, elt);
+      return dump_subexp_body_funcall (exp, stream, elt + 1);
     }
 
   elt += oplen;
diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog
index 42c317a..d3e81a2 100644
--- a/gdb/testsuite/ChangeLog
+++ b/gdb/testsuite/ChangeLog
@@ -1,3 +1,17 @@
+2020-11-06  Andrew Burgess  <andrew.burgess@embecosm.com>
+
+	* gdb.base/debug-expr.c: Add extra function to allow for an
+	additional test.
+	* gdb.base/debug-expr.exp (test_debug_expr): Delete, replace calls
+	to this proc with gdb_test_debug_expr.  Add an extra test.
+	* gdb.cp/debug-expr.exp (test_debug_expr): Delete, replace calls
+	to this proc with gdb_test_debug_expr, give the tests names
+	* gdb.dlang/debug-expr.exp (test_debug_expr): Delete, replace
+	calls to this proc with gdb_test_debug_expr, give the tests names
+	* gdb.fortran/debug-expr.exp: New file.
+	* gdb.fortran/debug-expr.f90: New file.
+	* lib/gdb.exp (gdb_test_debug_expr): New proc.
+
 2020-11-06  Simon Marchi  <simon.marchi@efficios.com>
 
 	* lib/dwarf.exp (ranges): Handle "base" and "range" as
diff --git a/gdb/testsuite/gdb.base/debug-expr.c b/gdb/testsuite/gdb.base/debug-expr.c
index 9b32c52..f7c3dbc 100644
--- a/gdb/testsuite/gdb.base/debug-expr.c
+++ b/gdb/testsuite/gdb.base/debug-expr.c
@@ -1,7 +1,15 @@
 char array[4];
 
 int
+call_me (int *arg)
+{
+  return (*arg) - 1;
+}
+
+int val = 1;
+
+int
 main ()
 {
-  return 0;
+  return call_me (&val);
 }
diff --git a/gdb/testsuite/gdb.base/debug-expr.exp b/gdb/testsuite/gdb.base/debug-expr.exp
index 95c2185..b0318bc 100644
--- a/gdb/testsuite/gdb.base/debug-expr.exp
+++ b/gdb/testsuite/gdb.base/debug-expr.exp
@@ -33,21 +33,6 @@ if ![runto_main] {
     return -1
 }
 
-# Test whether the expression debug machinery accepts the expression.
-
-proc test_debug_expr { cmd output } {
-    global gdb_prompt
-
-    gdb_test_multiple $cmd "" {
-	-re ".*Invalid expression.*\r\n$gdb_prompt $" {
-	    fail $cmd
-	}
-	-re ".*\[\r\n\]$output\r\n$gdb_prompt $" {
-	    pass $cmd
-	}
-    }
-}
-
 for { set i 0 } { $i < 4 } { incr i } {
     gdb_test_no_output "set variable array\[$i\] = $i"
 }
@@ -55,10 +40,15 @@ for { set i 0 } { $i < 4 } { incr i } {
 gdb_test_no_output "set debug expression 1"
 
 # This caused gdb to segfault.
-test_debug_expr "print /x {char\[4\]} array" \
+gdb_test_debug_expr "print /x {char\[4\]} array" \
     "\[$\]$decimal = \\{0x0, 0x1, 0x2, 0x3\\}"
 
 # This caused gdb to output garbage and possibly segfault
-gdb_test "print \"hello\"" \
-    ".*OP_STRING\[^\r\n\]*Language-specific string type: 0.*\[\r\n\]\\$$decimal = \"hello\"\[\r\n\].*" \
+gdb_test_debug_expr "print \"hello\"" \
+    ".*OP_STRING\[^\r\n\]*Language-specific string type: 0.*\[\r\n\]\\$$decimal = \"hello\"" \
     "string evaluation with debug expr"
+
+# An expression using a function call.
+gdb_test_debug_expr "print call_me ( &val )" \
+    ".*OP_FUNCALL\[^\r\n\]*Number of args: 1.*\[\r\n\]\\$$decimal = 0.*" \
+    "function call expression"
diff --git a/gdb/testsuite/gdb.cp/debug-expr.exp b/gdb/testsuite/gdb.cp/debug-expr.exp
index 79ba0bc..77462c5 100644
--- a/gdb/testsuite/gdb.cp/debug-expr.exp
+++ b/gdb/testsuite/gdb.cp/debug-expr.exp
@@ -21,23 +21,11 @@ gdb_start
 gdb_test_no_output "set language c++"
 gdb_test_no_output "set debug expression 1"
 
-# Test whether the expression debug machinery accepts the expression.
-
-proc test_debug_expr { cmd output } {
-    global gdb_prompt
-
-    gdb_test_multiple $cmd "" {
-	-re ".*Invalid expression.*\r\n$gdb_prompt $" {
-	    fail $cmd
-	}
-	-re ".*\[\r\n\]$output\r\n$gdb_prompt $" {
-	    pass $cmd
-	}
-    }
-}
-
 set void_star_zero_regex "\[$\]$decimal = \\(void \[*\]\\) 0x0"
 
-test_debug_expr "print static_cast<void*>(0)" "$void_star_zero_regex"
-test_debug_expr "print reinterpret_cast<void*>(0)" "$void_star_zero_regex"
-test_debug_expr "print dynamic_cast<void*>(0)" "$void_star_zero_regex"
+gdb_test_debug_expr "print static_cast<void*>(0)" \
+    "$void_star_zero_regex" "static_cast of zero to void*"
+gdb_test_debug_expr "print reinterpret_cast<void*>(0)" \
+    "$void_star_zero_regex" "reinterpret_cast of zero to void*"
+gdb_test_debug_expr "print dynamic_cast<void*>(0)" \
+    "$void_star_zero_regex" "dynamic_cast of zero to void*"
diff --git a/gdb/testsuite/gdb.dlang/debug-expr.exp b/gdb/testsuite/gdb.dlang/debug-expr.exp
index 8d12d33..6b8ad0c 100644
--- a/gdb/testsuite/gdb.dlang/debug-expr.exp
+++ b/gdb/testsuite/gdb.dlang/debug-expr.exp
@@ -21,20 +21,7 @@ gdb_start
 gdb_test_no_output "set language d"
 gdb_test_no_output "set debug expression 1"
 
-# Test whether the expression debug machinery accepts the expression.
-
-proc test_debug_expr { cmd output } {
-    global gdb_prompt
-
-    gdb_test_multiple $cmd "" {
-	-re ".*Invalid expression.*\r\n$gdb_prompt $" {
-	    fail $cmd
-	}
-	-re ".*\[\r\n\]$output\r\n$gdb_prompt $" {
-	    pass $cmd
-	}
-    }
-}
-
 # This caused gdb to segfault.
-test_debug_expr "print *(int*)(0)" "Cannot access memory at address 0x0"
+gdb_test_debug_expr "print *(int*)(0)" \
+    "Cannot access memory at address 0x0" \
+    "dereference a null pointer"
diff --git a/gdb/testsuite/gdb.fortran/debug-expr.exp b/gdb/testsuite/gdb.fortran/debug-expr.exp
new file mode 100644
index 0000000..19df7bd
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/debug-expr.exp
@@ -0,0 +1,43 @@
+# Copyright 2020 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+# Test "set debug expr 1" on Fortran expressions.
+
+if { [skip_fortran_tests] } { return -1 }
+
+# Test relies on checking gdb debug output. Do not run if gdb debug is
+# enabled as any debug will be redirected to the log.
+if [gdb_debug_enabled] {
+    untested "debug is enabled"
+    return 0
+}
+
+standard_testfile .f90
+load_lib fortran.exp
+
+if {[prepare_for_testing "failed to prepare" $testfile $srcfile {debug f90}]} {
+    return -1
+}
+
+if ![fortran_runto_main] {
+    fail "run to main"
+    return -1
+}
+
+gdb_breakpoint [gdb_get_line_number "Break Here"]
+gdb_continue_to_breakpoint "Break Here"
+
+gdb_test_no_output "set debug expression 1"
+gdb_test_debug_expr "print obj%three(1)%two(1)%one(1)%i" "\\\$$decimal = 1"
diff --git a/gdb/testsuite/gdb.fortran/debug-expr.f90 b/gdb/testsuite/gdb.fortran/debug-expr.f90
new file mode 100644
index 0000000..8071f1b
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/debug-expr.f90
@@ -0,0 +1,38 @@
+! Copyright 2020 Free Software Foundation, Inc.
+
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 3 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+program main
+  type data_item
+     integer(kind=4) i, j, k
+  end type data_item
+
+  type level_one
+     type(data_item) :: one(3)
+  end type level_one
+
+  type level_two
+     type(level_one) :: two(3)
+  end type level_two
+
+  type level_three
+     type(level_two) :: three(3)
+  end type level_three
+
+  type (level_three) obj
+
+  obj%three(1)%two(1)%one(1)%i = 1
+
+  print *, obj ! Break Here
+end program
diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index 6c98ae0..55154db 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -1656,6 +1656,34 @@ proc gdb_test_stdio {command inferior_pattern {gdb_pattern ""} {message ""}} {
     return $res
 }
 
+# Wrapper around gdb_test_multiple to be used when testing expression
+# evaluation while 'set debug expression 1' is in effect.
+# Looks for some patterns that indicates the expression was rejected.
+#
+# CMD is the command to execute, which should include an expression
+# that GDB will need to parse.
+#
+# OUTPUT is the expected output pattern.
+#
+# TESTNAME is the name to be used for the test, defaults to CMD if not
+# given.
+proc gdb_test_debug_expr { cmd output {testname "" }} {
+    global gdb_prompt
+
+    if { ${testname} == "" } {
+	set testname $cmd
+    }
+
+    gdb_test_multiple $cmd $testname {
+	-re ".*Invalid expression.*\r\n$gdb_prompt $" {
+	    fail $gdb_test_name
+	}
+	-re ".*\[\r\n\]$output\r\n$gdb_prompt $" {
+	    pass $gdb_test_name
+	}
+    }
+}
+
 # get_print_expr_at_depths EXP OUTPUTS
 #
 # Used for testing 'set print max-depth'.  Prints the expression EXP