diff options
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 740 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 55 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/gen_il-fields.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/gen_il-gen-gen_nodes.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 31 | ||||
| -rw-r--r-- | gcc/ada/tbuild.adb | 36 | ||||
| -rw-r--r-- | gcc/ada/tbuild.ads | 11 |
9 files changed, 142 insertions, 750 deletions
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index dcbf2c4..fb5f404 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -108,31 +108,11 @@ package body Exp_Aggr is 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 + -- 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. function Is_CCG_Supported_Aggregate (N : Node_Id) return Boolean; @@ -181,37 +161,6 @@ package body Exp_Aggr is -- Returns the number of discrete choices (not including the others choice -- if present) contained in (sub-)aggregate N. - procedure Process_Transient_Component - (Loc : Source_Ptr; - Comp_Typ : Entity_Id; - Init_Expr : Node_Id; - Fin_Call : out Node_Id; - Hook_Clear : out Node_Id; - Aggr : Node_Id := Empty; - Stmts : List_Id := No_List); - -- Subsidiary to the expansion of array and record aggregates. Generate - -- part of the necessary code to finalize a transient component. Comp_Typ - -- is the component type. Init_Expr is the initialization expression of the - -- component which is always a function call. Fin_Call is the finalization - -- call used to clean up the transient function result. Hook_Clear is the - -- hook reset statement. Aggr and Stmts both control the placement of the - -- generated code. Aggr is the related aggregate. If present, all code is - -- inserted prior to Aggr using Insert_Action. Stmts is the initialization - -- statements of the component. If present, all code is added to Stmts. - - procedure Process_Transient_Component_Completion - (Loc : Source_Ptr; - Aggr : Node_Id; - Fin_Call : Node_Id; - Hook_Clear : Node_Id; - Stmts : List_Id); - -- Subsidiary to the expansion of array and record aggregates. Generate - -- part of the necessary code to finalize a transient component. Aggr is - -- the related aggregate. Fin_Clear is the finalization call used to clean - -- up the transient component. Hook_Clear is the hook reset statement. - -- Stmts is the initialization statement list for the component. All - -- generated code is added to Stmts. - procedure Sort_Case_Table (Case_Table : in out Case_Table_Type); -- Sort the Case Table using the Lower Bound of each Choice as the key. -- A simple insertion sort is used since the number of choices in a case @@ -2242,14 +2191,6 @@ package body Exp_Aggr is Comp_Expr : Node_Id; Expr_Q : Node_Id; - -- If this is an internal aggregate, the External_Final_List is an - -- expression for the controller record of the enclosing type. - - -- If the current aggregate has several controlled components, this - -- expression will appear in several calls to attach to the finali- - -- zation list, and it must not be shared. - - Ancestor_Is_Expression : Boolean := False; Ancestor_Is_Subtype_Mark : Boolean := False; Init_Typ : Entity_Id := Empty; @@ -2894,9 +2835,7 @@ package body Exp_Aggr is -- to the actual type of the aggregate, so that the proper components -- are visible. We know already that the types are compatible. - if Present (Etype (Lhs)) - and then Is_Class_Wide_Type (Etype (Lhs)) - then + if Present (Etype (Lhs)) and then Is_Class_Wide_Type (Etype (Lhs)) then Target := Unchecked_Convert_To (Typ, Lhs); else Target := Lhs; @@ -2910,7 +2849,6 @@ package body Exp_Aggr is Ancestor : constant Node_Id := Ancestor_Part (N); Ancestor_Q : constant Node_Id := Unqualify (Ancestor); - Adj_Call : Node_Id; Assign : List_Id; begin @@ -3057,7 +2995,6 @@ package body Exp_Aggr is -- Make_Build_In_Place_Call_In_Assignment). else - Ancestor_Is_Expression := True; Init_Typ := Etype (Ancestor); -- If the ancestor part is an aggregate, force its full @@ -3071,69 +3008,29 @@ package body Exp_Aggr is Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); - -- Make the assignment without usual controlled actions, since - -- we only want to Adjust afterwards, but not to Finalize - -- beforehand. Add manual Adjust when necessary. - Assign := New_List ( Make_OK_Assignment_Statement (Loc, Name => Ref, Expression => Ancestor)); - Set_No_Ctrl_Actions (First (Assign)); - - -- Assign the tag now to make sure that the dispatching call in - -- the subsequent deep_adjust works properly (unless - -- Tagged_Type_Expansion where tags are implicit). - - if Tagged_Type_Expansion then - Instr := - Make_Tag_Assignment_From_Type - (Loc, New_Copy_Tree (Target), Base_Type (Typ)); - - Append_To (Assign, Instr); - - -- Ada 2005 (AI-251): If tagged type has progenitors we must - -- also initialize tags of the secondary dispatch tables. - - if Has_Interfaces (Base_Type (Typ)) then - Init_Secondary_Tags - (Typ => Base_Type (Typ), - Target => Target, - Stmts_List => Assign, - Init_Tags_List => Assign); - end if; - end if; - -- Call Adjust manually + -- Arrange for the component to be adjusted if need be (the + -- call will be generated by Make_Tag_Ctrl_Assignment). if Needs_Finalization (Init_Typ) - and then not Is_Limited_Type (Init_Typ) - and then not Is_Build_In_Place_Function_Call (Ancestor) + and then not Is_Limited_View (Init_Typ) then - Adj_Call := - Make_Adjust_Call - (Obj_Ref => New_Copy_Tree (Ref), - Typ => Init_Typ); - - -- Guard against a missing [Deep_]Adjust when the ancestor - -- type was not properly frozen. - - if Present (Adj_Call) then - Append_To (Assign, Adj_Call); - end if; + Set_No_Finalize_Actions (First (Assign)); + else + Set_No_Ctrl_Actions (First (Assign)); end if; Append_To (L, - Make_Unsuppress_Block (Loc, Name_Discriminant_Check, Assign)); + Make_Suppress_Block (Loc, Name_Discriminant_Check, Assign)); if Has_Discriminants (Init_Typ) then Check_Ancestor_Discriminants (Init_Typ); end if; end if; - - pragma Assert (Nkind (N) = N_Extension_Aggregate); - pragma Assert - (not (Ancestor_Is_Expression and Ancestor_Is_Subtype_Mark)); end; -- Generate assignments of hidden discriminants. If the base type is @@ -3260,7 +3157,7 @@ package body Exp_Aggr is Prefix => New_Copy_Tree (Target), Selector_Name => New_Occurrence_Of (Selector, Loc)); - Initialize_Simple_Component + Initialize_Component (N => N, Comp => Comp_Expr, Comp_Typ => Etype (Selector), @@ -3591,21 +3488,18 @@ package body Exp_Aggr is Next (Comp); end loop; - -- If the type is tagged, the tag needs to be initialized (unless we - -- are in VM-mode where tags are implicit). It is done late in the - -- initialization process because in some cases, we call the init - -- proc of an ancestor which will not leave out the right tag. - - if Ancestor_Is_Expression then - null; - -- For CPP types we generated a call to the C++ default constructor -- before the components have been initialized to ensure the proper -- initialization of the _Tag component (see above). - elsif Is_CPP_Class (Typ) then + if Is_CPP_Class (Typ) then null; + -- If the type is tagged, the tag needs to be initialized (unless we + -- are in VM-mode where tags are implicit). It is done late in the + -- initialization process because in some cases, we call the init + -- proc of an ancestor which will not leave out the right tag. + elsif Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then Instr := Make_Tag_Assignment_From_Type @@ -8410,261 +8304,6 @@ package body Exp_Aggr is procedure Initialize_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); - - begin - -- If the initialization expression of a component with controlled type - -- is a conditional expression that has a function call as one of its - -- dependent expressions, then we need to expand it immediately, so as - -- to trigger the special processing for function calls with controlled - -- type below and avoid a wrong order of initialization, adjustment and - -- finalization in the context of aggregates. For the sake of uniformity - -- we perform this expansion for all conditional expressions. - - if Nkind (Init_Expr_Q) = N_If_Expression - and then Present (Comp_Typ) - and then Needs_Finalization (Comp_Typ) - then - declare - Cond : constant Node_Id := First (Expressions (Init_Expr_Q)); - Thenx : constant Node_Id := Next (Cond); - Elsex : constant Node_Id := Next (Thenx); - Then_Stmts : constant List_Id := New_List; - Else_Stmts : constant List_Id := New_List; - - If_Stmt : Node_Id; - - begin - Initialize_Component - (N => N, - Comp => Comp, - Comp_Typ => Comp_Typ, - Init_Expr => Thenx, - Stmts => Then_Stmts); - - Initialize_Component - (N => N, - Comp => Comp, - Comp_Typ => Comp_Typ, - Init_Expr => Elsex, - Stmts => Else_Stmts); - - If_Stmt := - Make_Implicit_If_Statement (N, - Condition => Relocate_Node (Cond), - Then_Statements => Then_Stmts, - Else_Statements => Else_Stmts); - - Set_From_Conditional_Expression (If_Stmt); - Append_To (Stmts, If_Stmt); - end; - - elsif Nkind (Init_Expr_Q) = N_Case_Expression - and then Present (Comp_Typ) - and then Needs_Finalization (Comp_Typ) - then - declare - Alt : Node_Id; - Alt_Stmts : List_Id; - Case_Stmt : Node_Id; - - begin - Case_Stmt := - Make_Case_Statement (Loc, - Expression => - Relocate_Node (Expression (Init_Expr_Q)), - Alternatives => New_List); - - Alt := First (Alternatives (Init_Expr_Q)); - while Present (Alt) loop - declare - Alt_Expr : constant Node_Id := Expression (Alt); - Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr); - - begin - Alt_Stmts := New_List; - - Initialize_Component - (N => N, - Comp => Comp, - Comp_Typ => Comp_Typ, - Init_Expr => Alt_Expr, - Stmts => Alt_Stmts); - - Append_To - (Alternatives (Case_Stmt), - Make_Case_Statement_Alternative (Alt_Loc, - Discrete_Choices => Discrete_Choices (Alt), - Statements => Alt_Stmts)); - end; - - Next (Alt); - end loop; - - Set_From_Conditional_Expression (Case_Stmt); - Append_To (Stmts, Case_Stmt); - end; - - -- 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); - - elsif Nkind (Init_Expr_Q) /= N_Aggregate - and then Present (Comp_Typ) - and then Needs_Finalization (Comp_Typ) - 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) @@ -8674,10 +8313,8 @@ package body Exp_Aggr is 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; @@ -8716,48 +8353,33 @@ package body Exp_Aggr is 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_Tag_Assignment_From_Type - (Loc, New_Copy_Tree (Comp), Full_Typ)); - 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); + -- Arrange for the component to be adjusted if need be (the call will be + -- generated by Make_Tag_Ctrl_Assignment). But, 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. 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_Limited_View (Comp_Typ) 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); + Set_No_Finalize_Actions (Init_Stmt); - -- Guard against a missing [Deep_]Adjust when the component type - -- was not properly frozen. + -- Or else, only adjust the tag due to a possible view conversion + + else + Set_No_Ctrl_Actions (Init_Stmt); - if Present (Adj_Call) then - Append_To (Blk_Stmts, Adj_Call); + if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then + Append_To (Blk_Stmts, + Make_Tag_Assignment_From_Type + (Loc, New_Copy_Tree (Comp), Underlying_Type (Comp_Typ))); end if; end if; @@ -8796,7 +8418,7 @@ package body Exp_Aggr is Build_Runtime_Call (Loc, RE_Abort_Undefer)); end if; end if; - end Initialize_Simple_Component; + end Initialize_Component; ---------------------------------------- -- Is_Build_In_Place_Aggregate_Return -- @@ -9522,304 +9144,6 @@ package body Exp_Aggr is end if; end Must_Slide; - --------------------------------- - -- Process_Transient_Component -- - --------------------------------- - - procedure Process_Transient_Component - (Loc : Source_Ptr; - Comp_Typ : Entity_Id; - Init_Expr : Node_Id; - Fin_Call : out Node_Id; - Hook_Clear : out Node_Id; - Aggr : Node_Id := Empty; - Stmts : List_Id := No_List) - is - procedure Add_Item (Item : Node_Id); - -- Insert arbitrary node Item into the tree depending on the values of - -- Aggr and Stmts. - - -------------- - -- Add_Item -- - -------------- - - procedure Add_Item (Item : Node_Id) is - begin - if Present (Aggr) then - Insert_Action (Aggr, Item); - else - pragma Assert (Present (Stmts)); - Append_To (Stmts, Item); - end if; - end Add_Item; - - -- Local variables - - Hook_Assign : Node_Id; - Hook_Decl : Node_Id; - Ptr_Decl : Node_Id; - Res_Decl : Node_Id; - Res_Id : Entity_Id; - Res_Typ : Entity_Id; - Copy_Init_Expr : constant Node_Id := New_Copy_Tree (Init_Expr); - - -- Start of processing for Process_Transient_Component - - begin - -- Add the access type, which provides a reference to the function - -- result. Generate: - - -- type Res_Typ is access all Comp_Typ; - - Res_Typ := Make_Temporary (Loc, 'A'); - Mutate_Ekind (Res_Typ, E_General_Access_Type); - Set_Directly_Designated_Type (Res_Typ, Comp_Typ); - - Add_Item - (Make_Full_Type_Declaration (Loc, - Defining_Identifier => Res_Typ, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => True, - Subtype_Indication => New_Occurrence_Of (Comp_Typ, Loc)))); - - -- Add the temporary which captures the result of the function call. - -- Generate: - - -- Res : constant Res_Typ := Init_Expr'Reference; - - -- Note that this temporary is effectively a transient object because - -- its lifetime is bounded by the current array or record component. - - Res_Id := Make_Temporary (Loc, 'R'); - Mutate_Ekind (Res_Id, E_Constant); - Set_Etype (Res_Id, Res_Typ); - - -- Mark the transient object as successfully processed to avoid double - -- finalization. - - Set_Is_Finalized_Transient (Res_Id); - - -- Signal the general finalization machinery that this transient object - -- should not be considered for finalization actions because its cleanup - -- will be performed by Process_Transient_Component_Completion. - - Set_Is_Ignored_Transient (Res_Id); - - Res_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Res_Id, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Res_Typ, Loc), - Expression => - Make_Reference (Loc, Copy_Init_Expr)); - - -- In some cases, like iterated component, the Init_Expr may have been - -- analyzed in a context where all the Etype fields are not correct yet - -- and a later call to Analyze is expected to set them. - -- Resetting the Analyzed flag ensures this later call doesn't skip this - -- node. - - Reset_Analyzed_Flags (Copy_Init_Expr); - - Add_Item (Res_Decl); - - -- Construct all pieces necessary to hook and finalize the transient - -- result. - - Build_Transient_Object_Statements - (Obj_Decl => Res_Decl, - Fin_Call => Fin_Call, - Hook_Assign => Hook_Assign, - Hook_Clear => Hook_Clear, - Hook_Decl => Hook_Decl, - Ptr_Decl => Ptr_Decl); - - -- Add the access type which provides a reference to the transient - -- result. Generate: - - -- type Ptr_Typ is access all Comp_Typ; - - Add_Item (Ptr_Decl); - - -- Add the temporary which acts as a hook to the transient result. - -- Generate: - - -- Hook : Ptr_Typ := null; - - Add_Item (Hook_Decl); - - -- Attach the transient result to the hook. Generate: - - -- Hook := Ptr_Typ (Res); - - Add_Item (Hook_Assign); - - -- The original initialization expression now references the value of - -- the temporary function result. Generate: - - -- Res.all - - Rewrite (Init_Expr, - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Res_Id, Loc))); - end Process_Transient_Component; - - -------------------------------------------- - -- Process_Transient_Component_Completion -- - -------------------------------------------- - - procedure Process_Transient_Component_Completion - (Loc : Source_Ptr; - Aggr : Node_Id; - Fin_Call : Node_Id; - Hook_Clear : Node_Id; - Stmts : List_Id) - is - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); - - begin - pragma Assert (Present (Hook_Clear)); - - -- Generate the following code if exception propagation is allowed: - - -- declare - -- Abort : constant Boolean := Triggered_By_Abort; - -- <or> - -- Abort : constant Boolean := False; -- no abort - - -- E : Exception_Occurrence; - -- Raised : Boolean := False; - - -- begin - -- [Abort_Defer;] - - -- begin - -- Hook := null; - -- [Deep_]Finalize (Res.all); - - -- exception - -- when others => - -- if not Raised then - -- Raised := True; - -- Save_Occurrence (E, - -- Get_Curent_Excep.all.all); - -- end if; - -- end; - - -- [Abort_Undefer;] - - -- if Raised and then not Abort then - -- Raise_From_Controlled_Operation (E); - -- end if; - -- end; - - if Exceptions_OK then - Abort_And_Exception : declare - Blk_Decls : constant List_Id := New_List; - Blk_Stmts : constant List_Id := New_List; - Fin_Stmts : constant List_Id := New_List; - - Fin_Data : Finalization_Exception_Data; - - begin - -- Create the declarations of the two flags and the exception - -- occurrence. - - Build_Object_Declarations (Fin_Data, Blk_Decls, Loc); - - -- Generate: - -- Abort_Defer; - - if Abort_Allowed then - Append_To (Blk_Stmts, - Build_Runtime_Call (Loc, RE_Abort_Defer)); - end if; - - -- Wrap the hook clear and the finalization call in order to trap - -- a potential exception. - - Append_To (Fin_Stmts, Hook_Clear); - - if Present (Fin_Call) then - Append_To (Fin_Stmts, Fin_Call); - end if; - - Append_To (Blk_Stmts, - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Fin_Stmts, - Exception_Handlers => New_List ( - Build_Exception_Handler (Fin_Data))))); - - -- Generate: - -- Abort_Undefer; - - if Abort_Allowed then - Append_To (Blk_Stmts, - Build_Runtime_Call (Loc, RE_Abort_Undefer)); - end if; - - -- Reraise the potential exception with a proper "upgrade" to - -- Program_Error if needed. - - Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data)); - - -- Wrap everything in a block - - Append_To (Stmts, - Make_Block_Statement (Loc, - Declarations => Blk_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Blk_Stmts))); - end Abort_And_Exception; - - -- Generate the following code if exception propagation is not allowed - -- and aborts are allowed: - - -- begin - -- Abort_Defer; - -- Hook := null; - -- [Deep_]Finalize (Res.all); - -- at end - -- Abort_Undefer_Direct; - -- end; - - elsif Abort_Allowed then - Abort_Only : declare - Blk_Stmts : constant List_Id := New_List; - - begin - Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); - Append_To (Blk_Stmts, Hook_Clear); - - if Present (Fin_Call) then - Append_To (Blk_Stmts, Fin_Call); - end if; - - Append_To (Stmts, - Build_Abort_Undefer_Block (Loc, - Stmts => Blk_Stmts, - Context => Aggr)); - end Abort_Only; - - -- Otherwise generate: - - -- Hook := null; - -- [Deep_]Finalize (Res.all); - - else - Append_To (Stmts, Hook_Clear); - - if Present (Fin_Call) then - Append_To (Stmts, Fin_Call); - end if; - end if; - end Process_Transient_Component_Completion; - --------------------- -- Sort_Case_Table -- --------------------- diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 2be6e7e..d8214bd 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -952,6 +952,7 @@ package body Exp_Ch5 is and then Base_Type (L_Type) = Base_Type (R_Type) and then Ndim = 1 and then not No_Ctrl_Actions (N) + and then not No_Finalize_Actions (N) then declare Proc : constant Entity_Id := @@ -1097,8 +1098,8 @@ package body Exp_Ch5 is and then Base_Type (L_Type) = Base_Type (R_Type) and then Ndim = 1 and then not No_Ctrl_Actions (N) + and then not No_Finalize_Actions (N) then - -- Call TSS procedure for array assignment, passing the -- explicit bounds of right- and left-hand sides. @@ -1321,9 +1322,10 @@ package body Exp_Ch5 is Set_Assignment_OK (Name (Assign)); - -- Propagate the No_Ctrl_Actions flag to individual assignments + -- Propagate the No_{Ctrl,Finalize}_Actions flags to assignments - Set_No_Ctrl_Actions (Assign, No_Ctrl_Actions (N)); + Set_No_Ctrl_Actions (Assign, No_Ctrl_Actions (N)); + Set_No_Finalize_Actions (Assign, No_Finalize_Actions (N)); end; -- Now construct the loop from the inside out, with the last subscript @@ -2963,7 +2965,9 @@ package body Exp_Ch5 is then Tagged_Case : declare L : List_Id := No_List; - Expand_Ctrl_Actions : constant Boolean := not No_Ctrl_Actions (N); + Expand_Ctrl_Actions : constant Boolean + := not No_Ctrl_Actions (N) + and then not No_Finalize_Actions (N); begin -- In the controlled case, we ensure that function calls are @@ -3163,10 +3167,20 @@ package body Exp_Ch5 is end if; end if; - Rewrite (N, - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, Statements => L))); + -- We will analyze the block statement with all checks suppressed + -- below, but we need elaboration checks for the primitives in the + -- case of an assignment created by the expansion of an aggregate. + + if No_Finalize_Actions (N) then + Rewrite (N, + Make_Unsuppress_Block (Loc, Name_Elaboration_Check, L)); + + else + Rewrite (N, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, L))); + end if; -- If no restrictions on aborts, protect the whole assignment -- for controlled objects as per 9.8(11). @@ -6240,12 +6254,20 @@ package body Exp_Ch5 is Res : constant List_Id := New_List; T : constant Entity_Id := Underlying_Type (Etype (L)); + Adj_Act : constant Boolean := Needs_Finalization (T) + and then not No_Ctrl_Actions (N); Comp_Asn : constant Boolean := Is_Fully_Repped_Tagged_Type (T); Ctrl_Act : constant Boolean := Needs_Finalization (T) - and then not No_Ctrl_Actions (N); + and then not No_Ctrl_Actions (N) + and then not No_Finalize_Actions (N); Save_Tag : constant Boolean := Is_Tagged_Type (T) and then not Comp_Asn and then not No_Ctrl_Actions (N) + and then not No_Finalize_Actions (N) + and then Tagged_Type_Expansion; + Set_Tag : constant Boolean := Is_Tagged_Type (T) + and then not Comp_Asn + and then not No_Ctrl_Actions (N) and then Tagged_Type_Expansion; Adj_Call : Node_Id; Fin_Call : Node_Id; @@ -6256,8 +6278,8 @@ package body Exp_Ch5 is -- We have two exceptions here: - -- 1. If we are in an init proc since it is an initialization more - -- than an assignment. + -- 1. If we are in an init proc or within an aggregate, since it is an + -- initialization more than an assignment. -- 2. If the left-hand side is a temporary that was not initialized -- (or the parent part of a temporary since it is the case in @@ -6266,7 +6288,7 @@ package body Exp_Ch5 is -- it may be a component of an entry formal, in which case it has -- been rewritten and does not appear to come from source either. - -- Case of init proc + -- Case of init proc or aggregate if not Ctrl_Act then null; @@ -6336,12 +6358,19 @@ package body Exp_Ch5 is Selector_Name => New_Occurrence_Of (First_Tag_Component (T), Loc)), Expression => New_Occurrence_Of (Tag_Id, Loc))); + + -- Or else just initialize it + + elsif Set_Tag then + Append_To (Res, + Make_Tag_Assignment_From_Type + (Loc, Duplicate_Subexpr_No_Checks (L), T)); end if; -- Adjust the target after the assignment when controlled (not in the -- init proc since it is an initialization more than an assignment). - if Ctrl_Act then + if Ctrl_Act or else Adj_Act then Adj_Call := Make_Adjust_Call (Obj_Ref => Duplicate_Subexpr_Move_Checks (L), diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index def027f..b032336 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -11877,14 +11877,6 @@ package body Exp_Util is then return; - -- Nothing to do if prior expansion determined that a function call does - -- not require side effect removal. - - elsif Nkind (Exp) = N_Function_Call - and then No_Side_Effect_Removal (Exp) - then - return; - -- No action needed for side-effect free expressions elsif Check_Side_Effects diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index ad240a7..c62523d 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -321,9 +321,9 @@ package Gen_IL.Fields is No_Ctrl_Actions, No_Elaboration_Check, No_Entities_Ref_In_Spec, + No_Finalize_Actions, No_Initialization, No_Minimize_Eliminate, - No_Side_Effect_Removal, No_Truncation, Null_Excluding_Subtype, Null_Exclusion_Present, diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index 864b7c4..19551fd 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -401,8 +401,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Cc (N_Function_Call, N_Subprogram_Call, (Sy (Name, Node_Id, Default_Empty), Sy (Parameter_Associations, List_Id, Default_No_List), - Sm (Is_Expanded_Build_In_Place_Call, Flag), - Sm (No_Side_Effect_Removal, Flag))); + Sm (Is_Expanded_Build_In_Place_Call, Flag))); Cc (N_Procedure_Call_Statement, N_Subprogram_Call, (Sy (Name, Node_Id, Default_Empty), @@ -970,6 +969,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sm (Is_Elaboration_Code, Flag), Sm (Is_SPARK_Mode_On_Node, Flag), Sm (No_Ctrl_Actions, Flag), + Sm (No_Finalize_Actions, Flag), Sm (Suppress_Assignment_Checks, Flag))); Cc (N_Asynchronous_Select, N_Statement_Other_Than_Procedure_Call, diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index cc3e018..abc0e5d 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -11279,7 +11279,10 @@ package body Sem_Prag is -- Warn that suppress of Elaboration_Check has no effect in SPARK - if C = Elaboration_Check and then SPARK_Mode = On then + if C = Elaboration_Check + and then Suppress_Case + and then SPARK_Mode = On + then Error_Pragma_Arg ("Suppress of Elaboration_Check ignored in SPARK??", "\elaboration checking rules are statically enforced " diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 0f698cd..b565221 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -2067,12 +2067,14 @@ package Sinfo is -- is undefined and should not be read). -- No_Ctrl_Actions - -- Present in N_Assignment_Statement to indicate that no Finalize nor - -- Adjust should take place on this assignment even though the RHS is - -- controlled. Also indicates that the primitive _assign should not be - -- used for a tagged assignment. This is used in init procs and aggregate - -- expansions where the generated assignments are initializations, not - -- real assignments. + -- Present in N_Assignment_Statement to indicate that neither Finalize + -- nor Adjust should take place on this assignment even though the LHS + -- and RHS are controlled. Also to indicate that the primitive _assign + -- should not be used for a tagged assignment. This flag is used in init + -- proc and aggregate expansion where the generated assignments are + -- initializations, not real assignments. Note that it also suppresses + -- the creation of transient scopes around the N_Assignment_Statement, + -- in other words it disables all controlled actions for the assignment. -- No_Elaboration_Check -- NOTE: this flag is relevant only for the legacy ABE mechanism and @@ -2092,6 +2094,15 @@ package Sinfo is -- to generate the proper message (see Sem_Util.Check_Unused_Withs for -- full details). + -- No_Finalize_Actions + -- Present in N_Assignment_Statement to indicate that no Finalize should + -- take place on this assignment even though the LHS is controlled. Also + -- to indicate that the primitive _assign should not be used for a tagged + -- assignment. This flag is only used in aggregates expansion where the + -- generated assignments are initializations, not real assignments. Note + -- that, unlike the No_Ctrl_Actions flag, it does *not* suppress the + -- creation of transient scopes around the N_Assignment_Statement. + -- No_Initialization -- Present in N_Object_Declaration and N_Allocator to indicate that the -- object must not be initialized (by Initialize or call to an init @@ -2106,12 +2117,6 @@ package Sinfo is -- It is used to indicate that processing for extended overflow checking -- modes is not required (this is used to prevent infinite recursion). - -- No_Side_Effect_Removal - -- Present in N_Function_Call nodes. Set when a function call does not - -- require side effect removal. This attribute suppresses the generation - -- of a temporary to capture the result of the function which eventually - -- replaces the function call. - -- No_Truncation -- Present in N_Unchecked_Type_Conversion node. This flag has an effect -- only if the RM_Size of the source is greater than the RM_Size of the @@ -4934,6 +4939,7 @@ package Sinfo is -- Forwards_OK -- Backwards_OK -- No_Ctrl_Actions + -- No_Finalize_Actions -- Has_Target_Names -- Is_Elaboration_Code -- Componentwise_Assignment @@ -5560,7 +5566,6 @@ package Sinfo is -- Is_Elaboration_Warnings_OK_Node -- No_Elaboration_Check -- Is_Expanded_Build_In_Place_Call - -- No_Side_Effect_Removal -- Is_Known_Guaranteed_ABE -- plus fields for expression diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 2a8fc36..a8b0437 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -525,6 +525,38 @@ package body Tbuild is return Make_String_Literal (Sloc, Strval => End_String); end Make_String_Literal; + ------------------------- + -- Make_Suppress_Block -- + ------------------------- + + -- Generates the following expansion: + + -- declare + -- pragma Suppress (<check>); + -- begin + -- <stmts> + -- end; + + function Make_Suppress_Block + (Loc : Source_Ptr; + Check : Name_Id; + Stmts : List_Id) return Node_Id + is + begin + return + Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Pragma (Loc, + Chars => Name_Suppress, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Check))))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + end Make_Suppress_Block; + -------------------- -- Make_Temporary -- -------------------- @@ -548,7 +580,7 @@ package body Tbuild is -- Generates the following expansion: -- declare - -- pragma Suppress (<check>); + -- pragma Unsuppress (<check>); -- begin -- <stmts> -- end; @@ -563,7 +595,7 @@ package body Tbuild is Make_Block_Statement (Loc, Declarations => New_List ( Make_Pragma (Loc, - Chars => Name_Suppress, + Chars => Name_Unsuppress, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Make_Identifier (Loc, Check))))), diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index 1b42fbd..bb2c70c 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -187,6 +187,13 @@ package Tbuild is -- A convenient form of Make_String_Literal, where the string value is -- given as a normal string instead of a String_Id value. + function Make_Suppress_Block + (Loc : Source_Ptr; + Check : Name_Id; + Stmts : List_Id) return Node_Id; + -- Build a block with a pragma Suppress on Check. Stmts is the statements + -- list that needs protection against the check activation. + function Make_Temporary (Loc : Source_Ptr; Id : Character; @@ -207,8 +214,8 @@ package Tbuild is (Loc : Source_Ptr; Check : Name_Id; Stmts : List_Id) return Node_Id; - -- Build a block with a pragma Suppress on 'Check'. Stmts is the statements - -- list that needs protection against the check + -- Build a block with a pragma Unsuppress on Check. Stmts is the statements + -- list that needs protection against the check suppression. function New_Constraint_Error (Loc : Source_Ptr) return Node_Id; -- This function builds a tree corresponding to the Ada statement |