[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  <kirtchev@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.

From-SVN: r273336

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index f3f7217..adcb6a9 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,13 @@
 2019-07-10  Hristian Kirtchev  <kirtchev@adacore.com>
 
+       * 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  <kirtchev@adacore.com>
+
        * bindo-graphs.adb, bindo.adb, debug.adb, exp_ch6.adb,
        sem_ch10.adb, sem_ch13.adb, sem_ch3.adb, sem_ch4.adb,
        sem_ch6.adb, sem_ch7.adb, sem_res.adb, sem_spark.adb,

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index b4159a7..f18632a 100644 (file)
--- 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 5c247f1..21c5e31 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2019-07-10  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * 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  <schonberg@adacore.com>
 
        * 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 (file)
index 0000000..e3b28ec
--- /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 (file)
index 0000000..1f6e616
--- /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 (file)
index 0000000..c7d0950
--- /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 (file)
index 0000000..2a4ddd1
--- /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 (file)
index 0000000..efc1ab6
--- /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;