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.
Tested on x86_64-pc-linux-gnu, committed on trunk
2019-07-10 Hristian Kirtchev <kirtc...@adacore.com>
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.--- gcc/ada/exp_ch4.adb
+++ 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;
--- /dev/null
new file mode 100644
+++ 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;
--- /dev/null
new file mode 100644
+++ 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;
--- /dev/null
new file mode 100644
+++ 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;
--- /dev/null
new file mode 100644
+++ 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;
--- /dev/null
new file mode 100644
+++ 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;
