diff options
| -rw-r--r-- | gdb/ChangeLog | 9 | ||||
| -rw-r--r-- | gdb/ada-lang.c | 169 | ||||
| -rw-r--r-- | gdb/testsuite/ChangeLog | 4 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.ada/same_component_name.exp | 60 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.ada/same_component_name/foo.adb | 31 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.ada/same_component_name/pck.adb | 42 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.ada/same_component_name/pck.ads | 51 |
7 files changed, 364 insertions, 2 deletions
diff --git a/gdb/ChangeLog b/gdb/ChangeLog index f98ec27..83a014a 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,3 +1,12 @@ +2017-12-15 Xavier Roirand <roirand@adacore.com> + + * ada-lang.c (ada_value_primitive_field): Handle field search + in case of homonyms. + (find_struct_field): Ditto. + (ada_search_struct_field): Ditto. + (ada_value_struct_elt): Ditto. + (ada_lookup_struct_elt_type): Ditto. + 2017-12-14 Simon Marchi <simon.marchi@ericsson.com> * python/py-breakpoint.c (bppy_init): Use 'O' format specifier diff --git a/gdb/ada-lang.c b/gdb/ada-lang.c index 44f219f..c40803c 100644 --- a/gdb/ada-lang.c +++ b/gdb/ada-lang.c @@ -7232,6 +7232,56 @@ ada_value_primitive_field (struct value *arg1, int offset, int fieldno, number of fields if not found. A NULL value of NAME never matches; the function just counts visible fields in this case. + Notice that we need to handle when a tagged record hierarchy + has some components with the same name, like in this scenario: + + type Top_T is tagged record + N : Integer := 1; + U : Integer := 974; + A : Integer := 48; + end record; + + type Middle_T is new Top.Top_T with record + N : Character := 'a'; + C : Integer := 3; + end record; + + type Bottom_T is new Middle.Middle_T with record + N : Float := 4.0; + C : Character := '5'; + X : Integer := 6; + A : Character := 'J'; + end record; + + Let's say we now have a variable declared and initialized as follow: + + TC : Top_A := new Bottom_T; + + And then we use this variable to call this function + + procedure Assign (Obj: in out Top_T; TV : Integer); + + as follow: + + Assign (Top_T (B), 12); + + Now, we're in the debugger, and we're inside that procedure + then and we want to print the value of obj.c: + + Usually, the tagged record or one of the parent type owns the + component to print and there's no issue but in this particular + case, what does it mean to ask for Obj.C? Since the actual + type for object is type Bottom_T, it could mean two things: type + component C from the Middle_T view, but also component C from + Bottom_T. So in that "undefined" case, when the component is + not found in the non-resolved type (which includes all the + components of the parent type), then resolve it and see if we + get better luck once expanded. + + In the case of homonyms in the derived tagged type, we don't + guaranty anything, and pick the one that's easiest for us + to program. + Returns 1 if found, 0 otherwise. */ static int @@ -7241,6 +7291,7 @@ find_struct_field (const char *name, struct type *type, int offset, int *index_p) { int i; + int parent_offset = -1; type = ada_check_typedef (type); @@ -7262,6 +7313,20 @@ find_struct_field (const char *name, struct type *type, int offset, if (t_field_name == NULL) continue; + else if (ada_is_parent_field (type, i)) + { + /* This is a field pointing us to the parent type of a tagged + type. As hinted in this function's documentation, we give + preference to fields in the current record first, so what + we do here is just record the index of this field before + we skip it. If it turns out we couldn't find our field + in the current record, then we'll get back to it and search + inside it whether the field might exist in the parent. */ + + parent_offset = i; + continue; + } + else if (name != NULL && field_name_match (t_field_name, name)) { int bit_size = TYPE_FIELD_BITSIZE (type, i); @@ -7304,6 +7369,21 @@ find_struct_field (const char *name, struct type *type, int offset, else if (index_p != NULL) *index_p += 1; } + + /* Field not found so far. If this is a tagged type which + has a parent, try finding that field in the parent now. */ + + if (parent_offset != -1) + { + int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset); + int fld_offset = offset + bit_pos / 8; + + if (find_struct_field (name, TYPE_FIELD_TYPE (type, parent_offset), + fld_offset, field_type_p, byte_offset_p, + bit_offset_p, bit_size_p, index_p)) + return 1; + } + return 0; } @@ -7323,13 +7403,17 @@ num_visible_fields (struct type *type) and search in it assuming it has (class) type TYPE. If found, return value, else return NULL. - Searches recursively through wrapper fields (e.g., '_parent'). */ + Searches recursively through wrapper fields (e.g., '_parent'). + + In the case of homonyms in the tagged types, please refer to the + long explanation in find_struct_field's function documentation. */ static struct value * ada_search_struct_field (const char *name, struct value *arg, int offset, struct type *type) { int i; + int parent_offset = -1; type = ada_check_typedef (type); for (i = 0; i < TYPE_NFIELDS (type); i += 1) @@ -7339,6 +7423,20 @@ ada_search_struct_field (const char *name, struct value *arg, int offset, if (t_field_name == NULL) continue; + else if (ada_is_parent_field (type, i)) + { + /* This is a field pointing us to the parent type of a tagged + type. As hinted in this function's documentation, we give + preference to fields in the current record first, so what + we do here is just record the index of this field before + we skip it. If it turns out we couldn't find our field + in the current record, then we'll get back to it and search + inside it whether the field might exist in the parent. */ + + parent_offset = i; + continue; + } + else if (field_name_match (t_field_name, name)) return ada_value_primitive_field (arg, offset, i, type); @@ -7374,6 +7472,20 @@ ada_search_struct_field (const char *name, struct value *arg, int offset, } } } + + /* Field not found so far. If this is a tagged type which + has a parent, try finding that field in the parent now. */ + + if (parent_offset != -1) + { + struct value *v = ada_search_struct_field ( + name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8, + TYPE_FIELD_TYPE (type, parent_offset)); + + if (v != NULL) + return v; + } + return NULL; } @@ -7498,7 +7610,29 @@ ada_value_struct_elt (struct value *arg, const char *name, int no_err) else address = value_address (ada_coerce_ref (arg)); - t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1); + /* Check to see if this is a tagged type. We also need to handle + the case where the type is a reference to a tagged type, but + we have to be careful to exclude pointers to tagged types. + The latter should be shown as usual (as a pointer), whereas + a reference should mostly be transparent to the user. */ + + if (ada_is_tagged_type (t1, 0) + || (TYPE_CODE (t1) == TYPE_CODE_REF + && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0))) + { + /* We first try to find the searched field in the current type. + If not found then let's look in the fixed type. */ + + if (!find_struct_field (name, t1, 0, + &field_type, &byte_offset, &bit_offset, + &bit_size, NULL)) + t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, + address, NULL, 1); + } + else + t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, + address, NULL, 1); + if (find_struct_field (name, t1, 0, &field_type, &byte_offset, &bit_offset, &bit_size, NULL)) @@ -7557,6 +7691,9 @@ type_as_string (struct type *type) Looks recursively into variant clauses and parent types. + In the case of homonyms in the tagged types, please refer to the + long explanation in find_struct_field's function documentation. + If NOERR is nonzero, return NULL if NAME is not suitably defined or TYPE is not a type of the right kind. */ @@ -7565,6 +7702,7 @@ ada_lookup_struct_elt_type (struct type *type, const char *name, int refok, int noerr) { int i; + int parent_offset = -1; if (name == NULL) goto BadName; @@ -7600,6 +7738,20 @@ ada_lookup_struct_elt_type (struct type *type, const char *name, int refok, if (t_field_name == NULL) continue; + else if (ada_is_parent_field (type, i)) + { + /* This is a field pointing us to the parent type of a tagged + type. As hinted in this function's documentation, we give + preference to fields in the current record first, so what + we do here is just record the index of this field before + we skip it. If it turns out we couldn't find our field + in the current record, then we'll get back to it and search + inside it whether the field might exist in the parent. */ + + parent_offset = i; + continue; + } + else if (field_name_match (t_field_name, name)) return TYPE_FIELD_TYPE (type, i); @@ -7640,6 +7792,19 @@ ada_lookup_struct_elt_type (struct type *type, const char *name, int refok, } + /* Field not found so far. If this is a tagged type which + has a parent, try finding that field in the parent now. */ + + if (parent_offset != -1) + { + struct type *t; + + t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, parent_offset), + name, 0, 1); + if (t != NULL) + return t; + } + BadName: if (!noerr) { diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog index 50f371b..84ad6d6 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2017-12-15 Xavier Roirand <roirand@adacore.com> + + * gdb.ada/same_component_name: New testcase. + 2017-12-14 Joel Brobecker <brobecker@adacore.com> * gdb.ada/str_binop_equal: New testcase. diff --git a/gdb/testsuite/gdb.ada/same_component_name.exp b/gdb/testsuite/gdb.ada/same_component_name.exp new file mode 100644 index 0000000..c3c7645 --- /dev/null +++ b/gdb/testsuite/gdb.ada/same_component_name.exp @@ -0,0 +1,60 @@ +# Copyright 2017 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" + +standard_ada_testfile foo + +if {[gdb_compile_ada "${srcfile}" "${binfile}" executable [list debug ]] != "" } { + return -1 +} + +clean_restart ${testfile} + +set bp_top_location [gdb_get_line_number "BREAK_TOP" ${testdir}/pck.adb] +set bp_middle_location [gdb_get_line_number "BREAK_MIDDLE" ${testdir}/pck.adb] +set bp_bottom_location [gdb_get_line_number "BREAK_BOTTOM" ${testdir}/pck.adb] + +gdb_breakpoint "pck.adb:$bp_top_location" +gdb_breakpoint "pck.adb:$bp_middle_location" +gdb_breakpoint "pck.adb:$bp_bottom_location" + +gdb_run_cmd + +gdb_test "" \ + ".*Breakpoint $decimal, pck.top.assign \\(.*\\).*" \ + "run to top assign breakpoint" + +gdb_test "print obj.n" " = 1" "Print top component field" + +gdb_test "continue" \ + ".*Breakpoint $decimal, pck.assign \\(.*\\).*" \ + "continue to bottom assign breakpoint" + +gdb_test "print obj.n" " = 4\\.0" "Print bottom component field" + +gdb_test "continue" \ + ".*Breakpoint $decimal, pck.middle.assign \\(.*\\).*" \ + "continue to middle assign breakpoint" + +gdb_test "print obj.a" " = 48" \ + "Print top component field in middle assign function" + +gdb_test "continue" \ + ".*Breakpoint $decimal, pck.assign \\(.*\\).*" \ + "continue to bottom assign breakpoint (2nd time)" + +gdb_test "print obj.x" " = 6" \ + "Print field existing only in bottom component" diff --git a/gdb/testsuite/gdb.ada/same_component_name/foo.adb b/gdb/testsuite/gdb.ada/same_component_name/foo.adb new file mode 100644 index 0000000..2a3c763 --- /dev/null +++ b/gdb/testsuite/gdb.ada/same_component_name/foo.adb @@ -0,0 +1,31 @@ +-- Copyright 2017 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 Pck; +use Pck; +use Pck.Middle; +use Pck.Top; + +procedure Foo is + B : Bottom_T; + M : Middle_T; + +begin + Assign (Top_T (B), 12); + Assign (B, 10.0); + + Assign (M, 'V'); + Assign (B, 5.0); +end Foo; diff --git a/gdb/testsuite/gdb.ada/same_component_name/pck.adb b/gdb/testsuite/gdb.ada/same_component_name/pck.adb new file mode 100644 index 0000000..c0f7ba1 --- /dev/null +++ b/gdb/testsuite/gdb.ada/same_component_name/pck.adb @@ -0,0 +1,42 @@ +-- Copyright 2010-2017 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 System; + +package body Pck is + package body Top is + procedure Assign (Obj: in out Top_T; TV : Integer) is + begin + Do_Nothing (Obj'Address); -- BREAK_TOP + end Assign; + end Top; + + package body Middle is + procedure Assign (Obj: in out Middle_T; MV : Character) is + begin + Do_Nothing (Obj'Address); -- BREAK_MIDDLE + end Assign; + end Middle; + + procedure Assign (Obj: in out Bottom_T; BV : Float) is + begin + Do_Nothing (Obj'Address); -- BREAK_BOTTOM + end Assign; + + procedure Do_Nothing (A : System.Address) is + begin + null; + end Do_Nothing; +end Pck; diff --git a/gdb/testsuite/gdb.ada/same_component_name/pck.ads b/gdb/testsuite/gdb.ada/same_component_name/pck.ads new file mode 100644 index 0000000..813fc9d --- /dev/null +++ b/gdb/testsuite/gdb.ada/same_component_name/pck.ads @@ -0,0 +1,51 @@ +-- Copyright 2017 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 System; + +package Pck is + + package Top is + type Top_T is tagged private; + type Top_A is access Top_T'Class; + procedure Assign (Obj: in out Top_T; TV : Integer); + private + type Top_T is tagged record + N : Integer := 1; + A : Integer := 48; + end record; + end Top; + + package Middle is + type Middle_T is new Top.Top_T with private; + type Middle_A is access Middle_T'Class; + procedure Assign (Obj: in out Middle_T; MV : Character); + private + type Middle_T is new Top.Top_T with record + N : Character := 'a'; + end record; + end Middle; + + type Bottom_T is new Middle.Middle_T with record + N : Float := 4.0; + X : Integer := 6; + A : Character := 'J'; + end record; + type Bottom_A is access Bottom_T'Class; + procedure Assign (Obj: in out Bottom_T; BV : Float); + + procedure Do_Nothing (A : System.Address); + +end Pck; |