[binutils-gdb] Decode "dynamic" interface types in Ada

[binutils-gdb] Decode "dynamic" interface types in Ada

[Tom Tromey]

https://sourceware.org/git/gitweb.cgi?p=binutils-gdb.git;h=d537777dfe634f3109125156484e33d421b03f1b

commit d537777dfe634f3109125156484e33d421b03f1b
Author: Tom Tromey <tromey@adacore.com>
Date:   Thu Mar 17 07:59:43 2022 -0600

    Decode "dynamic" interface types in Ada
    
    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.

Diff:
---
 gdb/ada-lang.c                                   | 51 ++++++++++++++++++------
 gdb/testsuite/gdb.ada/dynamic-iface.exp          | 44 ++++++++++++++++++++
 gdb/testsuite/gdb.ada/dynamic-iface/concrete.adb | 23 +++++++++++
 gdb/testsuite/gdb.ada/dynamic-iface/concrete.ads | 36 +++++++++++++++++
 gdb/testsuite/gdb.ada/dynamic-iface/main.adb     | 24 +++++++++++
 5 files changed, 165 insertions(+), 13 deletions(-)

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;