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,
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;
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);
--- /dev/null
+# 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"
--- /dev/null
+-- 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;
--- /dev/null
+-- 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;
--- /dev/null
+-- 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;
projects / binutils-gdb.git / commitdiff