diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 1000 |
1 files changed, 360 insertions, 640 deletions
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 270d3bb..e5b2ced 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -105,6 +105,36 @@ package body Exp_Aggr is -- N is an aggregate (record or array). Checks the presence of default -- initialization (<>) in any component (Ada 2005: AI-287). + procedure Initialize_Component + (N : Node_Id; + Comp : Node_Id; + Comp_Typ : Entity_Id; + Init_Expr : Node_Id; + Stmts : List_Id); + -- Perform the initialization of component Comp with expected type Comp_Typ + -- of aggregate N. Init_Expr denotes the initialization expression of the + -- component. All generated code is added to Stmts. + + procedure Initialize_Controlled_Component + (N : Node_Id; + Comp : Node_Id; + Comp_Typ : Entity_Id; + Init_Expr : Node_Id; + Stmts : List_Id); + -- Perform the initialization of controlled component Comp with expected + -- type Comp_Typ of aggregate N. Init_Expr denotes the initialization + -- expression of the component. All generated code is added to Stmts. + + procedure Initialize_Simple_Component + (N : Node_Id; + Comp : Node_Id; + Comp_Typ : Node_Id; + Init_Expr : Node_Id; + Stmts : List_Id); + -- Perform the initialization of simple component Comp with expected + -- type Comp_Typ of aggregate N. Init_Expr denotes the initialization + -- expression of the component. All generated code is added to Stmts. + function Is_CCG_Supported_Aggregate (N : Node_Id) return Boolean; -- Return True if aggregate N is located in a context supported by the -- CCG backend; False otherwise. @@ -1081,16 +1111,14 @@ package body Exp_Aggr is function Gen_Assign (Ind : Node_Id; - Expr : Node_Id; - In_Loop : Boolean := False) return List_Id; + Expr : Node_Id) return List_Id; -- Ind must be a side-effect-free expression. If the input aggregate N -- to Build_Loop contains no subaggregates, then this function returns -- the assignment statement: -- -- Into (Indexes, Ind) := Expr; -- - -- Otherwise we call Build_Code recursively. Flag In_Loop should be set - -- when the assignment appears within a generated loop. + -- Otherwise we call Build_Code recursively. -- -- Ada 2005 (AI-287): In case of default initialized component, Expr -- is empty and we generate a call to the corresponding IP subprogram. @@ -1310,35 +1338,13 @@ package body Exp_Aggr is function Gen_Assign (Ind : Node_Id; - Expr : Node_Id; - In_Loop : Boolean := False) return List_Id + Expr : Node_Id) return List_Id is function Add_Loop_Actions (Lis : List_Id) return List_Id; -- Collect insert_actions generated in the construction of a loop, -- and prepend them to the sequence of assignments to complete the -- eventual body of the loop. - procedure Initialize_Array_Component - (Arr_Comp : Node_Id; - Comp_Typ : Node_Id; - Init_Expr : Node_Id; - Stmts : List_Id); - -- Perform the initialization of array component Arr_Comp with - -- expected type Comp_Typ. Init_Expr denotes the initialization - -- expression of the array component. All generated code is added - -- to list Stmts. - - procedure Initialize_Ctrl_Array_Component - (Arr_Comp : Node_Id; - Comp_Typ : Entity_Id; - Init_Expr : Node_Id; - Stmts : List_Id); - -- Perform the initialization of array component Arr_Comp when its - -- expected type Comp_Typ needs finalization actions. Init_Expr is - -- the initialization expression of the array component. All hook- - -- related declarations are inserted prior to aggregate N. Remaining - -- code is added to list Stmts. - ---------------------- -- Add_Loop_Actions -- ---------------------- @@ -1366,263 +1372,6 @@ package body Exp_Aggr is end if; end Add_Loop_Actions; - -------------------------------- - -- Initialize_Array_Component -- - -------------------------------- - - procedure Initialize_Array_Component - (Arr_Comp : Node_Id; - Comp_Typ : Node_Id; - Init_Expr : Node_Id; - Stmts : List_Id) - is - Exceptions_OK : constant Boolean := - not Restriction_Active - (No_Exception_Propagation); - - Finalization_OK : constant Boolean := - Present (Comp_Typ) - and then Needs_Finalization (Comp_Typ); - - Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ); - Adj_Call : Node_Id; - Blk_Stmts : List_Id; - Init_Stmt : Node_Id; - - begin - -- Protect the initialization statements from aborts. Generate: - - -- Abort_Defer; - - if Finalization_OK and Abort_Allowed then - if Exceptions_OK then - Blk_Stmts := New_List; - else - Blk_Stmts := Stmts; - end if; - - Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); - - -- Otherwise aborts are not allowed. All generated code is added - -- directly to the input list. - - else - Blk_Stmts := Stmts; - end if; - - -- Initialize the array element. Generate: - - -- Arr_Comp := Init_Expr; - - -- Note that the initialization expression is replicated because - -- it has to be reevaluated within a generated loop. - - Init_Stmt := - Make_OK_Assignment_Statement (Loc, - Name => New_Copy_Tree (Arr_Comp), - Expression => New_Copy_Tree (Init_Expr)); - Set_No_Ctrl_Actions (Init_Stmt); - - Append_To (Blk_Stmts, Init_Stmt); - - -- Adjust the tag due to a possible view conversion. Generate: - - -- Arr_Comp._tag := Full_TypP; - - if Tagged_Type_Expansion - and then Present (Comp_Typ) - and then Is_Tagged_Type (Comp_Typ) - then - Append_To (Blk_Stmts, - Make_OK_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Arr_Comp), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Full_Typ), Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Full_Typ))), - Loc)))); - end if; - - -- Adjust the array component. Controlled subaggregates are not - -- considered because each of their individual elements will - -- receive an adjustment of its own. Generate: - - -- [Deep_]Adjust (Arr_Comp); - - if Finalization_OK - and then not Is_Limited_Type (Comp_Typ) - and then not Is_Build_In_Place_Function_Call (Init_Expr) - and then not - (Is_Array_Type (Comp_Typ) - and then Needs_Finalization (Component_Type (Comp_Typ)) - and then Nkind (Unqualify (Init_Expr)) = N_Aggregate) - then - Adj_Call := - Make_Adjust_Call - (Obj_Ref => New_Copy_Tree (Arr_Comp), - Typ => Comp_Typ); - - -- Guard against a missing [Deep_]Adjust when the component - -- type was not frozen properly. - - if Present (Adj_Call) then - Append_To (Blk_Stmts, Adj_Call); - end if; - end if; - - -- Complete the protection of the initialization statements - - if Finalization_OK and Abort_Allowed then - - -- Wrap the initialization statements in a block to catch a - -- potential exception. Generate: - - -- begin - -- Abort_Defer; - -- Arr_Comp := Init_Expr; - -- Arr_Comp._tag := Full_TypP; - -- [Deep_]Adjust (Arr_Comp); - -- at end - -- Abort_Undefer_Direct; - -- end; - - if Exceptions_OK then - Append_To (Stmts, - Build_Abort_Undefer_Block (Loc, - Stmts => Blk_Stmts, - Context => N)); - - -- Otherwise exceptions are not propagated. Generate: - - -- Abort_Defer; - -- Arr_Comp := Init_Expr; - -- Arr_Comp._tag := Full_TypP; - -- [Deep_]Adjust (Arr_Comp); - -- Abort_Undefer; - - else - Append_To (Blk_Stmts, - Build_Runtime_Call (Loc, RE_Abort_Undefer)); - end if; - end if; - end Initialize_Array_Component; - - ------------------------------------- - -- Initialize_Ctrl_Array_Component -- - ------------------------------------- - - procedure Initialize_Ctrl_Array_Component - (Arr_Comp : Node_Id; - Comp_Typ : Entity_Id; - Init_Expr : Node_Id; - Stmts : List_Id) - is - Init_Expr_Q : constant Node_Id := Unqualify (Init_Expr); - - Act_Aggr : Node_Id; - Act_Stmts : List_Id; - Fin_Call : Node_Id; - Hook_Clear : Node_Id; - - In_Place_Expansion : Boolean; - -- Flag set when a nonlimited controlled function call requires - -- in-place expansion. - - begin - -- Perform a preliminary analysis and resolution to determine what - -- the initialization expression denotes. An unanalyzed function - -- call may appear as an identifier or an indexed component. - - if Nkind (Init_Expr_Q) in N_Function_Call - | N_Identifier - | N_Indexed_Component - and then not Analyzed (Init_Expr) - then - Preanalyze_And_Resolve (Init_Expr, Comp_Typ); - end if; - - In_Place_Expansion := - Nkind (Init_Expr_Q) = N_Function_Call - and then not Is_Build_In_Place_Result_Type (Comp_Typ); - - -- The initialization expression is a controlled function call. - -- Perform in-place removal of side effects to avoid creating a - -- transient scope, which leads to premature finalization. - - -- This in-place expansion is not performed for limited transient - -- objects, because the initialization is already done in place. - - if In_Place_Expansion then - - -- Suppress the removal of side effects by general analysis, - -- because this behavior is emulated here. This avoids the - -- generation of a transient scope, which leads to out-of-order - -- adjustment and finalization. - - Set_No_Side_Effect_Removal (Init_Expr); - - -- When the transient component initialization is related to a - -- range or an "others", keep all generated statements within - -- the enclosing loop. This way the controlled function call - -- will be evaluated at each iteration, and its result will be - -- finalized at the end of each iteration. - - if In_Loop then - Act_Aggr := Empty; - Act_Stmts := Stmts; - - -- Otherwise this is a single component initialization. Hook- - -- related statements are inserted prior to the aggregate. - - else - Act_Aggr := N; - Act_Stmts := No_List; - end if; - - -- Install all hook-related declarations and prepare the clean - -- up statements. - - Process_Transient_Component - (Loc => Loc, - Comp_Typ => Comp_Typ, - Init_Expr => Init_Expr, - Fin_Call => Fin_Call, - Hook_Clear => Hook_Clear, - Aggr => Act_Aggr, - Stmts => Act_Stmts); - end if; - - -- Use the noncontrolled component initialization circuitry to - -- assign the result of the function call to the array element. - -- This also performs subaggregate wrapping, tag adjustment, and - -- [deep] adjustment of the array element. - - Initialize_Array_Component - (Arr_Comp => Arr_Comp, - Comp_Typ => Comp_Typ, - Init_Expr => Init_Expr, - Stmts => Stmts); - - -- At this point the array element is fully initialized. Complete - -- the processing of the controlled array component by finalizing - -- the transient function result. - - if In_Place_Expansion then - Process_Transient_Component_Completion - (Loc => Loc, - Aggr => N, - Fin_Call => Fin_Call, - Hook_Clear => Hook_Clear, - Stmts => Stmts); - end if; - end Initialize_Ctrl_Array_Component; - -- Local variables Stmts : constant List_Id := New_List; @@ -1768,57 +1517,12 @@ package body Exp_Aggr is end if; if Present (Expr) then - - -- Handle an initialization expression of a controlled type in - -- case it denotes a function call. In general such a scenario - -- will produce a transient scope, but this will lead to wrong - -- order of initialization, adjustment, and finalization in the - -- context of aggregates. - - -- Target (1) := Ctrl_Func_Call; - - -- begin -- scope - -- Trans_Obj : ... := Ctrl_Func_Call; -- object - -- Target (1) := Trans_Obj; - -- Finalize (Trans_Obj); - -- end; - -- Target (1)._tag := ...; - -- Adjust (Target (1)); - - -- In the example above, the call to Finalize occurs too early - -- and as a result it may leave the array component in a bad - -- state. Finalization of the transient object should really - -- happen after adjustment. - - -- To avoid this scenario, perform in-place side-effect removal - -- of the function call. This eliminates the transient property - -- of the function result and ensures correct order of actions. - - -- Res : ... := Ctrl_Func_Call; - -- Target (1) := Res; - -- Target (1)._tag := ...; - -- Adjust (Target (1)); - -- Finalize (Res); - - if Present (Comp_Typ) - and then Needs_Finalization (Comp_Typ) - and then Nkind (Expr_Q) /= N_Aggregate - then - Initialize_Ctrl_Array_Component - (Arr_Comp => Indexed_Comp, - Comp_Typ => Comp_Typ, - Init_Expr => Expr, - Stmts => Stmts); - - -- Otherwise perform simple component initialization - - else - Initialize_Array_Component - (Arr_Comp => Indexed_Comp, - Comp_Typ => Comp_Typ, - Init_Expr => Expr, - Stmts => Stmts); - end if; + Initialize_Component + (N => N, + Comp => Indexed_Comp, + Comp_Typ => Comp_Typ, + Init_Expr => Expr, + Stmts => Stmts); -- Ada 2005 (AI-287): In case of default initialized component, call -- the initialization subprogram associated with the component type. @@ -2070,8 +1774,7 @@ package body Exp_Aggr is -- Construct the statements to execute in the loop body - L_Body := - Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr, In_Loop => True); + L_Body := Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr); -- Construct the final loop @@ -2184,7 +1887,7 @@ package body Exp_Aggr is Append_To (W_Body, W_Increment); Append_List_To (W_Body, - Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr, In_Loop => True)); + Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr)); -- Construct the final loop @@ -2606,26 +2309,6 @@ package body Exp_Aggr is -- The type of the aggregate is a subtype created ealier using the -- given values of the discriminant components of the aggregate. - procedure Initialize_Ctrl_Record_Component - (Rec_Comp : Node_Id; - Comp_Typ : Entity_Id; - Init_Expr : Node_Id; - Stmts : List_Id); - -- Perform the initialization of controlled record component Rec_Comp. - -- Comp_Typ is the component type. Init_Expr is the initialization - -- expression for the record component. Hook-related declarations are - -- inserted prior to aggregate N using Insert_Action. All remaining - -- generated code is added to list Stmts. - - procedure Initialize_Record_Component - (Rec_Comp : Node_Id; - Comp_Typ : Entity_Id; - Init_Expr : Node_Id; - Stmts : List_Id); - -- Perform the initialization of record component Rec_Comp. Comp_Typ - -- is the component type. Init_Expr is the initialization expression - -- of the record component. All generated code is added to list Stmts. - function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean; -- Check whether Bounds is a range node and its lower and higher bounds -- are integers literals. @@ -3119,236 +2802,6 @@ package body Exp_Aggr is end loop; end Init_Stored_Discriminants; - -------------------------------------- - -- Initialize_Ctrl_Record_Component -- - -------------------------------------- - - procedure Initialize_Ctrl_Record_Component - (Rec_Comp : Node_Id; - Comp_Typ : Entity_Id; - Init_Expr : Node_Id; - Stmts : List_Id) - is - Init_Expr_Q : constant Node_Id := Unqualify (Init_Expr); - - Fin_Call : Node_Id; - Hook_Clear : Node_Id; - - In_Place_Expansion : Boolean; - -- Flag set when a nonlimited controlled function call requires - -- in-place expansion. - - begin - -- Perform a preliminary analysis and resolution to determine what - -- the initialization expression denotes. Unanalyzed function calls - -- may appear as identifiers or indexed components. - - if Nkind (Init_Expr_Q) in N_Function_Call - | N_Identifier - | N_Indexed_Component - and then not Analyzed (Init_Expr) - then - Preanalyze_And_Resolve (Init_Expr, Comp_Typ); - end if; - - In_Place_Expansion := - Nkind (Init_Expr_Q) = N_Function_Call - and then not Is_Build_In_Place_Result_Type (Comp_Typ); - - -- The initialization expression is a controlled function call. - -- Perform in-place removal of side effects to avoid creating a - -- transient scope. - - -- This in-place expansion is not performed for limited transient - -- objects because the initialization is already done in place. - - if In_Place_Expansion then - - -- Suppress the removal of side effects by general analysis - -- because this behavior is emulated here. This avoids the - -- generation of a transient scope, which leads to out-of-order - -- adjustment and finalization. - - Set_No_Side_Effect_Removal (Init_Expr); - - -- Install all hook-related declarations and prepare the clean up - -- statements. The generated code follows the initialization order - -- of individual components and discriminants, rather than being - -- inserted prior to the aggregate. This ensures that a transient - -- component which mentions a discriminant has proper visibility - -- of the discriminant. - - Process_Transient_Component - (Loc => Loc, - Comp_Typ => Comp_Typ, - Init_Expr => Init_Expr, - Fin_Call => Fin_Call, - Hook_Clear => Hook_Clear, - Stmts => Stmts); - end if; - - -- Use the noncontrolled component initialization circuitry to - -- assign the result of the function call to the record component. - -- This also performs tag adjustment and [deep] adjustment of the - -- record component. - - Initialize_Record_Component - (Rec_Comp => Rec_Comp, - Comp_Typ => Comp_Typ, - Init_Expr => Init_Expr, - Stmts => Stmts); - - -- At this point the record component is fully initialized. Complete - -- the processing of the controlled record component by finalizing - -- the transient function result. - - if In_Place_Expansion then - Process_Transient_Component_Completion - (Loc => Loc, - Aggr => N, - Fin_Call => Fin_Call, - Hook_Clear => Hook_Clear, - Stmts => Stmts); - end if; - end Initialize_Ctrl_Record_Component; - - --------------------------------- - -- Initialize_Record_Component -- - --------------------------------- - - procedure Initialize_Record_Component - (Rec_Comp : Node_Id; - Comp_Typ : Entity_Id; - Init_Expr : Node_Id; - Stmts : List_Id) - is - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); - - Finalization_OK : constant Boolean := Needs_Finalization (Comp_Typ); - - Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ); - Adj_Call : Node_Id; - Blk_Stmts : List_Id; - Init_Stmt : Node_Id; - - begin - pragma Assert (Nkind (Init_Expr) in N_Subexpr); - - -- Protect the initialization statements from aborts. Generate: - - -- Abort_Defer; - - if Finalization_OK and Abort_Allowed then - if Exceptions_OK then - Blk_Stmts := New_List; - else - Blk_Stmts := Stmts; - end if; - - Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); - - -- Otherwise aborts are not allowed. All generated code is added - -- directly to the input list. - - else - Blk_Stmts := Stmts; - end if; - - -- Initialize the record component. Generate: - - -- Rec_Comp := Init_Expr; - - -- Note that the initialization expression is NOT replicated because - -- only a single component may be initialized by it. - - Init_Stmt := - Make_OK_Assignment_Statement (Loc, - Name => New_Copy_Tree (Rec_Comp), - Expression => Init_Expr); - Set_No_Ctrl_Actions (Init_Stmt); - - Append_To (Blk_Stmts, Init_Stmt); - - -- Adjust the tag due to a possible view conversion. Generate: - - -- Rec_Comp._tag := Full_TypeP; - - if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then - Append_To (Blk_Stmts, - Make_OK_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Rec_Comp), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Full_Typ), Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Full_Typ))), - Loc)))); - end if; - - -- Adjust the component. Generate: - - -- [Deep_]Adjust (Rec_Comp); - - if Finalization_OK - and then not Is_Limited_Type (Comp_Typ) - and then not Is_Build_In_Place_Function_Call (Init_Expr) - then - Adj_Call := - Make_Adjust_Call - (Obj_Ref => New_Copy_Tree (Rec_Comp), - Typ => Comp_Typ); - - -- Guard against a missing [Deep_]Adjust when the component type - -- was not properly frozen. - - if Present (Adj_Call) then - Append_To (Blk_Stmts, Adj_Call); - end if; - end if; - - -- Complete the protection of the initialization statements - - if Finalization_OK and Abort_Allowed then - - -- Wrap the initialization statements in a block to catch a - -- potential exception. Generate: - - -- begin - -- Abort_Defer; - -- Rec_Comp := Init_Expr; - -- Rec_Comp._tag := Full_TypP; - -- [Deep_]Adjust (Rec_Comp); - -- at end - -- Abort_Undefer_Direct; - -- end; - - if Exceptions_OK then - Append_To (Stmts, - Build_Abort_Undefer_Block (Loc, - Stmts => Blk_Stmts, - Context => N)); - - -- Otherwise exceptions are not propagated. Generate: - - -- Abort_Defer; - -- Rec_Comp := Init_Expr; - -- Rec_Comp._tag := Full_TypP; - -- [Deep_]Adjust (Rec_Comp); - -- Abort_Undefer; - - else - Append_To (Blk_Stmts, - Build_Runtime_Call (Loc, RE_Abort_Undefer)); - end if; - end if; - end Initialize_Record_Component; - ------------------------- -- Is_Int_Range_Bounds -- ------------------------- @@ -3828,8 +3281,9 @@ package body Exp_Aggr is Prefix => New_Copy_Tree (Target), Selector_Name => New_Occurrence_Of (Selector, Loc)); - Initialize_Record_Component - (Rec_Comp => Comp_Expr, + Initialize_Simple_Component + (N => N, + Comp => Comp_Expr, Comp_Typ => Etype (Selector), Init_Expr => Get_Simple_Init_Val (Typ => Etype (Selector), @@ -4062,56 +3516,12 @@ package body Exp_Aggr is end; else - -- Handle an initialization expression of a controlled type - -- in case it denotes a function call. In general such a - -- scenario will produce a transient scope, but this will - -- lead to wrong order of initialization, adjustment, and - -- finalization in the context of aggregates. - - -- Target.Comp := Ctrl_Func_Call; - - -- begin -- scope - -- Trans_Obj : ... := Ctrl_Func_Call; -- object - -- Target.Comp := Trans_Obj; - -- Finalize (Trans_Obj); - -- end - -- Target.Comp._tag := ...; - -- Adjust (Target.Comp); - - -- In the example above, the call to Finalize occurs too - -- early and as a result it may leave the record component - -- in a bad state. Finalization of the transient object - -- should really happen after adjustment. - - -- To avoid this scenario, perform in-place side-effect - -- removal of the function call. This eliminates the - -- transient property of the function result and ensures - -- correct order of actions. - - -- Res : ... := Ctrl_Func_Call; - -- Target.Comp := Res; - -- Target.Comp._tag := ...; - -- Adjust (Target.Comp); - -- Finalize (Res); - - if Needs_Finalization (Comp_Type) - and then Nkind (Expr_Q) /= N_Aggregate - then - Initialize_Ctrl_Record_Component - (Rec_Comp => Comp_Expr, - Comp_Typ => Etype (Selector), - Init_Expr => Expr_Q, - Stmts => L); - - -- Otherwise perform single component initialization - - else - Initialize_Record_Component - (Rec_Comp => Comp_Expr, - Comp_Typ => Etype (Selector), - Init_Expr => Expr_Q, - Stmts => L); - end if; + Initialize_Component + (N => N, + Comp => Comp_Expr, + Comp_Typ => Etype (Selector), + Init_Expr => Expr_Q, + Stmts => L); end if; end if; @@ -9025,6 +8435,316 @@ package body Exp_Aggr is return False; end Has_Default_Init_Comps; + -------------------------- + -- Initialize_Component -- + -------------------------- + + procedure Initialize_Component + (N : Node_Id; + Comp : Node_Id; + Comp_Typ : Entity_Id; + Init_Expr : Node_Id; + Stmts : List_Id) is + begin + -- Handle an initialization expression of a controlled type in + -- case it denotes a function call. In general such a scenario + -- will produce a transient scope, but this will lead to wrong + -- order of initialization, adjustment, and finalization in the + -- context of aggregates. + + -- Comp := Ctrl_Func_Call; + + -- begin -- scope + -- Trans_Obj : ... := Ctrl_Func_Call; -- object + -- Comp := Trans_Obj; + -- Finalize (Trans_Obj); + -- end; + -- Comp._tag := ...; + -- Adjust (Comp (1)); + + -- In the example above, the call to Finalize occurs too early + -- and as a result it may leave the array component in a bad + -- state. Finalization of the transient object should really + -- happen after adjustment. + + -- To avoid this scenario, perform in-place side-effect removal + -- of the function call. This eliminates the transient property + -- of the function result and ensures correct order of actions. + + -- Res : ... := Ctrl_Func_Call; + -- Comp := Res; + -- Comp._tag := ...; + -- Adjust (Comp); + -- Finalize (Res); + + if Present (Comp_Typ) + and then Needs_Finalization (Comp_Typ) + and then Nkind (Unqualify (Init_Expr)) /= N_Aggregate + then + Initialize_Controlled_Component + (N => N, + Comp => Comp, + Comp_Typ => Comp_Typ, + Init_Expr => Init_Expr, + Stmts => Stmts); + + -- Otherwise perform simple component initialization + + else + Initialize_Simple_Component + (N => N, + Comp => Comp, + Comp_Typ => Comp_Typ, + Init_Expr => Init_Expr, + Stmts => Stmts); + end if; + end Initialize_Component; + + ------------------------------------- + -- Initialize_Controlled_Component -- + ------------------------------------- + + procedure Initialize_Controlled_Component + (N : Node_Id; + Comp : Node_Id; + Comp_Typ : Entity_Id; + Init_Expr : Node_Id; + Stmts : List_Id) + is + Init_Expr_Q : constant Node_Id := Unqualify (Init_Expr); + Loc : constant Source_Ptr := Sloc (N); + + Fin_Call : Node_Id; + Hook_Clear : Node_Id; + + In_Place_Expansion : Boolean; + -- Flag set when a nonlimited controlled function call requires + -- in-place expansion. + + begin + -- Perform a preliminary analysis and resolution to determine what + -- the initialization expression denotes. Unanalyzed function calls + -- may appear as identifiers or indexed components. + + if Nkind (Init_Expr_Q) in N_Function_Call + | N_Identifier + | N_Indexed_Component + and then not Analyzed (Init_Expr) + then + Preanalyze_And_Resolve (Init_Expr, Comp_Typ); + end if; + + In_Place_Expansion := + Nkind (Init_Expr_Q) = N_Function_Call + and then not Is_Build_In_Place_Result_Type (Comp_Typ); + + -- The initialization expression is a controlled function call. + -- Perform in-place removal of side effects to avoid creating a + -- transient scope. + + -- This in-place expansion is not performed for limited transient + -- objects because the initialization is already done in place. + + if In_Place_Expansion then + + -- Suppress the removal of side effects by general analysis + -- because this behavior is emulated here. This avoids the + -- generation of a transient scope, which leads to out-of-order + -- adjustment and finalization. + + Set_No_Side_Effect_Removal (Init_Expr); + + -- Install all hook-related declarations and prepare the clean up + -- statements. The generated code follows the initialization order + -- of individual components and discriminants, rather than being + -- inserted prior to the aggregate. This ensures that a transient + -- component which mentions a discriminant has proper visibility + -- of the discriminant. + + Process_Transient_Component + (Loc => Loc, + Comp_Typ => Comp_Typ, + Init_Expr => Init_Expr, + Fin_Call => Fin_Call, + Hook_Clear => Hook_Clear, + Stmts => Stmts); + end if; + + -- Use the simple component initialization circuitry to assign the + -- result of the function call to the component. This also performs + -- tag adjustment and [deep] adjustment of the component. + + Initialize_Simple_Component + (N => N, + Comp => Comp, + Comp_Typ => Comp_Typ, + Init_Expr => Init_Expr, + Stmts => Stmts); + + -- At this point the component is fully initialized. Complete the + -- processing by finalizing the transient function result. + + if In_Place_Expansion then + Process_Transient_Component_Completion + (Loc => Loc, + Aggr => N, + Fin_Call => Fin_Call, + Hook_Clear => Hook_Clear, + Stmts => Stmts); + end if; + end Initialize_Controlled_Component; + + --------------------------------- + -- Initialize_Simple_Component -- + --------------------------------- + + procedure Initialize_Simple_Component + (N : Node_Id; + Comp : Node_Id; + Comp_Typ : Node_Id; + Init_Expr : Node_Id; + Stmts : List_Id) + is + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + Finalization_OK : constant Boolean := + Present (Comp_Typ) + and then Needs_Finalization (Comp_Typ); + Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ); + Loc : constant Source_Ptr := Sloc (N); + + Adj_Call : Node_Id; + Blk_Stmts : List_Id; + Init_Stmt : Node_Id; + + begin + pragma Assert (Nkind (Init_Expr) in N_Subexpr); + + -- Protect the initialization statements from aborts. Generate: + + -- Abort_Defer; + + if Finalization_OK and Abort_Allowed then + if Exceptions_OK then + Blk_Stmts := New_List; + else + Blk_Stmts := Stmts; + end if; + + Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); + + -- Otherwise aborts are not allowed. All generated code is added + -- directly to the input list. + + else + Blk_Stmts := Stmts; + end if; + + -- Initialize the component. Generate: + + -- Comp := Init_Expr; + + -- Note that the initialization expression is not duplicated because + -- either only a single component may be initialized by it (record) + -- or it has already been duplicated if need be (array). + + Init_Stmt := + Make_OK_Assignment_Statement (Loc, + Name => New_Copy_Tree (Comp), + Expression => Relocate_Node (Init_Expr)); + Set_No_Ctrl_Actions (Init_Stmt); + + Append_To (Blk_Stmts, Init_Stmt); + + -- Adjust the tag due to a possible view conversion. Generate: + + -- Comp._tag := Full_TypeP; + + if Tagged_Type_Expansion + and then Present (Comp_Typ) + and then Is_Tagged_Type (Comp_Typ) + then + Append_To (Blk_Stmts, + Make_OK_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Comp), + Selector_Name => + New_Occurrence_Of + (First_Tag_Component (Full_Typ), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Full_Typ))), + Loc)))); + end if; + + -- Adjust the component. In the case of an array aggregate, controlled + -- subaggregates are not considered because each of their individual + -- elements will receive an adjustment of its own. Generate: + + -- [Deep_]Adjust (Comp); + + if Finalization_OK + and then not Is_Limited_Type (Comp_Typ) + and then not Is_Build_In_Place_Function_Call (Init_Expr) + and then not + (Is_Array_Type (Etype (N)) + and then Is_Array_Type (Comp_Typ) + and then Needs_Finalization (Component_Type (Comp_Typ)) + and then Nkind (Unqualify (Init_Expr)) = N_Aggregate) + then + Adj_Call := + Make_Adjust_Call + (Obj_Ref => New_Copy_Tree (Comp), + Typ => Comp_Typ); + + -- Guard against a missing [Deep_]Adjust when the component type + -- was not properly frozen. + + if Present (Adj_Call) then + Append_To (Blk_Stmts, Adj_Call); + end if; + end if; + + -- Complete the protection of the initialization statements + + if Finalization_OK and Abort_Allowed then + + -- Wrap the initialization statements in a block to catch a + -- potential exception. Generate: + + -- begin + -- Abort_Defer; + -- Comp := Init_Expr; + -- Comp._tag := Full_TypP; + -- [Deep_]Adjust (Comp); + -- at end + -- Abort_Undefer_Direct; + -- end; + + if Exceptions_OK then + Append_To (Stmts, + Build_Abort_Undefer_Block (Loc, + Stmts => Blk_Stmts, + Context => N)); + + -- Otherwise exceptions are not propagated. Generate: + + -- Abort_Defer; + -- Comp := Init_Expr; + -- Comp._tag := Full_TypP; + -- [Deep_]Adjust (Comp); + -- Abort_Undefer; + + else + Append_To (Blk_Stmts, + Build_Runtime_Call (Loc, RE_Abort_Undefer)); + end if; + end if; + end Initialize_Simple_Component; + ---------------------------------------- -- Is_Build_In_Place_Aggregate_Return -- ---------------------------------------- |