From efa129331c5ceb9937c990f45f3bfd447cbe290e Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 17 Jul 2018 08:03:49 +0000 Subject: [PATCH] [Ada] Fix handling of inherited discriminant constraints 2018-07-17 Ed Schonberg 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 | 7 ++ gcc/ada/sem_util.adb | 54 +++++++------ gcc/testsuite/ChangeLog | 4 + gcc/testsuite/gnat.dg/discr54.adb | 9 +++ gcc/testsuite/gnat.dg/discr54_pkg.ads | 105 ++++++++++++++++++++++++++ 5 files changed, 158 insertions(+), 21 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/discr54.adb create mode 100644 gcc/testsuite/gnat.dg/discr54_pkg.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d6cf6e78a88..ad067f641e2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2018-07-17 Ed Schonberg + + * 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 * 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 c8c914a093b..2b96ce84b04 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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c801b103c82..39caa2f7776 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-07-17 Ed Schonberg + + * gnat.dg/discr54.adb, gnat.dg/discr54_pkg.ads: New testcase. + 2018-07-17 Hristian Kirtchev * 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 index 00000000000..a16e75c81df --- /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 index 00000000000..82382585251 --- /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; -- 2.30.2