[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>
|
2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
|
||||||
|
|
||||||
* einfo.adb Flag252 is now used as Is_Finalized_Transient. Flag295
|
* 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_Ch6; use Exp_Ch6;
|
||||||
with Exp_Ch7; use Exp_Ch7;
|
with Exp_Ch7; use Exp_Ch7;
|
||||||
with Exp_Ch9; use Exp_Ch9;
|
with Exp_Ch9; use Exp_Ch9;
|
||||||
with Exp_Ch11; use Exp_Ch11;
|
|
||||||
with Exp_Disp; use Exp_Disp;
|
with Exp_Disp; use Exp_Disp;
|
||||||
with Exp_Tss; use Exp_Tss;
|
with Exp_Tss; use Exp_Tss;
|
||||||
with Fname; use Fname;
|
with Fname; use Fname;
|
||||||
with Freeze; use Freeze;
|
with Freeze; use Freeze;
|
||||||
with Inline; use Inline;
|
|
||||||
with Itypes; use Itypes;
|
with Itypes; use Itypes;
|
||||||
with Lib; use Lib;
|
with Lib; use Lib;
|
||||||
with Namet; use Namet;
|
with Namet; use Namet;
|
||||||
|
@ -1121,10 +1119,39 @@ package body Exp_Aggr is
|
||||||
Init_Expr : Node_Id;
|
Init_Expr : Node_Id;
|
||||||
Stmts : List_Id)
|
Stmts : List_Id)
|
||||||
is
|
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);
|
Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
|
||||||
|
Blk_Stmts : List_Id;
|
||||||
Init_Stmt : Node_Id;
|
Init_Stmt : Node_Id;
|
||||||
|
|
||||||
begin
|
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:
|
-- Initialize the array element. Generate:
|
||||||
|
|
||||||
-- Arr_Comp := Init_Expr;
|
-- Arr_Comp := Init_Expr;
|
||||||
|
@ -1148,10 +1175,7 @@ package body Exp_Aggr is
|
||||||
-- Arr_Comp := Init_Expr;
|
-- Arr_Comp := Init_Expr;
|
||||||
-- end;
|
-- end;
|
||||||
|
|
||||||
if Present (Comp_Typ)
|
if Finalization_OK and then Is_Array_Type (Comp_Typ) then
|
||||||
and then Needs_Finalization (Comp_Typ)
|
|
||||||
and then Is_Array_Type (Comp_Typ)
|
|
||||||
then
|
|
||||||
Init_Stmt :=
|
Init_Stmt :=
|
||||||
Make_Block_Statement (Loc,
|
Make_Block_Statement (Loc,
|
||||||
Handled_Statement_Sequence =>
|
Handled_Statement_Sequence =>
|
||||||
|
@ -1159,7 +1183,7 @@ package body Exp_Aggr is
|
||||||
Statements => New_List (Init_Stmt)));
|
Statements => New_List (Init_Stmt)));
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Append_To (Stmts, Init_Stmt);
|
Append_To (Blk_Stmts, Init_Stmt);
|
||||||
|
|
||||||
-- Adjust the tag due to a possible view conversion. Generate:
|
-- 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 Present (Comp_Typ)
|
||||||
and then Is_Tagged_Type (Comp_Typ)
|
and then Is_Tagged_Type (Comp_Typ)
|
||||||
then
|
then
|
||||||
Append_To (Stmts,
|
Append_To (Blk_Stmts,
|
||||||
Make_OK_Assignment_Statement (Loc,
|
Make_OK_Assignment_Statement (Loc,
|
||||||
Name =>
|
Name =>
|
||||||
Make_Selected_Component (Loc,
|
Make_Selected_Component (Loc,
|
||||||
|
@ -1191,19 +1215,54 @@ package body Exp_Aggr is
|
||||||
|
|
||||||
-- [Deep_]Adjust (Arr_Comp);
|
-- [Deep_]Adjust (Arr_Comp);
|
||||||
|
|
||||||
if Present (Comp_Typ)
|
if Finalization_OK
|
||||||
and then Needs_Finalization (Comp_Typ)
|
|
||||||
and then not Is_Limited_Type (Comp_Typ)
|
and then not Is_Limited_Type (Comp_Typ)
|
||||||
and then not
|
and then not
|
||||||
(Is_Array_Type (Comp_Typ)
|
(Is_Array_Type (Comp_Typ)
|
||||||
and then Is_Controlled (Component_Type (Comp_Typ))
|
and then Is_Controlled (Component_Type (Comp_Typ))
|
||||||
and then Nkind (Expr) = N_Aggregate)
|
and then Nkind (Expr) = N_Aggregate)
|
||||||
then
|
then
|
||||||
Append_To (Stmts,
|
Append_To (Blk_Stmts,
|
||||||
Make_Adjust_Call
|
Make_Adjust_Call
|
||||||
(Obj_Ref => New_Copy_Tree (Arr_Comp),
|
(Obj_Ref => New_Copy_Tree (Arr_Comp),
|
||||||
Typ => Comp_Typ));
|
Typ => Comp_Typ));
|
||||||
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;
|
end Initialize_Array_Component;
|
||||||
|
|
||||||
-------------------------------------
|
-------------------------------------
|
||||||
|
@ -2772,10 +2831,36 @@ package body Exp_Aggr is
|
||||||
Init_Expr : Node_Id;
|
Init_Expr : Node_Id;
|
||||||
Stmts : List_Id)
|
Stmts : List_Id)
|
||||||
is
|
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);
|
Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
|
||||||
|
Blk_Stmts : List_Id;
|
||||||
Init_Stmt : Node_Id;
|
Init_Stmt : Node_Id;
|
||||||
|
|
||||||
begin
|
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:
|
-- Initialize the record component. Generate:
|
||||||
|
|
||||||
-- Rec_Comp := Init_Expr;
|
-- Rec_Comp := Init_Expr;
|
||||||
|
@ -2789,14 +2874,14 @@ package body Exp_Aggr is
|
||||||
Expression => Init_Expr);
|
Expression => Init_Expr);
|
||||||
Set_No_Ctrl_Actions (Init_Stmt);
|
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:
|
-- Adjust the tag due to a possible view conversion. Generate:
|
||||||
|
|
||||||
-- Rec_Comp._tag := Full_TypeP;
|
-- Rec_Comp._tag := Full_TypeP;
|
||||||
|
|
||||||
if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then
|
if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then
|
||||||
Append_To (Stmts,
|
Append_To (Blk_Stmts,
|
||||||
Make_OK_Assignment_Statement (Loc,
|
Make_OK_Assignment_Statement (Loc,
|
||||||
Name =>
|
Name =>
|
||||||
Make_Selected_Component (Loc,
|
Make_Selected_Component (Loc,
|
||||||
|
@ -2816,14 +2901,48 @@ package body Exp_Aggr is
|
||||||
|
|
||||||
-- [Deep_]Adjust (Rec_Comp);
|
-- [Deep_]Adjust (Rec_Comp);
|
||||||
|
|
||||||
if Needs_Finalization (Comp_Typ)
|
if Finalization_OK and then not Is_Limited_Type (Comp_Typ) then
|
||||||
and then not Is_Limited_Type (Comp_Typ)
|
Append_To (Blk_Stmts,
|
||||||
then
|
|
||||||
Append_To (Stmts,
|
|
||||||
Make_Adjust_Call
|
Make_Adjust_Call
|
||||||
(Obj_Ref => New_Copy_Tree (Rec_Comp),
|
(Obj_Ref => New_Copy_Tree (Rec_Comp),
|
||||||
Typ => Comp_Typ));
|
Typ => Comp_Typ));
|
||||||
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;
|
end Initialize_Record_Component;
|
||||||
|
|
||||||
-------------------------
|
-------------------------
|
||||||
|
@ -7804,43 +7923,22 @@ package body Exp_Aggr is
|
||||||
-- Hook := null;
|
-- Hook := null;
|
||||||
-- [Deep_]Finalize (Res.all);
|
-- [Deep_]Finalize (Res.all);
|
||||||
-- at end
|
-- at end
|
||||||
-- Abort_Undefer;
|
-- Abort_Undefer_Direct;
|
||||||
-- end;
|
-- end;
|
||||||
|
|
||||||
elsif Abort_Allowed then
|
elsif Abort_Allowed then
|
||||||
Abort_Only : declare
|
Abort_Only : declare
|
||||||
Blk_Stmts : constant List_Id := New_List;
|
Blk_Stmts : constant List_Id := New_List;
|
||||||
|
|
||||||
AUD : Entity_Id;
|
|
||||||
Blk : Node_Id;
|
|
||||||
Blk_HSS : Node_Id;
|
|
||||||
Blk_Id : Entity_Id;
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
|
Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
|
||||||
Append_To (Blk_Stmts, Hook_Clear);
|
Append_To (Blk_Stmts, Hook_Clear);
|
||||||
Append_To (Blk_Stmts, Fin_Call);
|
Append_To (Blk_Stmts, Fin_Call);
|
||||||
|
|
||||||
AUD := RTE (RE_Abort_Undefer_Direct);
|
Append_To (Stmts,
|
||||||
|
Build_Abort_Undefer_Block (Loc,
|
||||||
Blk_HSS :=
|
Stmts => Blk_Stmts,
|
||||||
Make_Handled_Sequence_Of_Statements (Loc,
|
Context => Aggr));
|
||||||
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);
|
|
||||||
end Abort_Only;
|
end Abort_Only;
|
||||||
|
|
||||||
-- Otherwise generate:
|
-- Otherwise generate:
|
||||||
|
|
|
@ -34,7 +34,6 @@ with Exp_Ch4; use Exp_Ch4;
|
||||||
with Exp_Ch6; use Exp_Ch6;
|
with Exp_Ch6; use Exp_Ch6;
|
||||||
with Exp_Ch7; use Exp_Ch7;
|
with Exp_Ch7; use Exp_Ch7;
|
||||||
with Exp_Ch9; use Exp_Ch9;
|
with Exp_Ch9; use Exp_Ch9;
|
||||||
with Exp_Ch11; use Exp_Ch11;
|
|
||||||
with Exp_Dbug; use Exp_Dbug;
|
with Exp_Dbug; use Exp_Dbug;
|
||||||
with Exp_Disp; use Exp_Disp;
|
with Exp_Disp; use Exp_Disp;
|
||||||
with Exp_Dist; use Exp_Dist;
|
with Exp_Dist; use Exp_Dist;
|
||||||
|
@ -44,7 +43,6 @@ with Exp_Tss; use Exp_Tss;
|
||||||
with Exp_Util; use Exp_Util;
|
with Exp_Util; use Exp_Util;
|
||||||
with Freeze; use Freeze;
|
with Freeze; use Freeze;
|
||||||
with Ghost; use Ghost;
|
with Ghost; use Ghost;
|
||||||
with Inline; use Inline;
|
|
||||||
with Namet; use Namet;
|
with Namet; use Namet;
|
||||||
with Nlists; use Nlists;
|
with Nlists; use Nlists;
|
||||||
with Nmake; use Nmake;
|
with Nmake; use Nmake;
|
||||||
|
@ -5519,16 +5517,12 @@ package body Exp_Ch3 is
|
||||||
Exceptions_OK : constant Boolean :=
|
Exceptions_OK : constant Boolean :=
|
||||||
not Restriction_Active (No_Exception_Propagation);
|
not Restriction_Active (No_Exception_Propagation);
|
||||||
|
|
||||||
Abrt_Blk : Node_Id;
|
Aggr_Init : Node_Id;
|
||||||
Abrt_Blk_Id : Entity_Id;
|
Comp_Init : List_Id := No_List;
|
||||||
Abrt_HSS : Node_Id;
|
Fin_Call : Node_Id;
|
||||||
Aggr_Init : Node_Id;
|
Init_Stmts : List_Id := No_List;
|
||||||
AUD : Entity_Id;
|
Obj_Init : Node_Id := Empty;
|
||||||
Comp_Init : List_Id := No_List;
|
Obj_Ref : Node_Id;
|
||||||
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
|
-- Start of processing for Default_Initialize_Object
|
||||||
|
|
||||||
|
@ -5726,26 +5720,10 @@ package body Exp_Ch3 is
|
||||||
-- end;
|
-- end;
|
||||||
|
|
||||||
if Exceptions_OK then
|
if Exceptions_OK then
|
||||||
AUD := RTE (RE_Abort_Undefer_Direct);
|
Init_Stmts := New_List (
|
||||||
|
Build_Abort_Undefer_Block (Loc,
|
||||||
Abrt_HSS :=
|
Stmts => Init_Stmts,
|
||||||
Make_Handled_Sequence_Of_Statements (Loc,
|
Context => N));
|
||||||
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);
|
|
||||||
|
|
||||||
-- Otherwise exceptions are not propagated. Generate:
|
-- Otherwise exceptions are not propagated. Generate:
|
||||||
|
|
||||||
|
|
|
@ -2371,6 +2371,8 @@ package body Exp_Ch5 is
|
||||||
AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
|
AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
Set_Is_Abort_Block (N);
|
||||||
|
|
||||||
Set_Scope (Blk, Current_Scope);
|
Set_Scope (Blk, Current_Scope);
|
||||||
Set_Etype (Blk, Standard_Void_Type);
|
Set_Etype (Blk, Standard_Void_Type);
|
||||||
Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
|
Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
|
||||||
|
|
|
@ -13217,17 +13217,30 @@ package body Exp_Ch9 is
|
||||||
-- package or return statement.
|
-- package or return statement.
|
||||||
|
|
||||||
Context := Parent (N);
|
Context := Parent (N);
|
||||||
while not Nkind_In (Context, N_Block_Statement,
|
while Present (Context) loop
|
||||||
N_Entry_Body,
|
if Nkind_In (Context, N_Entry_Body,
|
||||||
N_Extended_Return_Statement,
|
N_Extended_Return_Statement,
|
||||||
N_Package_Body,
|
N_Package_Body,
|
||||||
N_Package_Declaration,
|
N_Package_Declaration,
|
||||||
N_Subprogram_Body,
|
N_Subprogram_Body,
|
||||||
N_Task_Body)
|
N_Task_Body)
|
||||||
loop
|
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);
|
Context := Parent (Context);
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
|
pragma Assert (Present (Context));
|
||||||
|
|
||||||
-- Extract the constituents of the context
|
-- Extract the constituents of the context
|
||||||
|
|
||||||
if Nkind (Context) = N_Extended_Return_Statement then
|
if Nkind (Context) = N_Extended_Return_Statement then
|
||||||
|
@ -13258,8 +13271,6 @@ package body Exp_Ch9 is
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
else
|
else
|
||||||
Context_Decls := Declarations (Context);
|
|
||||||
|
|
||||||
if Nkind (Context) = N_Block_Statement then
|
if Nkind (Context) = N_Block_Statement then
|
||||||
Context_Id := Entity (Identifier (Context));
|
Context_Id := Entity (Identifier (Context));
|
||||||
|
|
||||||
|
@ -13283,9 +13294,10 @@ package body Exp_Ch9 is
|
||||||
else
|
else
|
||||||
raise Program_Error;
|
raise Program_Error;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
Context_Decls := Declarations (Context);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
pragma Assert (Present (Context));
|
|
||||||
pragma Assert (Present (Context_Id));
|
pragma Assert (Present (Context_Id));
|
||||||
pragma Assert (Present (Context_Decls));
|
pragma Assert (Present (Context_Decls));
|
||||||
end Find_Enclosing_Context;
|
end Find_Enclosing_Context;
|
||||||
|
|
|
@ -34,6 +34,7 @@ with Errout; use Errout;
|
||||||
with Exp_Aggr; use Exp_Aggr;
|
with Exp_Aggr; use Exp_Aggr;
|
||||||
with Exp_Ch6; use Exp_Ch6;
|
with Exp_Ch6; use Exp_Ch6;
|
||||||
with Exp_Ch7; use Exp_Ch7;
|
with Exp_Ch7; use Exp_Ch7;
|
||||||
|
with Exp_Ch11; use Exp_Ch11;
|
||||||
with Ghost; use Ghost;
|
with Ghost; use Ghost;
|
||||||
with Inline; use Inline;
|
with Inline; use Inline;
|
||||||
with Itypes; use Itypes;
|
with Itypes; use Itypes;
|
||||||
|
@ -724,7 +725,7 @@ package body Exp_Util is
|
||||||
-- For deallocation of class-wide types we obtain the value of
|
-- For deallocation of class-wide types we obtain the value of
|
||||||
-- alignment from the Type Specific Record of the deallocated object.
|
-- alignment from the Type Specific Record of the deallocated object.
|
||||||
-- This is needed because the frontend expansion of class-wide types
|
-- 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
|
else
|
||||||
-- Generate:
|
-- Generate:
|
||||||
|
@ -930,6 +931,59 @@ package body Exp_Util is
|
||||||
end;
|
end;
|
||||||
end Build_Allocate_Deallocate_Proc;
|
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 --
|
-- Build_Procedure_Form --
|
||||||
--------------------------
|
--------------------------
|
||||||
|
@ -2441,7 +2495,7 @@ package body Exp_Util is
|
||||||
-- If the type of the expression is an internally generated type it
|
-- 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
|
-- may not be necessary to create a new subtype. However there are two
|
||||||
-- exceptions: references to the current instances, and aliased array
|
-- 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)
|
elsif Is_Constrained (Exp_Typ)
|
||||||
and then not Is_Class_Wide_Type (Unc_Type)
|
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
|
-- Note on checks that could raise Constraint_Error. Strictly, if we
|
||||||
-- take advantage of 11.6, these checks do not count as side effects.
|
-- take advantage of 11.6, these checks do not count as side effects.
|
||||||
-- However, we would prefer to consider that they are 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
|
-- 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
|
-- them to be side effect free, then we get some awkward expansions
|
||||||
-- in -gnato mode, resulting in code insertions at a point where we
|
-- 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
|
-- must be a free statement. If flag Is_Allocate is set, the generated
|
||||||
-- routine is allocate, deallocate otherwise.
|
-- 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);
|
procedure Build_Procedure_Form (N : Node_Id);
|
||||||
-- Create a procedure declaration which emulates the behavior of a function
|
-- Create a procedure declaration which emulates the behavior of a function
|
||||||
-- that returns an array type, for C-compatible generation.
|
-- that returns an array type, for C-compatible generation.
|
||||||
|
|
|
@ -3480,6 +3480,61 @@ package body Sem_Ch4 is
|
||||||
Next_Actual (Actual);
|
Next_Actual (Actual);
|
||||||
Next_Formal (Formal);
|
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
|
else
|
||||||
if Debug_Flag_E then
|
if Debug_Flag_E then
|
||||||
Write_Str (" type checking fails in call ");
|
Write_Str (" type checking fails in call ");
|
||||||
|
|
|
@ -1752,6 +1752,14 @@ package body Sinfo is
|
||||||
return Uint3 (N);
|
return Uint3 (N);
|
||||||
end Intval;
|
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
|
function Is_Accessibility_Actual
|
||||||
(N : Node_Id) return Boolean is
|
(N : Node_Id) return Boolean is
|
||||||
begin
|
begin
|
||||||
|
@ -5015,6 +5023,14 @@ package body Sinfo is
|
||||||
Set_Uint3 (N, Val);
|
Set_Uint3 (N, Val);
|
||||||
end Set_Intval;
|
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
|
procedure Set_Is_Accessibility_Actual
|
||||||
(N : Node_Id; Val : Boolean := True) is
|
(N : Node_Id; Val : Boolean := True) is
|
||||||
begin
|
begin
|
||||||
|
|
|
@ -1535,6 +1535,10 @@ package Sinfo is
|
||||||
-- to the node for the spec of the instance, inserted as part of the
|
-- to the node for the spec of the instance, inserted as part of the
|
||||||
-- semantic processing for instantiations in Sem_Ch12.
|
-- 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)
|
-- Is_Accessibility_Actual (Flag13-Sem)
|
||||||
-- Present in N_Parameter_Association nodes. True if the parameter is
|
-- Present in N_Parameter_Association nodes. True if the parameter is
|
||||||
-- an extra actual that carries the accessibility level of the actual
|
-- 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)
|
-- Declarations (List2) (set to No_List if no DECLARE part)
|
||||||
-- Handled_Statement_Sequence (Node4)
|
-- Handled_Statement_Sequence (Node4)
|
||||||
-- Cleanup_Actions (List5-Sem)
|
-- Cleanup_Actions (List5-Sem)
|
||||||
|
-- Is_Abort_Block (Flag4-Sem)
|
||||||
-- Is_Task_Master (Flag5-Sem)
|
-- Is_Task_Master (Flag5-Sem)
|
||||||
-- Activation_Chain_Entity (Node3-Sem)
|
-- Activation_Chain_Entity (Node3-Sem)
|
||||||
-- Has_Created_Identifier (Flag15)
|
-- Has_Created_Identifier (Flag15)
|
||||||
|
@ -9331,6 +9336,9 @@ package Sinfo is
|
||||||
function Intval
|
function Intval
|
||||||
(N : Node_Id) return Uint; -- Uint3
|
(N : Node_Id) return Uint; -- Uint3
|
||||||
|
|
||||||
|
function Is_Abort_Block
|
||||||
|
(N : Node_Id) return Boolean; -- Flag4
|
||||||
|
|
||||||
function Is_Accessibility_Actual
|
function Is_Accessibility_Actual
|
||||||
(N : Node_Id) return Boolean; -- Flag13
|
(N : Node_Id) return Boolean; -- Flag13
|
||||||
|
|
||||||
|
@ -10375,6 +10383,9 @@ package Sinfo is
|
||||||
procedure Set_Intval
|
procedure Set_Intval
|
||||||
(N : Node_Id; Val : Uint); -- Uint3
|
(N : Node_Id; Val : Uint); -- Uint3
|
||||||
|
|
||||||
|
procedure Set_Is_Abort_Block
|
||||||
|
(N : Node_Id; Val : Boolean := True); -- Flag4
|
||||||
|
|
||||||
procedure Set_Is_Accessibility_Actual
|
procedure Set_Is_Accessibility_Actual
|
||||||
(N : Node_Id; Val : Boolean := True); -- Flag13
|
(N : Node_Id; Val : Boolean := True); -- Flag13
|
||||||
|
|
||||||
|
@ -12819,6 +12830,7 @@ package Sinfo is
|
||||||
pragma Inline (Instance_Spec);
|
pragma Inline (Instance_Spec);
|
||||||
pragma Inline (Intval);
|
pragma Inline (Intval);
|
||||||
pragma Inline (Iterator_Specification);
|
pragma Inline (Iterator_Specification);
|
||||||
|
pragma Inline (Is_Abort_Block);
|
||||||
pragma Inline (Is_Accessibility_Actual);
|
pragma Inline (Is_Accessibility_Actual);
|
||||||
pragma Inline (Is_Analyzed_Pragma);
|
pragma Inline (Is_Analyzed_Pragma);
|
||||||
pragma Inline (Is_Asynchronous_Call_Block);
|
pragma Inline (Is_Asynchronous_Call_Block);
|
||||||
|
@ -13162,6 +13174,7 @@ package Sinfo is
|
||||||
pragma Inline (Set_Interface_List);
|
pragma Inline (Set_Interface_List);
|
||||||
pragma Inline (Set_Interface_Present);
|
pragma Inline (Set_Interface_Present);
|
||||||
pragma Inline (Set_Intval);
|
pragma Inline (Set_Intval);
|
||||||
|
pragma Inline (Set_Is_Abort_Block);
|
||||||
pragma Inline (Set_Is_Accessibility_Actual);
|
pragma Inline (Set_Is_Accessibility_Actual);
|
||||||
pragma Inline (Set_Is_Analyzed_Pragma);
|
pragma Inline (Set_Is_Analyzed_Pragma);
|
||||||
pragma Inline (Set_Is_Asynchronous_Call_Block);
|
pragma Inline (Set_Is_Asynchronous_Call_Block);
|
||||||
|
|
Loading…
Reference in New Issue