[Ada] Illegal limited function call accepted in a type conversion

It's illegal to call a function with a result of an immutably limited
type inside a type conversion that's used in one of the special contexts
that allow such a function call by itself (see RM 7.5 (2.1-2.10)), such
as in the initialization expression of an object declaration. The
compiler was recursively applying OK_For_Limited_Init_In_05 to the
expression inside of a rewritten type conversion, rather than directly
to the Original_Node itself (which is what was cased on to get to the
type conversion case alternative), which allowed such illegal
initialization, and that's corrected by this fix. However, when the
expression is not a rewriting of a user-written conversion, the
recursive call to OK_For_Limited_Init_In_05 must be applied to the
Expression of the conversion.

2019-08-20  Gary Dismukes  <dismukes@adacore.com>

gcc/ada/

	* sem_ch3.adb (OK_For_Limited_Init_In_05): In the case of type
	conversions, apply the recursive call to the Original_Node of
	the expression Exp rather than the Expression of the
	Original_Node, in the case where Exp has been rewritten;
	otherwise, when Original_Node is the same as Exp, apply the
	recursive call to the Expression.
	(Check_Initialization): Revise condition for special check on
	type conversions of limited function calls to test Original_Node
	(avoiding spurious errors on expanded unchecked conversions
	applied to build-in-place dispatching calls).

gcc/testsuite/

	* gnat.dg/type_conv2.adb, gnat.dg/type_conv2.ads: New testcase.

From-SVN: r274731

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index cfc609aa4334856f7b5c3500c8b325d08da2acd6..ecda7b8695a86a08945d2a6d760b3f938dd6c08a 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,16 @@
+2019-08-20  Gary Dismukes  <dismukes@adacore.com>
+
+       * sem_ch3.adb (OK_For_Limited_Init_In_05): In the case of type
+       conversions, apply the recursive call to the Original_Node of
+       the expression Exp rather than the Expression of the
+       Original_Node, in the case where Exp has been rewritten;
+       otherwise, when Original_Node is the same as Exp, apply the
+       recursive call to the Expression.
+       (Check_Initialization): Revise condition for special check on
+       type conversions of limited function calls to test Original_Node
+       (avoiding spurious errors on expanded unchecked conversions
+       applied to build-in-place dispatching calls).
+
 2019-08-20  Patrick Bernardi  <bernardi@adacore.com>
 
        * exp_aggr.adb (Expand_Record_Aggregate): Always convert a

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 1b4c42d33a321228f1f6b63ce74883f421ad13a6..4afa3a69083260f556943b5048448e8cea1ca0b3 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -11870,10 +11870,14 @@ package body Sem_Ch3 is
 
             else
                --  Specialize error message according to kind of illegal
-               --  initial expression.
+               --  initial expression. We check the Original_Node to cover
+               --  cases where the initialization expression of an object
+               --  declaration generated by the compiler has been rewritten
+               --  (such as for dispatching calls).
 
-               if Nkind (Exp) = N_Type_Conversion
-                 and then Nkind (Expression (Exp)) = N_Function_Call
+               if Nkind (Original_Node (Exp)) = N_Type_Conversion
+                 and then
+                   Nkind (Expression (Original_Node (Exp))) = N_Function_Call
                then
                   --  No error for internally-generated object declarations,
                   --  which can come from build-in-place assignment statements.
@@ -19648,8 +19652,20 @@ package body Sem_Ch3 is
          =>
             return not Comes_From_Source (Exp)
               and then
-                OK_For_Limited_Init_In_05
-                  (Typ, Expression (Original_Node (Exp)));
+                --  If the conversion has been rewritten, check Original_Node
+
+                ((Original_Node (Exp) /= Exp
+                   and then
+                     OK_For_Limited_Init_In_05 (Typ, Original_Node (Exp)))
+
+                  --  Otherwise, check the expression of the compiler-generated
+                  --  conversion (which is a conversion that we want to ignore
+                  --  for purposes of the limited-initialization restrictions).
+
+                  or else
+                    (Original_Node (Exp) = Exp
+                      and then
+                        OK_For_Limited_Init_In_05 (Typ, Expression (Exp))));
 
          when N_Explicit_Dereference
             | N_Indexed_Component

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 61e37dad25ba8b680d861dc6e8330e9a8fa74d8d..e53afce4540c9129678210278d876aeb12cb4301 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2019-08-20  Gary Dismukes  <dismukes@adacore.com>
+
+       * gnat.dg/type_conv2.adb, gnat.dg/type_conv2.ads: New testcase.
+
 2019-08-20  Bob Duff  <duff@adacore.com>
 
        * gnat.dg/unchecked_convert14.adb: New testcase.

diff --git a/gcc/testsuite/gnat.dg/type_conv2.adb b/gcc/testsuite/gnat.dg/type_conv2.adb
new file mode 100644 (file)
index 0000000..d1818c6
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/type_conv2.adb
@@ -0,0 +1,16 @@
+--  { dg-do compile }
+
+package body Type_Conv2 is
+
+   function Wrap (X : Integer) return Root'Class is
+   begin
+      return Der_I'(X => X);
+   end Wrap;
+
+   procedure Proc_Static is
+      D : constant Der_I := Der_I (Wrap (0));  --  { dg-error "initialization of limited object requires aggregate or function call" }
+   begin
+      null;
+   end Proc_Static;
+
+end Type_Conv2;

diff --git a/gcc/testsuite/gnat.dg/type_conv2.ads b/gcc/testsuite/gnat.dg/type_conv2.ads
new file mode 100644 (file)
index 0000000..b9ddeb2
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/type_conv2.ads
@@ -0,0 +1,13 @@
+package Type_Conv2 is
+
+   type Root is abstract tagged limited null record;
+
+   type Der_I is new Root with record
+      X : Integer;
+   end record;
+
+   function Wrap (X : Integer) return Root'Class;
+
+   procedure Proc_Static;
+
+end Type_Conv2;