[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

gcc/ada/ChangeLog

+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

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,20 +8818,28 @@ 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 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.
+                                 --  D is renamed by Discrim, whose value is
+                                 --  given in Assoc.
 
                                  null;
 
@@ -8849,6 +8856,11 @@ package body Sem_Util is
                            Next_Discriminant (D);
                            Next_Elmt (C);
                         end loop;
+                     end if;
+
+                     --  Discriminant may be inherited from ancestor.
+                     T := Etype (T);
+                  end loop;
                end;
             end if;
          end if;

gcc/testsuite/ChangeLog

+2018-07-17  Ed Schonberg  <schonberg@adacore.com>
+
+	* gnat.dg/discr54.adb, gnat.dg/discr54_pkg.ads: New testcase.
+
 2018-07-17  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* gnat.dg/bip_case_expr.adb, gnat.dg/bip_case_expr_pkg.ads: New testcase.

gcc/testsuite/gnat.dg/discr54.adb

+--  { dg-do compile }
+
+with Discr54_Pkg;
+pragma Unreferenced (Discr54_Pkg);
+
+procedure Discr54 is
+begin
+   null;
+end Discr54;

gcc/testsuite/gnat.dg/discr54_pkg.ads

+package Discr54_Pkg is
+
+  type E_TYPE is (A_KIND, B_KIND, C_KIND, X_KIND);
+
+  type DR0 (V : E_TYPE) is tagged
+    record
+      I0 : INTEGER;
+      case V is
+        when A_KIND | B_KIND =>
+          I1 : INTEGER;
+          I2 : INTEGER;
+        when C_KIND | X_KIND =>
+          I3 : INTEGER;
+      end case;
+    end record;
+
+  type DN1 is new DR0 (V => A_KIND) with
+    record
+      I4 : INTEGER;
+      I5 : INTEGER;
+    end record;
+
+  type DR1 (W : E_TYPE) is new DR0 (V => A_KIND) with
+    record
+      I4 : INTEGER;
+      case W is
+        when A_KIND | B_KIND =>
+          I5 : INTEGER;
+        when C_KIND | X_KIND =>
+          I6 : INTEGER;
+      end case;
+    end record;
+
+  type DD1 (W : E_TYPE; V : E_TYPE) is new DR0 (V => V) with
+    record
+      I4 : INTEGER;
+      case W is
+        when A_KIND | B_KIND =>
+          I5 : INTEGER;
+        when C_KIND | X_KIND =>
+          I6 : INTEGER;
+      end case;
+    end record;
+
+  type DR2 is new DR1 (W => A_KIND) with
+    record
+      I7 : INTEGER;
+    end record;
+
+  V0 : constant DR0 := DR0'(I0 => 0,
+                            V  => A_KIND,
+                            I1 => 0,
+                            I2 => 0
+                           );
+
+  N1 : constant DN1 := DN1'(V  => A_KIND,
+                            I0 => 0,
+                            I1 => 0,
+                            I2 => 0,
+                            I4 => 0,
+                            I5 => 0);
+
+  N2 : constant DN1 := DN1'(V  => A_KIND,
+                            I0 => 0,
+                            I1 => 0,
+                            I2 => 0,
+                            I4 => 0,
+                            I5 => 0);
+
+  D1 : constant DD1 := DD1'(W  => A_KIND,
+                            V  => A_KIND,
+                            I0 => 0,
+                            I1 => 0,
+                            I2 => 0,
+                            I4 => 0,
+                            I5 => 0);
+
+  V1 : constant DR1 := DR1'(W  => A_KIND,
+                            I0 => 0,
+                            I1 => 0,
+                            I2 => 0,
+                            I4 => 0,
+                            I5 => 0);
+
+  V3 : constant DR2 := DR2'(V1 with I7 => 0);
+  V2 : constant DR2 := DR2'(
+                            --  V  => A_KIND,  --  needed???
+                            W  => A_KIND,
+                            I0 => 0,
+                            I1 => 1,
+                            I2 => 2,
+                            I4 => 4,
+                            I5 => 5,
+                            I7 => 7);
+
+  pragma Assert (
+      V2.I0 = 0
+    and then V2.I1 = 1
+    and then V2.I1 = 1
+    and then V2.I2 = 2
+    and then V2.I4 = 4
+    and then V2.I5 = 5
+    and then V2.I7 = 1);
+
+end Discr54_Pkg;