[pushed] Decode "dynamic" interface types in Ada

[pushed] Decode "dynamic" interface types in Ada

[Tom Tromey]

In Ada, if a class implements an interface and has a dynamic
superclass, then the "offset to top" -- the offset that says how to
turn a pointer to the interface into a pointer to the whole object --
is stored in the object itself.  This patch changes GDB to understand
this.

Because this only touches Ada code, and because Joel already reviewed
it internally, I am checking it in.
---
 gdb/ada-lang.c                                | 51 ++++++++++++++-----
 gdb/testsuite/gdb.ada/dynamic-iface.exp       | 44 ++++++++++++++++
 .../gdb.ada/dynamic-iface/concrete.adb        | 23 +++++++++
 .../gdb.ada/dynamic-iface/concrete.ads        | 36 +++++++++++++
 gdb/testsuite/gdb.ada/dynamic-iface/main.adb  | 24 +++++++++
 5 files changed, 165 insertions(+), 13 deletions(-)
 create mode 100644 gdb/testsuite/gdb.ada/dynamic-iface.exp
 create mode 100644 gdb/testsuite/gdb.ada/dynamic-iface/concrete.adb
 create mode 100644 gdb/testsuite/gdb.ada/dynamic-iface/concrete.ads
 create mode 100644 gdb/testsuite/gdb.ada/dynamic-iface/main.adb

diff --git a/gdb/ada-lang.c b/gdb/ada-lang.c
index 59cbb110116..a3a1a2bcec5 100644
--- a/gdb/ada-lang.c
+++ b/gdb/ada-lang.c
@@ -6287,6 +6287,18 @@ ada_is_ignored_field (struct type *type, int field_num)
        should not be ignored either.  */
     if (name[0] == '_' && !startswith (name, "_parent"))
       return 1;
+
+    /* The compiler doesn't document this, but sometimes it emits
+       a field whose name starts with a capital letter, like 'V148s'.
+       These aren't marked as artificial in any way, but we know they
+       should be ignored.  However, wrapper fields should not be
+       ignored.  */
+    if (name[0] == 'S' || name[0] == 'R' || name[0] == 'O')
+      {
+	/* Wrapper field.  */
+      }
+    else if (isupper (name[0]))
+      return 1;
   }
 
   /* If this is the dispatch table of a tagged type or an interface tag,
@@ -6422,9 +6434,10 @@ ada_tag_value_at_base_address (struct value *obj)
   if (is_ada95_tag (tag))
     return obj;
 
-  ptr_type = language_lookup_primitive_type
-    (language_def (language_ada), target_gdbarch(), "storage_offset");
-  ptr_type = lookup_pointer_type (ptr_type);
+  struct type *offset_type
+    = language_lookup_primitive_type (language_def (language_ada),
+				      target_gdbarch(), "storage_offset");
+  ptr_type = lookup_pointer_type (offset_type);
   val = value_cast (ptr_type, tag);
   if (!val)
     return obj;
@@ -6456,16 +6469,28 @@ ada_tag_value_at_base_address (struct value *obj)
   if (offset_to_top == -1)
     return obj;
 
-  /* OFFSET_TO_TOP used to be a positive value to be subtracted
-     from the base address.  This was however incompatible with
-     C++ dispatch table: C++ uses a *negative* value to *add*
-     to the base address.  Ada's convention has therefore been
-     changed in GNAT 19.0w 20171023: since then, C++ and Ada
-     use the same convention.  Here, we support both cases by
-     checking the sign of OFFSET_TO_TOP.  */
-
-  if (offset_to_top > 0)
-    offset_to_top = -offset_to_top;
+  /* Storage_Offset'Last is used to indicate that a dynamic offset to
+     top is used.  In this situation the offset is stored just after
+     the tag, in the object itself.  */
+  ULONGEST last = (((ULONGEST) 1) << (8 * TYPE_LENGTH (offset_type) - 1)) - 1;
+  if (offset_to_top == last)
+    {
+      struct value *tem = value_addr (tag);
+      tem = value_ptradd (tem, 1);
+      tem = value_cast (ptr_type, tem);
+      offset_to_top = value_as_long (value_ind (tem));
+    }
+  else if (offset_to_top > 0)
+    {
+      /* OFFSET_TO_TOP used to be a positive value to be subtracted
+	 from the base address.  This was however incompatible with
+	 C++ dispatch table: C++ uses a *negative* value to *add*
+	 to the base address.  Ada's convention has therefore been
+	 changed in GNAT 19.0w 20171023: since then, C++ and Ada
+	 use the same convention.  Here, we support both cases by
+	 checking the sign of OFFSET_TO_TOP.  */
+      offset_to_top = -offset_to_top;
+    }
 
   base_address = value_address (obj) + offset_to_top;
   tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
diff --git a/gdb/testsuite/gdb.ada/dynamic-iface.exp b/gdb/testsuite/gdb.ada/dynamic-iface.exp
new file mode 100644
index 00000000000..2942a437687
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/dynamic-iface.exp
@@ -0,0 +1,44 @@
+# Copyright 2022 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/>.
+
+load_lib "ada.exp"
+
+if { [skip_ada_tests] } { return -1 }
+
+if {![gnat_runtime_has_debug_info]} {
+    untested "GNAT runtime debuginfo required for this test"
+    return -1
+}
+
+standard_ada_testfile main
+
+if {[gdb_compile_ada "${srcfile}" "${binfile}" executable {debug additional_flags=-gnat05}] != "" } {
+  return -1
+}
+
+clean_restart ${testfile}
+
+set bp_location [gdb_get_line_number "STOP" ${testdir}/concrete.adb]
+runto "concrete.adb:$bp_location"
+
+gdb_test "print obj" \
+    [string_to_regexp "(n => 3, a => \"ABC\", value => 93)"] \
+    "print local as interface"
+
+gdb_continue_to_breakpoint STOP
+
+gdb_test "print obj" \
+    [string_to_regexp "(n => 5, a => \"DEFGH\", value => 107)"] \
+    "print local2 as interface"
diff --git a/gdb/testsuite/gdb.ada/dynamic-iface/concrete.adb b/gdb/testsuite/gdb.ada/dynamic-iface/concrete.adb
new file mode 100644
index 00000000000..66cbbbcf41d
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/dynamic-iface/concrete.adb
@@ -0,0 +1,23 @@
+--  Copyright 2022 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/>.
+
+package body Concrete is
+
+   procedure Accept_Iface (Obj: Iface'Class) is
+   begin
+      null;                     -- STOP
+   end Accept_Iface;
+
+end Concrete;
diff --git a/gdb/testsuite/gdb.ada/dynamic-iface/concrete.ads b/gdb/testsuite/gdb.ada/dynamic-iface/concrete.ads
new file mode 100644
index 00000000000..3d44e42d4f3
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/dynamic-iface/concrete.ads
@@ -0,0 +1,36 @@
+--  Copyright 2022 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/>.
+
+package Concrete is
+   type Iface is interface;
+
+   type Base (N : Integer) is tagged record
+      A : String (1 .. N);
+   end record;
+
+   -- An empty extension of Base.  The compiler sources claimed there
+   -- was a special case for this, and while that doesn't seem to be
+   -- true in practice, it's worth checking.
+   type Intermediate is new Base with record
+      null;
+   end record;
+
+   type Object is new Intermediate and Iface with record
+      Value: Integer;
+   end record;
+
+   procedure Accept_Iface (Obj: Iface'Class);
+
+end Concrete;
diff --git a/gdb/testsuite/gdb.ada/dynamic-iface/main.adb b/gdb/testsuite/gdb.ada/dynamic-iface/main.adb
new file mode 100644
index 00000000000..01e19f297b5
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/dynamic-iface/main.adb
@@ -0,0 +1,24 @@
+--  Copyright 2022 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/>.
+
+with Concrete; use Concrete;
+
+procedure Main is
+   Local : Object := (N => 3, A => "ABC", Value => 93);
+   Local2 : Object := (N => 5, A => "DEFGH", Value => 107);
+begin
+   Accept_Iface (Local);
+   Accept_Iface (Local2);
+end Main;
-- 
2.34.1

Re: [pushed] Decode "dynamic" interface types in Ada

[Tom de Vries]

[-- Attachment #1: Type: text/plain, Size: 653 bytes --]

On 3/30/22 17:00, Tom Tromey via Gdb-patches wrote:
> In Ada, if a class implements an interface and has a dynamic
> superclass, then the "offset to top" -- the offset that says how to
> turn a pointer to the interface into a pointer to the whole object --
> is stored in the object itself.  This patch changes GDB to understand
> this.
> 
> Because this only touches Ada code, and because Joel already reviewed
> it internally, I am checking it in.

This passes for me with gcc-12, but fails for me with gcc-11 and earlier.

Is this test-case expected to pass when using older compilers?

If not, this patch add the appropriate xfails.

Thanks,
- Tom


[-- Attachment #2: 0001-gdb-testsuite-Add-xfail-in-gdb.ada-dynamic-iface.exp.patch --]
[-- Type: text/x-patch, Size: 1807 bytes --]

[gdb/testsuite] Add xfail in gdb.ada/dynamic-iface.exp

On openSUSE Leap 15.3 with gcc 7.5.0 I run into:
...
(gdb) print obj^M
$1 = ()^M
(gdb) FAIL: gdb.ada/dynamic-iface.exp: print local as interface
...

The test passes with gcc-12, but also fails with gcc-11.

Assume this is a problem with older compilers, and xfail it.

Tested on x86_64-linux.

---
 gdb/testsuite/gdb.ada/dynamic-iface.exp | 34 +++++++++++++++++++++++++++------
 1 file changed, 28 insertions(+), 6 deletions(-)

diff --git a/gdb/testsuite/gdb.ada/dynamic-iface.exp b/gdb/testsuite/gdb.ada/dynamic-iface.exp
index 2942a437687..6542bb43c5a 100644
--- a/gdb/testsuite/gdb.ada/dynamic-iface.exp
+++ b/gdb/testsuite/gdb.ada/dynamic-iface.exp
@@ -33,12 +33,34 @@ clean_restart ${testfile}
 set bp_location [gdb_get_line_number "STOP" ${testdir}/concrete.adb]
 runto "concrete.adb:$bp_location"
 
-gdb_test "print obj" \
-    [string_to_regexp "(n => 3, a => \"ABC\", value => 93)"] \
-    "print local as interface"
+set have_xfail [expr ![test_compiler_info {gcc-1[2-9]-*}]]
+
+set re [string_to_regexp "(n => 3, a => \"ABC\", value => 93)"]
+gdb_test_multiple "print obj" "print local as interface" {
+    -wrap -re $re {
+	pass $gdb_test_name
+    }
+    -wrap -re "()" {
+	if { $have_xfail } {
+	    xfail $gdb_test_name
+	} else {
+	    pass $gdb_test_name
+	}
+    }
+}
 
 gdb_continue_to_breakpoint STOP
 
-gdb_test "print obj" \
-    [string_to_regexp "(n => 5, a => \"DEFGH\", value => 107)"] \
-    "print local2 as interface"
+set re [string_to_regexp "(n => 5, a => \"DEFGH\", value => 107)"]
+gdb_test_multiple "print obj" "print local2 as interface" {
+    -wrap -re $re {
+	pass $gdb_test_name
+    }
+    -wrap -re "()" {
+	if { $have_xfail } {
+	    xfail $gdb_test_name
+	} else {
+	    pass $gdb_test_name
+	}
+    }
+}