From: Hristian Kirtchev Date: Wed, 10 Jul 2019 09:01:38 +0000 (+0000) Subject: [Ada] Spurious error on case expression with limited result X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=5b4ce2a0360a79751107c245c2e44c0932835164;p=gcc.git [Ada] Spurious error on case expression with limited result This patch modifies the expansion of case expressions to prevent a spurious error caused by the use of assignment statements to capture the result of the case expression when the associated type is limited. 2019-07-10 Hristian Kirtchev gcc/ada/ * exp_ch4.adb (Expand_N_Case_Expression): Mark the generated assignments to the temporary result as being OK because the expansion of case expressions is correct by construction. (Is_Copy_Type): Update the predicate to match the comment within. gcc/testsuite/ * gnat.dg/limited2.adb, gnat.dg/limited2_pack_1.adb, gnat.dg/limited2_pack_1.ads, gnat.dg/limited2_pack_2.adb, gnat.dg/limited2_pack_2.ads: New testcase. From-SVN: r273336 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f3f7217f95b..adcb6a94c56 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,11 @@ +2019-07-10 Hristian Kirtchev + + * exp_ch4.adb (Expand_N_Case_Expression): Mark the generated + assignments to the temporary result as being OK because the + expansion of case expressions is correct by construction. + (Is_Copy_Type): Update the predicate to match the comment + within. + 2019-07-10 Hristian Kirtchev * bindo-graphs.adb, bindo.adb, debug.adb, exp_ch6.adb, diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index b4159a7cefc..f18632a55db 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -5087,7 +5087,6 @@ package body Exp_Ch4 is ------------------------------ procedure Expand_N_Case_Expression (N : Node_Id) is - function Is_Copy_Type (Typ : Entity_Id) return Boolean; -- Return True if we can copy objects of this type when expanding a case -- expression. @@ -5106,7 +5105,7 @@ package body Exp_Ch4 is or else (Minimize_Expression_With_Actions and then Is_Constrained (Underlying_Type (Typ)) - and then not Is_Limited_View (Underlying_Type (Typ))); + and then not Is_Limited_Type (Underlying_Type (Typ))); end Is_Copy_Type; -- Local variables @@ -5283,6 +5282,7 @@ package body Exp_Ch4 is declare Alt_Expr : Node_Id := Expression (Alt); Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr); + LHS : Node_Id; Stmts : List_Id; begin @@ -5312,9 +5312,12 @@ package body Exp_Ch4 is -- Target := AX['Unrestricted_Access]; else + LHS := New_Occurrence_Of (Target, Loc); + Set_Assignment_OK (LHS); + Stmts := New_List ( Make_Assignment_Statement (Alt_Loc, - Name => New_Occurrence_Of (Target, Loc), + Name => LHS, Expression => Alt_Expr)); end if; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 5c247f16f16..21c5e319c4f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2019-07-10 Hristian Kirtchev + + * gnat.dg/limited2.adb, gnat.dg/limited2_pack_1.adb, + gnat.dg/limited2_pack_1.ads, gnat.dg/limited2_pack_2.adb, + gnat.dg/limited2_pack_2.ads: New testcase. + 2019-07-10 Ed Schonberg * gnat.dg/equal8.adb, gnat.dg/equal8.ads, diff --git a/gcc/testsuite/gnat.dg/limited2.adb b/gcc/testsuite/gnat.dg/limited2.adb new file mode 100644 index 00000000000..e3b28ec6018 --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited2.adb @@ -0,0 +1,8 @@ +-- { dg-do compile } + +with Limited2_Pack_2; + +procedure Limited2 is +begin + Limited2_Pack_2.Create (P => Limited2_Pack_2.C1); +end Limited2; diff --git a/gcc/testsuite/gnat.dg/limited2_pack_1.adb b/gcc/testsuite/gnat.dg/limited2_pack_1.adb new file mode 100644 index 00000000000..1f6e616c911 --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited2_pack_1.adb @@ -0,0 +1,5 @@ +package body Limited2_Pack_1 is + type B is record + F : Integer := 0; + end record; +end Limited2_Pack_1; diff --git a/gcc/testsuite/gnat.dg/limited2_pack_1.ads b/gcc/testsuite/gnat.dg/limited2_pack_1.ads new file mode 100644 index 00000000000..c7d0950d0ba --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited2_pack_1.ads @@ -0,0 +1,8 @@ +package Limited2_Pack_1 is + type A is limited private; + type A_Ptr is access all A; + +private + type B; + type A is access all B; +end Limited2_Pack_1; diff --git a/gcc/testsuite/gnat.dg/limited2_pack_2.adb b/gcc/testsuite/gnat.dg/limited2_pack_2.adb new file mode 100644 index 00000000000..2a4ddd1d25d --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited2_pack_2.adb @@ -0,0 +1,21 @@ +with Limited2_Pack_1; + +package body Limited2_Pack_2 is + Obj_1 : Limited2_Pack_1.A; + Obj_2 : Limited2_Pack_1.A; + Obj_3 : Limited2_Pack_1.A; + + procedure M (R : Limited2_Pack_1.A) is + begin + null; + end M; + + procedure Create (P : in C) is + begin + M (R => Obj_1); + M (R => (case P is + when C1 => Obj_1, + when C2 => Obj_2, + when C3 => Obj_3)); + end Create; +end Limited2_Pack_2; diff --git a/gcc/testsuite/gnat.dg/limited2_pack_2.ads b/gcc/testsuite/gnat.dg/limited2_pack_2.ads new file mode 100644 index 00000000000..efc1ab6591c --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited2_pack_2.ads @@ -0,0 +1,5 @@ +package Limited2_Pack_2 is + type C is (C1, C2, C3); + + procedure Create (P : in C); +end Limited2_Pack_2;