(Ada) Handle same component names when searching in tagged types

Consider the following code:

   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;

Tagged records in Ada provide object-oriented features, and what
is interesting in the code above is that a child tagged record
introduce additional components (fields) which sometimes have
the same name as one of the components in the parent. For instance,
Bottom_T introduces a component named "C", while at the same time
inheriting from Middle_T which also has a component named "C";
so, in essence, type Bottom_T has two components with the same name!

And before people start wondering why the language can possibly
be allowing that, this can only happen if the parent type has
a private definition. In our case, this was brought to our attention
when the parent was a generic paramenter.

With that in mind...  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
(Top.Assign in our gdb testcase), 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.

This patch fixes the behavior like described above.

gdb/ChangeLog:

        * 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.

gdb/testsuite/ChangeLog:

        * gdb.ada/same_component_name: New testcase.

Tested on x86_64-linux.

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;