[multiple changes]
2016-07-06 Hristian Kirtchev <kirtchev@adacore.com> * 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 <squirek@adacore.com> * sem_ch4.adb (Analyze_One_Call): Add a conditional to handle disambiguation. From-SVN: r238045
This commit is contained in:
parent
937e96763e
commit
bb072d1c17
|
@ -1,3 +1,37 @@
|
|||
2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
|
||||
|
||||
* 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 <squirek@adacore.com>
|
||||
|
||||
* sem_ch4.adb (Analyze_One_Call): Add a conditional to handle
|
||||
disambiguation.
|
||||
|
||||
2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
|
||||
|
||||
* einfo.adb Flag252 is now used as Is_Finalized_Transient. Flag295
|
||||
|
|
|
@ -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:
|
||||
|
|
|
@ -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:
|
||||
|
||||
|
|
|
@ -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)));
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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
|
||||
-- <Stmts>
|
||||
-- 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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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 ");
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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);
|
||||
|
|
Loading…
Reference in New Issue