From 76e0721abb9283c9127921850bee619f354701c9 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Sat, 7 Mar 2020 10:05:11 -0500 Subject: [PATCH] [Ada] Ada 202x AI12-0192 "requires late initialization" 2020-06-10 Arnaud Charlet gcc/ada/ * exp_ch3.adb (Build_Init_Statements): Implement the notion of "require late initialization". --- gcc/ada/exp_ch3.adb | 206 ++++++++++++++++++++++++++++++++++++++------ 1 file changed, 182 insertions(+), 24 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index cf53100b078..76b62019778 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 -- 2.30.2