From d537777dfe634f3109125156484e33d421b03f1b Mon Sep 17 00:00:00 2001 From: Tom Tromey Date: Thu, 17 Mar 2022 07:59:43 -0600 Subject: [PATCH] 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. --- 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 . + +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 . + +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 . + +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 . + +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.30.2