From bb072d1c1716ecb6cd99f43a5dbc4855931302d3 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 6 Jul 2016 14:40:07 +0200 Subject: [PATCH] [multiple changes] 2016-07-06 Hristian Kirtchev * exp_aggr.adb Remove with and use clauses for Exp_Ch11 and Inline. (Initialize_Array_Component): Protect the initialization statements in an abort defer / undefer block when the associated component is controlled. (Initialize_Record_Component): Protect the initialization statements in an abort defer / undefer block when the associated component is controlled. (Process_Transient_Component_Completion): Use Build_Abort_Undefer_Block to create an abort defer / undefer block. * exp_ch3.adb Remove with and use clauses for Exp_ch11 and Inline. (Default_Initialize_Object): Use Build_Abort_Undefer_Block to create an abort defer / undefer block. * exp_ch5.adb (Expand_N_Assignment_Statement): Mark an abort defer / undefer block as such. * exp_ch9.adb (Find_Enclosing_Context): Do not consider an abort defer / undefer block as a suitable context for an activation chain or a master. * exp_util.adb Add with and use clauses for Exp_Ch11. (Build_Abort_Undefer_Block): New routine. * exp_util.ads (Build_Abort_Undefer_Block): New routine. * sinfo.adb (Is_Abort_Block): New routine. (Set_Is_Abort_Block): New routine. * sinfo.ads New attribute Is_Abort_Block along with occurrences in nodes. (Is_Abort_Block): New routine along with pragma Inline. (Set_Is_Abort_Block): New routine along with pragma Inline. 2016-07-06 Justin Squirek * sem_ch4.adb (Analyze_One_Call): Add a conditional to handle disambiguation. From-SVN: r238045 --- gcc/ada/ChangeLog | 34 ++++++++ gcc/ada/exp_aggr.adb | 184 +++++++++++++++++++++++++++++++++---------- gcc/ada/exp_ch3.adb | 42 +++------- gcc/ada/exp_ch5.adb | 2 + gcc/ada/exp_ch9.adb | 34 +++++--- gcc/ada/exp_util.adb | 60 +++++++++++++- gcc/ada/exp_util.ads | 9 +++ gcc/ada/sem_ch4.adb | 55 +++++++++++++ gcc/ada/sinfo.adb | 16 ++++ gcc/ada/sinfo.ads | 13 +++ 10 files changed, 360 insertions(+), 89 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index be8759c4274..764ba8d63e7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,37 @@ +2016-07-06 Hristian Kirtchev + + * exp_aggr.adb Remove with and use clauses for Exp_Ch11 and Inline. + (Initialize_Array_Component): Protect the initialization + statements in an abort defer / undefer block when the associated + component is controlled. + (Initialize_Record_Component): Protect the initialization statements + in an abort defer / undefer block when the associated component is + controlled. + (Process_Transient_Component_Completion): Use Build_Abort_Undefer_Block + to create an abort defer / undefer block. + * exp_ch3.adb Remove with and use clauses for Exp_ch11 and Inline. + (Default_Initialize_Object): Use Build_Abort_Undefer_Block to + create an abort defer / undefer block. + * exp_ch5.adb (Expand_N_Assignment_Statement): Mark an abort + defer / undefer block as such. + * exp_ch9.adb (Find_Enclosing_Context): Do not consider an abort + defer / undefer block as a suitable context for an activation + chain or a master. + * exp_util.adb Add with and use clauses for Exp_Ch11. + (Build_Abort_Undefer_Block): New routine. + * exp_util.ads (Build_Abort_Undefer_Block): New routine. + * sinfo.adb (Is_Abort_Block): New routine. + (Set_Is_Abort_Block): New routine. + * sinfo.ads New attribute Is_Abort_Block along with occurrences + in nodes. + (Is_Abort_Block): New routine along with pragma Inline. + (Set_Is_Abort_Block): New routine along with pragma Inline. + +2016-07-06 Justin Squirek + + * sem_ch4.adb (Analyze_One_Call): Add a conditional to handle + disambiguation. + 2016-07-06 Hristian Kirtchev * einfo.adb Flag252 is now used as Is_Finalized_Transient. Flag295 diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 7d1db3e4987..33374d35882 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -35,12 +35,10 @@ with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch9; use Exp_Ch9; -with Exp_Ch11; use Exp_Ch11; with Exp_Disp; use Exp_Disp; with Exp_Tss; use Exp_Tss; with Fname; use Fname; with Freeze; use Freeze; -with Inline; use Inline; with Itypes; use Itypes; with Lib; use Lib; with Namet; use Namet; @@ -1121,10 +1119,39 @@ package body Exp_Aggr is 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); + 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; @@ -1148,10 +1175,7 @@ package body Exp_Aggr is -- Arr_Comp := Init_Expr; -- end; - if Present (Comp_Typ) - and then Needs_Finalization (Comp_Typ) - and then Is_Array_Type (Comp_Typ) - then + if Finalization_OK and then Is_Array_Type (Comp_Typ) then Init_Stmt := Make_Block_Statement (Loc, Handled_Statement_Sequence => @@ -1159,7 +1183,7 @@ package body Exp_Aggr is Statements => New_List (Init_Stmt))); end if; - Append_To (Stmts, Init_Stmt); + Append_To (Blk_Stmts, Init_Stmt); -- Adjust the tag due to a possible view conversion. Generate: @@ -1169,7 +1193,7 @@ package body Exp_Aggr is and then Present (Comp_Typ) and then Is_Tagged_Type (Comp_Typ) then - Append_To (Stmts, + Append_To (Blk_Stmts, Make_OK_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, @@ -1191,19 +1215,54 @@ package body Exp_Aggr is -- [Deep_]Adjust (Arr_Comp); - if Present (Comp_Typ) - and then Needs_Finalization (Comp_Typ) + if Finalization_OK and then not Is_Limited_Type (Comp_Typ) and then not (Is_Array_Type (Comp_Typ) and then Is_Controlled (Component_Type (Comp_Typ)) and then Nkind (Expr) = N_Aggregate) then - Append_To (Stmts, + Append_To (Blk_Stmts, Make_Adjust_Call (Obj_Ref => New_Copy_Tree (Arr_Comp), Typ => Comp_Typ)); 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; ------------------------------------- @@ -2772,10 +2831,36 @@ package body Exp_Aggr is 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); + 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 record component. Generate: -- Rec_Comp := Init_Expr; @@ -2789,14 +2874,14 @@ package body Exp_Aggr is Expression => Init_Expr); Set_No_Ctrl_Actions (Init_Stmt); - Append_To (Stmts, 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 (Stmts, + Append_To (Blk_Stmts, Make_OK_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, @@ -2816,14 +2901,48 @@ package body Exp_Aggr is -- [Deep_]Adjust (Rec_Comp); - if Needs_Finalization (Comp_Typ) - and then not Is_Limited_Type (Comp_Typ) - then - Append_To (Stmts, + if Finalization_OK and then not Is_Limited_Type (Comp_Typ) then + Append_To (Blk_Stmts, Make_Adjust_Call (Obj_Ref => New_Copy_Tree (Rec_Comp), Typ => Comp_Typ)); 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; ------------------------- @@ -7804,43 +7923,22 @@ package body Exp_Aggr is -- Hook := null; -- [Deep_]Finalize (Res.all); -- at end - -- Abort_Undefer; + -- Abort_Undefer_Direct; -- end; elsif Abort_Allowed then Abort_Only : declare Blk_Stmts : constant List_Id := New_List; - AUD : Entity_Id; - Blk : Node_Id; - Blk_HSS : Node_Id; - Blk_Id : Entity_Id; - begin Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); Append_To (Blk_Stmts, Hook_Clear); Append_To (Blk_Stmts, Fin_Call); - AUD := RTE (RE_Abort_Undefer_Direct); - - Blk_HSS := - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Blk_Stmts, - At_End_Proc => New_Occurrence_Of (AUD, Loc)); - - Blk := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => Blk_HSS); - - Add_Block_Identifier (Blk, Blk_Id); - Expand_At_End_Handler (Blk_HSS, Blk_Id); - - -- Present the Abort_Undefer_Direct function to the back end so - -- that it can inline the call to the function. - - Add_Inlined_Body (AUD, Aggr); - - Append_To (Stmts, Blk); + Append_To (Stmts, + Build_Abort_Undefer_Block (Loc, + Stmts => Blk_Stmts, + Context => Aggr)); end Abort_Only; -- Otherwise generate: diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 923eca373a7..6f7ae0a002b 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -34,7 +34,6 @@ with Exp_Ch4; use Exp_Ch4; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch9; use Exp_Ch9; -with Exp_Ch11; use Exp_Ch11; with Exp_Dbug; use Exp_Dbug; with Exp_Disp; use Exp_Disp; with Exp_Dist; use Exp_Dist; @@ -44,7 +43,6 @@ with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Ghost; use Ghost; -with Inline; use Inline; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -5519,16 +5517,12 @@ package body Exp_Ch3 is Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); - Abrt_Blk : Node_Id; - Abrt_Blk_Id : Entity_Id; - Abrt_HSS : Node_Id; - Aggr_Init : Node_Id; - AUD : Entity_Id; - Comp_Init : List_Id := No_List; - Fin_Call : Node_Id; - Init_Stmts : List_Id := No_List; - Obj_Init : Node_Id := Empty; - Obj_Ref : Node_Id; + Aggr_Init : Node_Id; + Comp_Init : List_Id := No_List; + Fin_Call : Node_Id; + Init_Stmts : List_Id := No_List; + Obj_Init : Node_Id := Empty; + Obj_Ref : Node_Id; -- Start of processing for Default_Initialize_Object @@ -5726,26 +5720,10 @@ package body Exp_Ch3 is -- end; if Exceptions_OK then - AUD := RTE (RE_Abort_Undefer_Direct); - - Abrt_HSS := - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Init_Stmts, - At_End_Proc => New_Occurrence_Of (AUD, Loc)); - - Abrt_Blk := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => Abrt_HSS); - - Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id); - Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id); - - -- Present the Abort_Undefer_Direct function to the backend so - -- that it can inline the call to the function. - - Add_Inlined_Body (AUD, N); - - Init_Stmts := New_List (Abrt_Blk); + Init_Stmts := New_List ( + Build_Abort_Undefer_Block (Loc, + Stmts => Init_Stmts, + Context => N)); -- Otherwise exceptions are not propagated. Generate: diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 2a3ecbfe39b..77342299e82 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2371,6 +2371,8 @@ package body Exp_Ch5 is AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct); begin + Set_Is_Abort_Block (N); + Set_Scope (Blk, Current_Scope); Set_Etype (Blk, Standard_Void_Type); Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N))); diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 34f2150b37d..9591e19f2d3 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -13217,17 +13217,30 @@ package body Exp_Ch9 is -- package or return statement. Context := Parent (N); - while not Nkind_In (Context, N_Block_Statement, - N_Entry_Body, - N_Extended_Return_Statement, - N_Package_Body, - N_Package_Declaration, - N_Subprogram_Body, - N_Task_Body) - loop + while Present (Context) loop + if Nkind_In (Context, N_Entry_Body, + N_Extended_Return_Statement, + N_Package_Body, + N_Package_Declaration, + N_Subprogram_Body, + N_Task_Body) + then + exit; + + -- Do not consider block created to protect a list of statements with + -- an Abort_Defer / Abort_Undefer_Direct pair. + + elsif Nkind (Context) = N_Block_Statement + and then not Is_Abort_Block (Context) + then + exit; + end if; + Context := Parent (Context); end loop; + pragma Assert (Present (Context)); + -- Extract the constituents of the context if Nkind (Context) = N_Extended_Return_Statement then @@ -13258,8 +13271,6 @@ package body Exp_Ch9 is end if; else - Context_Decls := Declarations (Context); - if Nkind (Context) = N_Block_Statement then Context_Id := Entity (Identifier (Context)); @@ -13283,9 +13294,10 @@ package body Exp_Ch9 is else raise Program_Error; end if; + + Context_Decls := Declarations (Context); end if; - pragma Assert (Present (Context)); pragma Assert (Present (Context_Id)); pragma Assert (Present (Context_Decls)); end Find_Enclosing_Context; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 92a3aab53a5..6d6d7546597 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -34,6 +34,7 @@ with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; +with Exp_Ch11; use Exp_Ch11; with Ghost; use Ghost; with Inline; use Inline; with Itypes; use Itypes; @@ -724,7 +725,7 @@ package body Exp_Util is -- For deallocation of class-wide types we obtain the value of -- alignment from the Type Specific Record of the deallocated object. -- This is needed because the frontend expansion of class-wide types - -- into equivalent types confuses the backend. + -- into equivalent types confuses the back end. else -- Generate: @@ -930,6 +931,59 @@ package body Exp_Util is end; end Build_Allocate_Deallocate_Proc; + ------------------------------- + -- Build_Abort_Undefer_Block -- + ------------------------------- + + function Build_Abort_Undefer_Block + (Loc : Source_Ptr; + Stmts : List_Id; + Context : Node_Id) return Node_Id + is + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + + AUD : Entity_Id; + Blk : Node_Id; + Blk_Id : Entity_Id; + HSS : Node_Id; + + begin + -- The block should be generated only when undeferring abort in the + -- context of a potential exception. + + pragma Assert (Abort_Allowed and Exceptions_OK); + + -- Generate: + -- begin + -- + -- at end + -- Abort_Undefer_Direct; + -- end; + + AUD := RTE (RE_Abort_Undefer_Direct); + + HSS := + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts, + At_End_Proc => New_Occurrence_Of (AUD, Loc)); + + Blk := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => HSS); + Set_Is_Abort_Block (Blk); + + Add_Block_Identifier (Blk, Blk_Id); + Expand_At_End_Handler (HSS, Blk_Id); + + -- Present the Abort_Undefer_Direct function to the back end to inline + -- the call to the routine. + + Add_Inlined_Body (AUD, Context); + + return Blk; + end Build_Abort_Undefer_Block; + -------------------------- -- Build_Procedure_Form -- -------------------------- @@ -2441,7 +2495,7 @@ package body Exp_Util is -- If the type of the expression is an internally generated type it -- may not be necessary to create a new subtype. However there are two -- exceptions: references to the current instances, and aliased array - -- object declarations for which the backend needs to create a template. + -- object declarations for which the back end has to create a template. elsif Is_Constrained (Exp_Typ) and then not Is_Class_Wide_Type (Unc_Type) @@ -9227,7 +9281,7 @@ package body Exp_Util is -- Note on checks that could raise Constraint_Error. Strictly, if we -- take advantage of 11.6, these checks do not count as side effects. -- However, we would prefer to consider that they are side effects, - -- since the backend CSE does not work very well on expressions which + -- since the back end CSE does not work very well on expressions which -- can raise Constraint_Error. On the other hand if we don't consider -- them to be side effect free, then we get some awkward expansions -- in -gnato mode, resulting in code insertions at a point where we diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index e5b991690b4..b82d40869b1 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -238,6 +238,15 @@ package Exp_Util is -- must be a free statement. If flag Is_Allocate is set, the generated -- routine is allocate, deallocate otherwise. + function Build_Abort_Undefer_Block + (Loc : Source_Ptr; + Stmts : List_Id; + Context : Node_Id) return Node_Id; + -- Wrap statements Stmts in a block where the AT END handler contains a + -- call to Abort_Undefer_Direct. Context is the node which prompted the + -- inlining of the abort undefer routine. Note that this routine does + -- not install a call to Abort_Defer. + procedure Build_Procedure_Form (N : Node_Id); -- Create a procedure declaration which emulates the behavior of a function -- that returns an array type, for C-compatible generation. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 17c6308f8ff..5bbc1a34d17 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -3480,6 +3480,61 @@ package body Sem_Ch4 is Next_Actual (Actual); Next_Formal (Formal); + -- In a complex case where an enclosing generic and a nested + -- generic package, both declared with partially parameterized + -- formal subprograms with the same names, are instantiated + -- with the same type, the types of the actual parameter and + -- that of the formal may appear incompatible at first sight. + + -- generic + -- type Outer_T is private; + -- with function Func (Formal : Outer_T) + -- return ... is <>; + + -- package Outer_Gen is + -- generic + -- type Inner_T is private; + -- with function Func (Formal : Inner_T) -- (1) + -- return ... is <>; + + -- package Inner_Gen is + -- function Inner_Func (Formal : Inner_T) -- (2) + -- return ... is (Func (Formal)); + -- end Inner_Gen; + -- end Outer_Generic; + + -- package Outer_Inst is new Outer_Gen (Actual_T); + -- package Inner_Inst is new Outer_Inst.Inner_Gen (Actual_T); + + -- In the example above, the type of parameter + -- Inner_Func.Formal at (2) is incompatible with the type of + -- Func.Formal at (1) in the context of instantiations + -- Outer_Inst and Inner_Inst. In reality both types are + -- generic actual subtypes renaming base type Actual_T as + -- part of the generic prologues for the instantiations. + + -- Recognize this case and add a type conversion to allow + -- this kind of generic actual subtype conformance. Note that + -- this is done only when the call is non-overloaded because + -- the resolution mechanism already has the means to + -- disambiguate similar cases. + + elsif not Is_Overloaded (Name (N)) + and then Is_Type (Etype (Actual)) + and then Is_Type (Etype (Formal)) + and then Is_Generic_Actual_Type (Etype (Actual)) + and then Is_Generic_Actual_Type (Etype (Formal)) + and then Base_Type (Etype (Actual)) = + Base_Type (Etype (Formal)) + then + Rewrite (Actual, + Convert_To (Etype (Formal), Relocate_Node (Actual))); + Analyze_And_Resolve (Actual, Etype (Formal)); + Next_Actual (Actual); + Next_Formal (Formal); + + -- Handle failed type check + else if Debug_Flag_E then Write_Str (" type checking fails in call "); diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 5ea25db3ee5..9738101d86c 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1752,6 +1752,14 @@ package body Sinfo is return Uint3 (N); end Intval; + function Is_Abort_Block + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement); + return Flag4 (N); + end Is_Abort_Block; + function Is_Accessibility_Actual (N : Node_Id) return Boolean is begin @@ -5015,6 +5023,14 @@ package body Sinfo is Set_Uint3 (N, Val); end Set_Intval; + procedure Set_Is_Abort_Block + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement); + Set_Flag4 (N, Val); + end Set_Is_Abort_Block; + procedure Set_Is_Accessibility_Actual (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 29feb256401..01d9be531d3 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1535,6 +1535,10 @@ package Sinfo is -- to the node for the spec of the instance, inserted as part of the -- semantic processing for instantiations in Sem_Ch12. + -- Is_Abort_Block (Flag4-Sem) + -- Present in N_Block_Statement nodes. True if the block protects a list + -- of statements with an Abort_Defer / Abort_Undefer_Direct pair. + -- Is_Accessibility_Actual (Flag13-Sem) -- Present in N_Parameter_Association nodes. True if the parameter is -- an extra actual that carries the accessibility level of the actual @@ -4937,6 +4941,7 @@ package Sinfo is -- Declarations (List2) (set to No_List if no DECLARE part) -- Handled_Statement_Sequence (Node4) -- Cleanup_Actions (List5-Sem) + -- Is_Abort_Block (Flag4-Sem) -- Is_Task_Master (Flag5-Sem) -- Activation_Chain_Entity (Node3-Sem) -- Has_Created_Identifier (Flag15) @@ -9331,6 +9336,9 @@ package Sinfo is function Intval (N : Node_Id) return Uint; -- Uint3 + function Is_Abort_Block + (N : Node_Id) return Boolean; -- Flag4 + function Is_Accessibility_Actual (N : Node_Id) return Boolean; -- Flag13 @@ -10375,6 +10383,9 @@ package Sinfo is procedure Set_Intval (N : Node_Id; Val : Uint); -- Uint3 + procedure Set_Is_Abort_Block + (N : Node_Id; Val : Boolean := True); -- Flag4 + procedure Set_Is_Accessibility_Actual (N : Node_Id; Val : Boolean := True); -- Flag13 @@ -12819,6 +12830,7 @@ package Sinfo is pragma Inline (Instance_Spec); pragma Inline (Intval); pragma Inline (Iterator_Specification); + pragma Inline (Is_Abort_Block); pragma Inline (Is_Accessibility_Actual); pragma Inline (Is_Analyzed_Pragma); pragma Inline (Is_Asynchronous_Call_Block); @@ -13162,6 +13174,7 @@ package Sinfo is pragma Inline (Set_Interface_List); pragma Inline (Set_Interface_Present); pragma Inline (Set_Intval); + pragma Inline (Set_Is_Abort_Block); pragma Inline (Set_Is_Accessibility_Actual); pragma Inline (Set_Is_Analyzed_Pragma); pragma Inline (Set_Is_Asynchronous_Call_Block); -- 2.30.2