[Ada] Fix handling of inherited discriminant constraints

2018-07-17  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_util.adb (Gather_Components): A discriminant of an ancestor may
	have been constrained by a later ancestor, so when looking for the
	value of that hidden discriminant we must examine the stored constraint
	of other ancestors than the immediate parent type.

gcc/testsuite/

	* gnat.dg/discr54.adb, gnat.dg/discr54_pkg.ads: New testcase.

From-SVN: r262767

2 files changed, 40 insertions, 21 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d6cf6e7..ad067f6 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2018-07-17  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_util.adb (Gather_Components): A discriminant of an ancestor may
+	have been constrained by a later ancestor, so when looking for the
+	value of that hidden discriminant we must examine the stored constraint
+	of other ancestors than the immediate parent type.
+
 2018-07-17  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* exp_ch6.adb (Build_Heap_Or_Pool_Allocator): Ensure that scoping
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index c8c914a..2b96ce8 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -8805,7 +8805,6 @@ package body Sem_Util is
          if No (Next (Assoc)) then
             if not Is_Constrained (Typ)
               and then Is_Derived_Type (Typ)
-              and then Present (Stored_Constraint (Typ))
             then
                --  If the type is a tagged type with inherited discriminants,
                --  use the stored constraint on the parent in order to find
@@ -8819,35 +8818,48 @@ package body Sem_Util is
                --  of them. We recover the constraint on the others from the
                --  Stored_Constraint as well.
 
+               --  An inherited discriminant may have been constrained in a
+               --  later ancestor (no the immediate parent) so we must examine
+               --  the stored constraint of all of them to locate the inherited
+               --  value.
+
                declare
                   D : Entity_Id;
                   C : Elmt_Id;
+                  T : Entity_Id := Typ;
 
                begin
-                  D := First_Discriminant (Etype (Typ));
-                  C := First_Elmt (Stored_Constraint (Typ));
-                  while Present (D) and then Present (C) loop
-                     if Chars (Discrim_Name) = Chars (D) then
-                        if Is_Entity_Name (Node (C))
-                          and then Entity (Node (C)) = Entity (Discrim)
-                        then
-                           --  D is renamed by Discrim, whose value is given in
-                           --  Assoc.
+                  while Is_Derived_Type (T) loop
+                     if Present (Stored_Constraint (T)) then
+                        D := First_Discriminant (Etype (T));
+                        C := First_Elmt (Stored_Constraint (T));
+                        while Present (D) and then Present (C) loop
+                           if Chars (Discrim_Name) = Chars (D) then
+                              if Is_Entity_Name (Node (C))
+                                and then Entity (Node (C)) = Entity (Discrim)
+                              then
+                                 --  D is renamed by Discrim, whose value is
+                                 --  given in Assoc.
 
-                           null;
+                                 null;
 
-                        else
-                           Assoc :=
-                             Make_Component_Association (Sloc (Typ),
-                               New_List
-                                 (New_Occurrence_Of (D, Sloc (Typ))),
-                                  Duplicate_Subexpr_No_Checks (Node (C)));
-                        end if;
-                        exit Find_Constraint;
+                              else
+                                 Assoc :=
+                                   Make_Component_Association (Sloc (Typ),
+                                     New_List
+                                       (New_Occurrence_Of (D, Sloc (Typ))),
+                                     Duplicate_Subexpr_No_Checks (Node (C)));
+                              end if;
+                              exit Find_Constraint;
+                           end if;
+
+                           Next_Discriminant (D);
+                           Next_Elmt (C);
+                        end loop;
                      end if;
 
-                     Next_Discriminant (D);
-                     Next_Elmt (C);
+                     --  Discriminant may be inherited from ancestor.
+                     T := Etype (T);
                   end loop;
                end;
             end if;