[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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d6cf6e78a88be19bd4027fcae285d6d2a0b8076e..ad067f641e2617b0329470689d23e4f5f448b8d6 100644 (file)
--- 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 c8c914a093b4c0e1ada872c4454a365cc8eeab87..2b96ce84b0415f3681da90d1b7e8cde8b5f83b0f 100644 (file)
--- 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;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c801b103c82b94b8c0fa4e382885f7d507cf9dda..39caa2f7776ff371b51fdd7b45ccf122301acebf 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+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.

diff --git a/gcc/testsuite/gnat.dg/discr54.adb b/gcc/testsuite/gnat.dg/discr54.adb
new file mode 100644 (file)
index 0000000..a16e75c
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/discr54.adb
@@ -0,0 +1,9 @@
+--  { dg-do compile }
+
+with Discr54_Pkg;
+pragma Unreferenced (Discr54_Pkg);
+
+procedure Discr54 is
+begin
+   null;
+end Discr54;

diff --git a/gcc/testsuite/gnat.dg/discr54_pkg.ads b/gcc/testsuite/gnat.dg/discr54_pkg.ads
new file mode 100644 (file)
index 0000000..8238258
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/discr54_pkg.ads
@@ -0,0 +1,105 @@
+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;