Working on this AI it appeared that GNAT wasn't implementing the Ada
2012 notion of "require late initialization", so plug this hole and
implement the new rule from AI12-0192 at the same time.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-10 Arnaud Charlet <char...@adacore.com>
gcc/ada/
* exp_ch3.adb (Build_Init_Statements): Implement the notion of
"require late initialization".--- gcc/ada/exp_ch3.adb
+++ 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
