[Ada] ACATS 4.1G - C760A02 - Near infinite finalization

2020-06-19  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* exp_ch3.ads (Ensure_Activation_Chain_And_Master): New
	subprogram.
	* exp_ch3.adb (Ensure_Activation_Chain_And_Master): New
	subprogram that factorizes code.
	(Expand_N_Object_Declaration): Call new subprogram.
	* sem_ch6.adb (Analyze_Function_Return): Returning a
	build-in-place unconstrained array type defer the full analysis
	of the returned object to avoid generating the corresponding
	constrained subtype; otherwise the bounds would be created in
	the stack and a dangling reference would be returned pointing to
	the bounds.

3 files changed, 77 insertions, 30 deletions

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index f89e070..7d84732 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -4764,6 +4764,47 @@ package body Exp_Ch3 is
       end if;
    end Clean_Task_Names;
 
+   ----------------------------------------
+   -- Ensure_Activation_Chain_And_Master --
+   ----------------------------------------
+
+   procedure Ensure_Activation_Chain_And_Master (Obj_Decl : Node_Id) is
+      Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
+      Expr   : constant Node_Id   := Expression (Obj_Decl);
+      Expr_Q : Node_Id;
+      Typ    : constant Entity_Id := Etype (Def_Id);
+
+   begin
+      pragma Assert (Nkind (Obj_Decl) = N_Object_Declaration);
+
+      if Has_Task (Typ) or else Might_Have_Tasks (Typ) then
+         Build_Activation_Chain_Entity (Obj_Decl);
+
+         if Has_Task (Typ) then
+            Build_Master_Entity (Def_Id);
+
+         --  Handle objects initialized with BIP function calls
+
+         elsif Present (Expr) then
+            if Nkind (Expr) = N_Qualified_Expression then
+               Expr_Q := Expression (Expr);
+            else
+               Expr_Q := Expr;
+            end if;
+
+            if Is_Build_In_Place_Function_Call (Expr_Q)
+              or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
+              or else
+                (Nkind (Expr_Q) = N_Reference
+                   and then
+                 Is_Build_In_Place_Function_Call (Prefix (Expr_Q)))
+            then
+               Build_Master_Entity (Def_Id);
+            end if;
+         end if;
+      end if;
+   end Ensure_Activation_Chain_And_Master;
+
    ------------------------------
    -- Expand_Freeze_Array_Type --
    ------------------------------
@@ -6743,35 +6784,7 @@ package body Exp_Ch3 is
       --  also that a Master variable is established (and that the appropriate
       --  enclosing construct is established as a task master).
 
-      if Has_Task (Typ) or else Might_Have_Tasks (Typ) then
-         Build_Activation_Chain_Entity (N);
-
-         if Has_Task (Typ) then
-            Build_Master_Entity (Def_Id);
-
-         --  Handle objects initialized with BIP function calls
-
-         elsif Present (Expr) then
-            declare
-               Expr_Q : Node_Id := Expr;
-
-            begin
-               if Nkind (Expr) = N_Qualified_Expression then
-                  Expr_Q := Expression (Expr);
-               end if;
-
-               if Is_Build_In_Place_Function_Call (Expr_Q)
-                 or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
-                 or else
-                   (Nkind (Expr_Q) = N_Reference
-                      and then
-                    Is_Build_In_Place_Function_Call (Prefix (Expr_Q)))
-               then
-                  Build_Master_Entity (Def_Id);
-               end if;
-            end;
-         end if;
-      end if;
+      Ensure_Activation_Chain_And_Master (N);
 
       --  If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations
       --  restrictions are active then default-sized secondary stacks are
diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads
index fcbe83b..954b5a2 100644
--- a/gcc/ada/exp_ch3.ads
+++ b/gcc/ada/exp_ch3.ads
@@ -101,6 +101,13 @@ package Exp_Ch3 is
    --  Build the body of the equality function Body_Id for the untagged variant
    --  record Typ with the given parameters specification list.
 
+   procedure Ensure_Activation_Chain_And_Master (Obj_Decl : Node_Id);
+   --  If tasks are being declared (or might be declared) by the given object
+   --  declaration then ensure to have an activation chain defined for the
+   --  tasks (has no effect if we already have one), and also that a Master
+   --  variable is established (and that the appropriate enclosing construct
+   --  is established as a task master).
+
    function Freeze_Type (N : Node_Id) return Boolean;
    --  This function executes the freezing actions associated with the given
    --  freeze type node N and returns True if the node is to be deleted. We
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 96099e7..59cbccd 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -32,6 +32,7 @@ with Einfo;     use Einfo;
 with Elists;    use Elists;
 with Errout;    use Errout;
 with Expander;  use Expander;
+with Exp_Ch3;   use Exp_Ch3;
 with Exp_Ch6;   use Exp_Ch6;
 with Exp_Ch7;   use Exp_Ch7;
 with Exp_Ch9;   use Exp_Ch9;
@@ -1194,7 +1195,33 @@ package body Sem_Ch6 is
             --  object declaration.
 
             Set_Is_Return_Object (Defining_Identifier (Obj_Decl));
-            Analyze (Obj_Decl);
+
+            --  Returning a build-in-place unconstrained array type we defer
+            --  the full analysis of the returned object to avoid generating
+            --  the corresponding constrained subtype; otherwise the bounds
+            --  would be created in the stack and a dangling reference would
+            --  be returned pointing to the bounds. We perform its preanalysis
+            --  to report errors on the initializing aggregate now (if any);
+            --  we also ensure its activation chain and Master variable are
+            --  defined (if tasks are being declared) since they are generated
+            --  as part of the analysis and expansion of the object declaration
+            --  at this stage.
+
+            if Is_Array_Type (R_Type)
+              and then not Is_Constrained (R_Type)
+              and then Is_Build_In_Place_Function (Scope_Id)
+              and then Needs_BIP_Alloc_Form (Scope_Id)
+              and then Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate)
+            then
+               Preanalyze (Obj_Decl);
+
+               if Expander_Active then
+                  Ensure_Activation_Chain_And_Master (Obj_Decl);
+               end if;
+
+            else
+               Analyze (Obj_Decl);
+            end if;
 
             Check_Return_Subtype_Indication (Obj_Decl);