[PATCH 5/9] Resolve dynamic type in ada_value_struct_elt

Tom Tromey
2020-09-30T20:07:12Z

An internal AdaCore test case showed that gdb mishandled a case of
assigning to an array element in a packed array inside a variant
record. This problem can only be seen with -fgnat-encodings=minimal,
which isn't yet widely used. This patch fixes the bug, and also
updates an existing test to check this case.

2020-09-30 Tom Tromey <tromey@adacore.com>

* ada-lang.c (ada_value_struct_elt): Resolve dynamic type.

gdb/testsuite/ChangeLog
2020-09-30 Tom Tromey <tromey@adacore.com>

* gdb.ada/set_pckd_arr_elt.exp: Also test
-fgnat-encodings=minimal. Add tests.
* gdb.ada/set_pckd_arr_elt/foo.adb (Foo): Add VA variable.
Call Update_Small a second time.
* gdb.ada/set_pckd_arr_elt/pck.adb (New_Variant): New function.
* gdb.ada/set_pckd_arr_elt/pck.ads (Buffer, Variant)
(Variant_Access): New types.
(New_Variant): Declare.
---
gdb/ChangeLog | 4 +++
gdb/ada-lang.c | 4 +++
gdb/testsuite/ChangeLog | 11 ++++++
gdb/testsuite/gdb.ada/set_pckd_arr_elt.exp | 35 ++++++++++++-------
.../gdb.ada/set_pckd_arr_elt/foo.adb | 2 ++
.../gdb.ada/set_pckd_arr_elt/pck.adb | 7 ++++
.../gdb.ada/set_pckd_arr_elt/pck.ads | 14 ++++++++
7 files changed, 64 insertions(+), 13 deletions(-)

diff --git a/gdb/ada-lang.c b/gdb/ada-lang.c
index d851f57414b..e81a7877ccb 100644
--- a/gdb/ada-lang.c
+++ b/gdb/ada-lang.c
@@ -4414,6 +4414,10 @@ ada_value_struct_elt (struct value *arg, const char *name, int no_err)
t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
address, NULL, check_tag);

+ /* Resolve the dynamic type as well. */
+ arg = value_from_contents_and_address (t1, nullptr, address);
+ t1 = value_type (arg);
+
if (find_struct_field (name, t1, 0,
&field_type, &byte_offset, &bit_offset,
&bit_size, NULL))
diff --git a/gdb/testsuite/gdb.ada/set_pckd_arr_elt.exp b/gdb/testsuite/gdb.ada/set_pckd_arr_elt.exp
index bf28b9113e4..adaee7d592d 100644
--- a/gdb/testsuite/gdb.ada/set_pckd_arr_elt.exp
+++ b/gdb/testsuite/gdb.ada/set_pckd_arr_elt.exp
@@ -19,25 +19,34 @@ if { [skip_ada_tests] } { return -1 }

standard_ada_testfile foo

-if {[gdb_compile_ada "${srcfile}" "${binfile}" executable {debug}] != ""} {
- return -1
-}
+foreach_with_prefix scenario {all minimal} {
+ set flags [list debug additional_flags=-fgnat-encodings=$scenario]
+
+ if {[gdb_compile_ada "${srcfile}" "${binfile}" executable $flags] != ""} {
+ return -1
+ }

-clean_restart ${testfile}
+ clean_restart ${testfile}

-set bp_location [gdb_get_line_number "STOP" ${testdir}/foo.adb]
-runto "foo.adb:$bp_location"
+ set bp_location [gdb_get_line_number "STOP" ${testdir}/foo.adb]
+ runto "foo.adb:$bp_location"

-gdb_test "print sa(3) := 9" " = 9"
+ gdb_test "print sa(3) := 9" " = 9"
+ gdb_test "print va.t(1) := 15" " = 15"

-# To verify that the assignment was made correctly, we use the fact
-# that the program passes this very same element as an argument to
-# one of the functions. So we insert a breakpoint on that function,
-# and verify that the argument value is correct.
+ # To verify that the assignment was made correctly, we use the fact
+ # that the program passes this very same element as an argument to
+ # one of the functions. So we insert a breakpoint on that function,
+ # and verify that the argument value is correct.

-gdb_breakpoint "update_small"
+ gdb_breakpoint "update_small"

-gdb_test "continue" \
+ gdb_test "continue" \
"Breakpoint .*, pck\\.update_small \\(s=9\\) at .*pck.adb:.*" \
"continue to update_small"

+ # And again for the second call.
+ gdb_test "continue" \
+ "Breakpoint .*, pck\\.update_small \\(s=15\\) at .*pck.adb:.*" \
+ "continue to update_small for va.t"
+}
diff --git a/gdb/testsuite/gdb.ada/set_pckd_arr_elt/foo.adb b/gdb/testsuite/gdb.ada/set_pckd_arr_elt/foo.adb
index da826a6e0ae..04b444ada95 100644
--- a/gdb/testsuite/gdb.ada/set_pckd_arr_elt/foo.adb
+++ b/gdb/testsuite/gdb.ada/set_pckd_arr_elt/foo.adb
@@ -17,6 +17,8 @@ with Pck; use Pck;

procedure Foo is
SA : Simple_Array := (1, 2, 3, 4);
+ VA : Variant_Access := New_Variant (Size => 3);
begin
Update_Small (SA (3)); -- STOP
+ Update_Small (VA.T (1));
end Foo;
diff --git a/gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.adb b/gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.adb
index 0cebce3430b..d19ed2ed20a 100644
--- a/gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.adb
+++ b/gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.adb
@@ -14,6 +14,13 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>.

package body Pck is
+ function New_Variant (Size : Integer) return Variant_Access is
+ Result : Variant (Size => Size) :=
+ (Size => Size, A => 11, T => (others => 13));
+ begin
+ return new Variant'(Result);
+ end New_Variant;
+
procedure Update_Small (S : in out Small) is
begin
null;
diff --git a/gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.ads b/gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.ads
index fe8b6022702..d04809d9d0a 100644
--- a/gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.ads
+++ b/gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.ads
@@ -18,5 +18,19 @@ package Pck is
type Simple_Array is array (1 .. 4) of Small;
pragma Pack (Simple_Array);

+ type Buffer is array (Integer range <>) of Small;
+ pragma Pack (Buffer);
+
+ type Variant (Size : Integer := 1) is
+ record
+ A : Small;
+ T : Buffer (1 .. Size);
+ end record;
+ pragma Pack (Variant);
+
+ type Variant_Access is access all Variant;
+
+ function New_Variant (Size : Integer) return Variant_Access;
+
procedure Update_Small (S : in out Small);
end Pck;
--
2.26.2