[Ada] Ada 202x AI12-0192 "requires late initialization"

2020-06-10  Arnaud Charlet  <charlet@adacore.com>

gcc/ada/

	* exp_ch3.adb (Build_Init_Statements): Implement the notion of
	"require late initialization".

1 files changed, 182 insertions, 24 deletions

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index cf53100..76b6201 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -2826,16 +2826,16 @@ package body Exp_Ch3 is
       ---------------------------
 
       function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
-         Checks       : constant List_Id := New_List;
-         Actions      : List_Id          := No_List;
-         Counter_Id   : Entity_Id        := Empty;
-         Comp_Loc     : Source_Ptr;
-         Decl         : Node_Id;
-         Has_POC      : Boolean;
-         Id           : Entity_Id;
-         Parent_Stmts : List_Id;
-         Stmts        : List_Id;
-         Typ          : Entity_Id;
+         Checks             : constant List_Id := New_List;
+         Actions            : List_Id          := No_List;
+         Counter_Id         : Entity_Id        := Empty;
+         Comp_Loc           : Source_Ptr;
+         Decl               : Node_Id;
+         Has_Late_Init_Comp : Boolean;
+         Id                 : Entity_Id;
+         Parent_Stmts       : List_Id;
+         Stmts              : List_Id;
+         Typ                : Entity_Id;
 
          procedure Increment_Counter (Loc : Source_Ptr);
          --  Generate an "increment by one" statement for the current counter
@@ -2846,6 +2846,12 @@ package body Exp_Ch3 is
          --  creates a new defining Id, adds an object declaration and sets
          --  the Id generator for the next variant.
 
+         function Requires_Late_Initialization
+           (Decl     : Node_Id;
+            Rec_Type : Entity_Id) return Boolean;
+         --  Return whether the given Decl requires late initialization, as
+         --  defined by 3.3.1 (8.1/5).
+
          -----------------------
          -- Increment_Counter --
          -----------------------
@@ -2892,6 +2898,158 @@ package body Exp_Ch3 is
                   Make_Integer_Literal (Loc, 0)));
          end Make_Counter;
 
+         ----------------------------------
+         -- Requires_Late_Initialization --
+         ----------------------------------
+
+         function Requires_Late_Initialization
+           (Decl     : Node_Id;
+            Rec_Type : Entity_Id) return Boolean
+         is
+            References_Current_Instance : Boolean := False;
+            Has_Access_Discriminant     : Boolean := False;
+            Has_Internal_Call           : Boolean := False;
+
+            function Find_Access_Discriminant
+              (N : Node_Id) return Traverse_Result;
+            --  Look for a name denoting an access discriminant
+
+            function Find_Current_Instance
+              (N : Node_Id) return Traverse_Result;
+            --  Look for a reference to the current instance of the type
+
+            function Find_Internal_Call
+              (N : Node_Id) return Traverse_Result;
+            --  Look for an internal protected function call
+
+            ------------------------------
+            -- Find_Access_Discriminant --
+            ------------------------------
+
+            function Find_Access_Discriminant
+              (N : Node_Id) return Traverse_Result is
+            begin
+               if Is_Entity_Name (N)
+                 and then Denotes_Discriminant (N)
+                 and then Is_Access_Type (Etype (N))
+               then
+                  Has_Access_Discriminant := True;
+                  return Abandon;
+               else
+                  return OK;
+               end if;
+            end Find_Access_Discriminant;
+
+            ---------------------------
+            -- Find_Current_Instance --
+            ---------------------------
+
+            function Find_Current_Instance
+              (N : Node_Id) return Traverse_Result is
+            begin
+               if Nkind (N) = N_Attribute_Reference
+                 and then Is_Access_Type (Etype (N))
+                 and then Is_Entity_Name (Prefix (N))
+                 and then Is_Type (Entity (Prefix (N)))
+               then
+                  References_Current_Instance := True;
+                  return Abandon;
+               else
+                  return OK;
+               end if;
+            end Find_Current_Instance;
+
+            ------------------------
+            -- Find_Internal_Call --
+            ------------------------
+
+            function Find_Internal_Call (N : Node_Id) return Traverse_Result is
+
+               function Call_Scope (N : Node_Id) return Entity_Id;
+               --  Return the scope enclosing a given call node N
+
+               ----------------
+               -- Call_Scope --
+               ----------------
+
+               function Call_Scope (N : Node_Id) return Entity_Id is
+                  Nam : constant Node_Id := Name (N);
+               begin
+                  if Nkind (Nam) = N_Selected_Component then
+                     return Scope (Entity (Prefix (Nam)));
+                  else
+                     return Scope (Entity (Nam));
+                  end if;
+               end Call_Scope;
+
+            begin
+               if Nkind (N) = N_Function_Call
+                 and then Call_Scope (N)
+                            = Corresponding_Concurrent_Type (Rec_Type)
+               then
+                  Has_Internal_Call := True;
+                  return Abandon;
+               else
+                  return OK;
+               end if;
+            end Find_Internal_Call;
+
+            procedure Search_Access_Discriminant is new
+              Traverse_Proc (Find_Access_Discriminant);
+
+            procedure Search_Current_Instance is new
+              Traverse_Proc (Find_Current_Instance);
+
+            procedure Search_Internal_Call is new
+              Traverse_Proc (Find_Internal_Call);
+
+         begin
+            --  A component of an object is said to require late initialization
+            --  if:
+
+            --  it has an access discriminant value constrained by a per-object
+            --  expression;
+
+            if Has_Access_Constraint (Defining_Identifier (Decl))
+              and then No (Expression (Decl))
+            then
+               return True;
+
+            elsif Present (Expression (Decl)) then
+
+               --  it has an initialization expression that includes a name
+               --  denoting an access discriminant;
+
+               Search_Access_Discriminant (Expression (Decl));
+
+               if Has_Access_Discriminant then
+                  return True;
+               end if;
+
+               --  or it has an initialization expression that includes a
+               --  reference to the current instance of the type either by
+               --  name...
+
+               Search_Current_Instance (Expression (Decl));
+
+               if References_Current_Instance then
+                  return True;
+               end if;
+
+               --  ...or implicitly as the target object of a call.
+
+               if Is_Protected_Record_Type (Rec_Type) then
+                  Search_Internal_Call (Expression (Decl));
+
+                  if Has_Internal_Call then
+                     return True;
+                  end if;
+               end if;
+            end if;
+
+            return False;
+         end Requires_Late_Initialization;
+
       --  Start of processing for Build_Init_Statements
 
       begin
@@ -2945,10 +3103,9 @@ package body Exp_Ch3 is
 
          --  Loop through components, skipping pragmas, in 2 steps. The first
          --  step deals with regular components. The second step deals with
-         --  components that have per object constraints and no explicit
-         --  initialization.
+         --  components that require late initialization.
 
-         Has_POC := False;
+         Has_Late_Init_Comp := False;
 
          --  First pass : regular components
 
@@ -2961,11 +3118,11 @@ package body Exp_Ch3 is
             Id  := Defining_Identifier (Decl);
             Typ := Etype (Id);
 
-            --  Leave any processing of per-object constrained component for
-            --  the second pass.
+            --  Leave any processing of component requiring late initialization
+            --  for the second pass.
 
-            if Has_Access_Constraint (Id) and then No (Expression (Decl)) then
-               Has_POC := True;
+            if Requires_Late_Initialization (Decl, Rec_Type) then
+               Has_Late_Init_Comp := True;
 
             --  Regular component cases
 
@@ -3267,19 +3424,21 @@ package body Exp_Ch3 is
               Make_Initialize_Protection (Rec_Type));
          end if;
 
-         --  Second pass: components with per-object constraints
+         --  Second pass: components that require late initialization
 
-         if Has_POC then
+         if Has_Late_Init_Comp then
             Decl := First_Non_Pragma (Component_Items (Comp_List));
             while Present (Decl) loop
                Comp_Loc := Sloc (Decl);
                Id := Defining_Identifier (Decl);
                Typ := Etype (Id);
 
-               if Has_Access_Constraint (Id)
-                 and then No (Expression (Decl))
-               then
-                  if Has_Non_Null_Base_Init_Proc (Typ) then
+               if Requires_Late_Initialization (Decl, Rec_Type) then
+                  if Present (Expression (Decl)) then
+                     Append_List_To (Stmts,
+                       Build_Assignment (Id, Expression (Decl)));
+
+                  elsif Has_Non_Null_Base_Init_Proc (Typ) then
                      Append_List_To (Stmts,
                        Build_Initialization_Call (Comp_Loc,
                          Make_Selected_Component (Comp_Loc,
@@ -3302,7 +3461,6 @@ package body Exp_Ch3 is
 
                         Increment_Counter (Comp_Loc);
                      end if;
-
                   elsif Component_Needs_Simple_Initialization (Typ) then
                      Append_List_To (Stmts,
                        Build_Assignment