Skip to content

R
riscv-gcc-1
Commit 7bf911b5 by Hristian Kirtchev Committed by Arnaud Charlet
Options

re PR ada/66242 (Front-end error if exception propagation disabled) 

2015-11-18  Hristian Kirtchev  <kirtchev@adacore.com>

	PR ada/66242

	* exp_ch3.adb (Default_Initialize_Object): Reimplemented. Abort
	defer / undefer pairs are now encapsulated in a block with
	an AT END handler. Partial finalization now takes restriction
	No_Exception_Propagation into account when generating blocks.
	* exp_ch7.adb Various reformattings.
	(Create_Finalizer): Change
	the generation of abort defer / undefer pairs and explain the
	lack of an AT END handler.
	(Process_Transient_Objects): Add generation of abort defer/undefer
	pairs.
	* exp_ch9.adb Various reformattings.
	(Build_Protected_Subprogram_Body): Use
	Build_Runtime_Call to construct a call to Abort_Defer.
	(Build_Protected_Subprogram_Call_Cleanup): Use
	Build_Runtime_Call to construct a call to Abort_Undefer.
	(Expand_N_Asynchronous_Select): Use Build_Runtime_Call to
	construct a call to Abort_Defer.
	* exp_intr.adb (Expand_Unc_Deallocation): Abort defer
	/ undefer pairs are now encapsulated in a block with
	an AT END handler. Finalization now takes restriction
	No_Exception_Propagation into account when generating blocks.
	* exp_util.ads, exp_util.adb (Wrap_Cleanup_Procedure): Removed.

From-SVN: r230531
parent 8ebcad86
Showing with 286 additions and 355 deletions
gcc/ada/exp_ch3.adb
......@@ -201,9 +201,9 @@ package body Exp_Ch3 is
-- subprogram they rename is not frozen when the type is frozen.
procedure Insert_Component_Invariant_Checks
(N : Node_Id;
Typ : Entity_Id;
Proc : Node_Id);
(N : Node_Id;
Typ : Entity_Id;
Proc : Node_Id);
-- If a composite type has invariants and also has components with defined
-- invariants. the component invariant procedure is inserted into the user-
-- defined invariant procedure and added to the checks to be performed.
......@@ -5197,8 +5197,8 @@ package body Exp_Ch3 is
if Ekind (Comp) = E_Component
and then Chars (Comp) = Chars (Old_Comp)
then
Set_Discriminant_Checking_Func (Comp,
Discriminant_Checking_Func (Old_Comp));
Set_Discriminant_Checking_Func
(Comp, Discriminant_Checking_Func (Old_Comp));
end if;
Next_Component (Old_Comp);
......@@ -6083,20 +6083,19 @@ package body Exp_Ch3 is
-- Local variables
Abrt_Blk : Node_Id;
Abrt_HSS : Node_Id;
Abrt_Id : Entity_Id;
Abrt_Stmts : List_Id;
Aggr_Init : Node_Id;
Comp_Init : List_Id := No_List;
Fin_Call : Node_Id;
Fin_Stmts : List_Id := No_List;
Obj_Init : Node_Id := Empty;
Obj_Ref : Node_Id;
Dummy : Entity_Id;
-- This variable captures a dummy internal entity, see the comment
-- associated with its use.
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;
-- Start of processing for Default_Initialize_Object
......@@ -6112,19 +6111,25 @@ package body Exp_Ch3 is
return;
end if;
-- Step 1: Initialize the object
-- The expansion performed by this routine is as follows:
if Needs_Finalization (Typ) and then not No_Initialization (N) then
Obj_Init :=
Make_Init_Call
(Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
Typ => Typ);
end if;
-- Step 2: Initialize the components of the object
-- begin
-- Abort_Defer;
-- Type_Init_Proc (Obj);
-- begin
-- [Deep_]Initialize (Obj);
-- exception
-- when others =>
-- [Deep_]Finalize (Obj, Self => False);
-- raise;
-- end;
-- at end
-- Abort_Undefer_Direct;
-- end;
-- Do not initialize the components if their initialization is
-- prohibited.
-- Initialize the components of the object
if Has_Non_Null_Base_Init_Proc (Typ)
and then not No_Initialization (N)
......@@ -6154,7 +6159,8 @@ package body Exp_Ch3 is
elsif Build_Equivalent_Aggregate then
null;
-- Otherwise invoke the type init proc
-- Otherwise invoke the type init proc, generate:
-- Type_Init_Proc (Obj);
else
Obj_Ref := New_Object_Reference;
......@@ -6182,41 +6188,35 @@ package body Exp_Ch3 is
Analyze_And_Resolve (Expression (N), Typ);
end if;
-- Step 3: Add partial finalization and abort actions, generate:
-- Initialize the object, generate:
-- [Deep_]Initialize (Obj);
if Needs_Finalization (Typ) and then not No_Initialization (N) then
Obj_Init :=
Make_Init_Call
(Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
Typ => Typ);
end if;
-- Build a special finalization block when both the object and its
-- controlled components are to be initialized. The block finalizes
-- the components if the object initialization fails. Generate:
-- Type_Init_Proc (Obj);
-- begin
-- Deep_Initialize (Obj);
-- <Obj_Init>
-- exception
-- when others =>
-- Deep_Finalize (Obj, Self => False);
-- <Fin_Call>
-- raise;
-- end;
-- Step 3a: Build the finalization block (if applicable)
-- The finalization block is required when both the object and its
-- controlled components are to be initialized. The block finalizes
-- the components if the object initialization fails.
if Has_Controlled_Component (Typ)
and then Present (Comp_Init)
and then Present (Obj_Init)
and then not Restriction_Active (No_Exception_Propagation)
and then Exceptions_OK
then
-- Generate:
-- Type_Init_Proc (Obj);
Fin_Stmts := Comp_Init;
-- Generate:
-- begin
-- Deep_Initialize (Obj);
-- exception
-- when others =>
-- Deep_Finalize (Obj, Self => False);
-- raise;
-- end;
Init_Stmts := Comp_Init;
Fin_Call :=
Make_Final_Call
......@@ -6232,7 +6232,7 @@ package body Exp_Ch3 is
Set_No_Elaboration_Check (Fin_Call);
Append_To (Fin_Stmts,
Append_To (Init_Stmts,
Make_Block_Statement (Loc,
Declarations => No_List,
......@@ -6250,100 +6250,93 @@ package body Exp_Ch3 is
Make_Raise_Statement (Loc)))))));
end if;
-- Finalization is not required, the initialization calls are passed
-- to the abort block building circuitry, generate:
-- Otherwise finalization is not required, the initialization calls
-- are passed to the abort block building circuitry, generate:
-- Type_Init_Proc (Obj);
-- Deep_Initialize (Obj);
-- [Deep_]Initialize (Obj);
else
if Present (Comp_Init) then
Fin_Stmts := Comp_Init;
Init_Stmts := Comp_Init;
end if;
if Present (Obj_Init) then
if No (Fin_Stmts) then
Fin_Stmts := New_List;
if No (Init_Stmts) then
Init_Stmts := New_List;
end if;
Append_To (Fin_Stmts, Obj_Init);
Append_To (Init_Stmts, Obj_Init);
end if;
end if;
-- Step 3b: Build the abort block (if applicable)
-- The abort block is required when aborts are allowed in order to
-- protect both initialization calls.
if Present (Comp_Init) and then Present (Obj_Init) then
if Abort_Allowed then
-- Generate:
-- Abort_Defer;
-- Build an abort block to protect the initialization calls
Prepend_To
(Fin_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
if Abort_Allowed
and then Present (Comp_Init)
and then Present (Obj_Init)
then
-- Generate:
-- Abort_Defer;
-- Generate:
-- begin
-- Abort_Defer;
-- <finalization statements>
-- at end
-- Abort_Undefer_Direct;
-- end;
Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
declare
AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
-- When exceptions are propagated, abort deferral must take place
-- in the presence of initialization or finalization exceptions.
-- Generate:
begin
Abrt_HSS :=
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Fin_Stmts,
At_End_Proc => New_Occurrence_Of (AUD, Loc));
-- begin
-- Abort_Defer;
-- <Init_Stmts>
-- at end
-- Abort_Undefer_Direct;
-- end;
-- Present the Abort_Undefer_Direct function to the backend
-- so that it can inline the call to the function.
if Exceptions_OK then
AUD := RTE (RE_Abort_Undefer_Direct);
Add_Inlined_Body (AUD, N);
end;
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,
Declarations => No_List,
Handled_Statement_Sequence => Abrt_HSS);
Add_Block_Identifier (Abrt_Blk, Abrt_Id);
Expand_At_End_Handler (Abrt_HSS, Abrt_Id);
Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id);
Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id);
Abrt_Stmts := New_List (Abrt_Blk);
-- Present the Abort_Undefer_Direct function to the backend so
-- that it can inline the call to the function.
-- Abort is not required
Add_Inlined_Body (AUD, N);
else
-- Generate a dummy entity to ensure that the internal symbols
-- are in sync when a unit is compiled with and without aborts.
-- The entity is a block with proper scope and type.
Init_Stmts := New_List (Abrt_Blk);
Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
Set_Etype (Dummy, Standard_Void_Type);
Abrt_Stmts := Fin_Stmts;
end if;
-- Otherwise exceptions are not propagated. Generate:
-- No initialization calls present
-- Abort_Defer;
-- <Init_Stmts>
-- Abort_Undefer;
else
Abrt_Stmts := Fin_Stmts;
else
Append_To (Init_Stmts,
Build_Runtime_Call (Loc, RE_Abort_Undefer));
end if;
end if;
-- Step 4: Insert the whole initialization sequence into the tree
-- If the object has a delayed freeze, as will be the case when
-- it has aspect specifications, the initialization sequence is
-- part of the freeze actions.
-- Insert the whole initialization sequence into the tree. If the
-- object has a delayed freeze, as will be the case when it has
-- aspect specifications, the initialization sequence is part of
-- the freeze actions.
if Has_Delayed_Freeze (Def_Id) then
Append_Freeze_Actions (Def_Id, Abrt_Stmts);
else
Insert_Actions_After (After, Abrt_Stmts);
if Present (Init_Stmts) then
if Has_Delayed_Freeze (Def_Id) then
Append_Freeze_Actions (Def_Id, Init_Stmts);
else
Insert_Actions_After (After, Init_Stmts);
end if;
end if;
end Default_Initialize_Object;
......
gcc/ada/exp_ch7.adb
......@@ -1323,13 +1323,6 @@ package body Exp_Ch7 is
----------------------
procedure Create_Finalizer is
Body_Id : Entity_Id;
Fin_Body : Node_Id;
Fin_Spec : Node_Id;
Jump_Block : Node_Id;
Label : Node_Id;
Label_Id : Entity_Id;
function New_Finalizer_Name return Name_Id;
-- Create a fully qualified name of a package spec or body finalizer.
-- The generated name is of the form: xx__yy__finalize_[spec|body].
......@@ -1380,6 +1373,15 @@ package body Exp_Ch7 is
return Name_Find;
end New_Finalizer_Name;
-- Local variables
Body_Id : Entity_Id;
Fin_Body : Node_Id;
Fin_Spec : Node_Id;
Jump_Block : Node_Id;
Label : Node_Id;
Label_Id : Entity_Id;
-- Start of processing for Create_Finalizer
begin
......@@ -1532,16 +1534,17 @@ package body Exp_Ch7 is
-- Protect the statements with abort defer/undefer. This is only when
-- aborts are allowed and the clean up statements require deferral or
-- there are controlled objects to be finalized.
-- there are controlled objects to be finalized. Note that the abort
-- defer/undefer pair does not require an extra block because each
-- finalization exception is caught in its corresponding finalization
-- block. As a result, the call to Abort_Defer always takes place.
if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then
Prepend_To (Finalizer_Stmts,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc)));
Build_Runtime_Call (Loc, RE_Abort_Defer));
Append_To (Finalizer_Stmts,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc)));
Build_Runtime_Call (Loc, RE_Abort_Undefer));
end if;
-- The local exception does not need to be reraised for library-level
......@@ -1596,7 +1599,8 @@ package body Exp_Ch7 is
Defining_Unit_Name => Body_Id),
Declarations => Finalizer_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Finalizer_Stmts));
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Finalizer_Stmts));
-- Step 4: Spec and body insertion, analysis
......@@ -2806,9 +2810,7 @@ package body Exp_Ch7 is
else
-- Generate:
-- [Deep_]Finalize (Obj); -- No_Exception_Propagation
-- begin -- Exception handlers allowed
-- begin
-- [Deep_]Finalize (Obj);
-- exception
......@@ -4727,6 +4729,8 @@ package body Exp_Ch7 is
-- Raised : Boolean := False;
-- begin
-- Abort_Defer;
-- begin
-- Hook_N := null;
-- [Deep_]Finalize (Ctrl_Trans_Obj_N);
......@@ -4752,26 +4756,8 @@ package body Exp_Ch7 is
-- if Raised and not Abrt then
-- Raise_From_Controlled_Operation (Ex);
-- end if;
-- end;
-- When restriction No_Exception_Propagation is active, the expansion
-- is as follows:
-- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
-- Hook_1 : Ptr_Typ_1 := null;
-- Ctrl_Trans_Obj_1 : ...;
-- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
-- . . .
-- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
-- Hook_N : Ptr_Typ_N := null;
-- Ctrl_Trans_Obj_N : ...;
-- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
-- begin
-- Hook_N := null;
-- [Deep_]Finalize (Ctrl_Trans_Obj_N);
-- Hook_1 := null;
-- [Deep_]Finalize (Ctrl_Trans_Obj_1);
-- Abort_Undefer_Direct;
-- end;
-- Recognize a scenario where the transient context is an object
......@@ -4983,6 +4969,7 @@ package body Exp_Ch7 is
-- When exception propagation is enabled wrap the hook clear
-- statement and the finalization call into a block to catch
-- potential exceptions raised during finalization. Generate:
-- begin
-- [Temp := null;]
-- [Deep_]Finalize (Obj_Ref);
......@@ -5037,6 +5024,20 @@ package body Exp_Ch7 is
end loop;
if Present (Blk_Decl) then
-- Note that the abort defer / undefer pair does not require an
-- extra block because each finalization exception is caught in
-- its corresponding finalization block. As a result, the call to
-- Abort_Defer always takes place.
if Abort_Allowed then
Prepend_To (Blk_Stmts,
Build_Runtime_Call (Loc, RE_Abort_Defer));
Append_To (Blk_Stmts,
Build_Runtime_Call (Loc, RE_Abort_Undefer));
end if;
Insert_After_And_Analyze (Blk_Ins, Blk_Decl);
end if;
end Process_Transient_Objects;
......@@ -5428,10 +5429,13 @@ package body Exp_Ch7 is
function Build_Adjust_Or_Finalize_Statements
(Typ : Entity_Id) return List_Id
is
Comp_Typ : constant Entity_Id := Component_Type (Typ);
Index_List : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (Typ);
Num_Dims : constant Int := Number_Dimensions (Typ);
Comp_Typ : constant Entity_Id := Component_Type (Typ);
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Index_List : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (Typ);
Num_Dims : constant Int := Number_Dimensions (Typ);
Finalizer_Decls : List_Id := No_List;
Finalizer_Data : Finalization_Exception_Data;
Call : Node_Id;
......@@ -5442,9 +5446,6 @@ package body Exp_Ch7 is
Loop_Id : Entity_Id;
Stmts : List_Id;
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
procedure Build_Indexes;
-- Generate the indexes used in the dimension loops
......@@ -5492,9 +5493,7 @@ package body Exp_Ch7 is
-- Generate the block which houses the adjust or finalize call:
-- <adjust or finalize call>; -- No_Exception_Propagation
-- begin -- Exception handlers allowed
-- begin
-- <adjust or finalize call>
-- exception
......@@ -5567,7 +5566,7 @@ package body Exp_Ch7 is
-- begin
-- <core loop>
-- if Raised and then not Abort then -- Expection handlers OK
-- if Raised and then not Abort then
-- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
......@@ -5575,8 +5574,7 @@ package body Exp_Ch7 is
Stmts := New_List (Core_Loop);
if Exceptions_OK then
Append_To (Stmts,
Build_Raise_Statement (Finalizer_Data));
Append_To (Stmts, Build_Raise_Statement (Finalizer_Data));
end if;
return
......@@ -5593,11 +5591,14 @@ package body Exp_Ch7 is
---------------------------------
function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
Comp_Typ : constant Entity_Id := Component_Type (Typ);
Final_List : constant List_Id := New_List;
Index_List : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (Typ);
Num_Dims : constant Int := Number_Dimensions (Typ);
Comp_Typ : constant Entity_Id := Component_Type (Typ);
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Final_List : constant List_Id := New_List;
Index_List : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (Typ);
Num_Dims : constant Int := Number_Dimensions (Typ);
Counter_Id : Entity_Id;
Dim : Int;
F : Node_Id;
......@@ -5611,9 +5612,6 @@ package body Exp_Ch7 is
Loop_Id : Node_Id;
Stmts : List_Id;
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
function Build_Counter_Assignment return Node_Id;
-- Generate the following assignment:
-- Counter := V'Length (1) *
......@@ -5751,9 +5749,7 @@ package body Exp_Ch7 is
-- if Counter > 0 then
-- Counter := Counter - 1;
-- else
-- [Deep_]Finalize (V (F1, ..., FN)); -- No_Except_Propagation
-- begin -- Exceptions allowed
-- begin
-- [Deep_]Finalize (V (F1, ..., FN));
-- exception
-- when others =>
......@@ -5852,18 +5848,17 @@ package body Exp_Ch7 is
-- <final loop>
-- if Raised and then not Abort then -- Exception handlers OK
-- if Raised and then not Abort then
-- Raise_From_Controlled_Operation (E);
-- end if;
-- raise; -- Exception handlers OK
-- raise;
-- end;
Stmts := New_List (Build_Counter_Assignment, Final_Loop);
if Exceptions_OK then
Append_To (Stmts,
Build_Raise_Statement (Finalizer_Data));
Append_To (Stmts, Build_Raise_Statement (Finalizer_Data));
Append_To (Stmts, Make_Raise_Statement (Loc));
end if;
......@@ -6243,17 +6238,17 @@ package body Exp_Ch7 is
-----------------------------
function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Loc : constant Source_Ptr := Sloc (Typ);
Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
Bod_Stmts : List_Id;
Finalizer_Data : Finalization_Exception_Data;
Finalizer_Decls : List_Id := No_List;
Rec_Def : Node_Id;
Var_Case : Node_Id;
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
function Process_Component_List_For_Adjust
(Comps : Node_Id) return List_Id;
-- Build all necessary adjust statements for a single component list
......@@ -6285,11 +6280,9 @@ package body Exp_Ch7 is
Adj_Stmt : Node_Id;
begin
-- Generate:
-- [Deep_]Adjust (V.Id); -- No_Exception_Propagation
-- begin -- Exception handlers allowed
-- begin
-- [Deep_]Adjust (V.Id);
-- exception
-- when others =>
-- if not Raised then
......@@ -6523,10 +6516,9 @@ package body Exp_Ch7 is
Skip_Self => True);
-- Generate:
-- Deep_Adjust (V._parent, False); -- No_Except_Propagat
-- begin -- Exceptions OK
-- begin
-- Deep_Adjust (V._parent, False);
-- exception
-- when Id : others =>
-- if not Raised then
......@@ -6568,10 +6560,9 @@ package body Exp_Ch7 is
-- Generate:
-- if F then
-- Adjust (V); -- No_Exception_Propagation
-- begin -- Exception handlers allowed
-- begin
-- Adjust (V);
-- exception
-- when others =>
-- if not Raised then
......@@ -6635,8 +6626,7 @@ package body Exp_Ch7 is
else
if Exceptions_OK then
Append_To (Bod_Stmts,
Build_Raise_Statement (Finalizer_Data));
Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
end if;
return
......@@ -6654,8 +6644,11 @@ package body Exp_Ch7 is
-------------------------------
function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Loc : constant Source_Ptr := Sloc (Typ);
Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
Bod_Stmts : List_Id;
Counter : Int := 0;
Finalizer_Data : Finalization_Exception_Data;
......@@ -6663,9 +6656,6 @@ package body Exp_Ch7 is
Rec_Def : Node_Id;
Var_Case : Node_Id;
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
function Process_Component_List_For_Finalize
(Comps : Node_Id) return List_Id;
-- Build all necessary finalization statements for a single component
......@@ -7096,10 +7086,9 @@ package body Exp_Ch7 is
Skip_Self => True);
-- Generate:
-- Deep_Finalize (V._parent, False); -- No_Except_Propag
-- begin -- Exceptions OK
-- begin
-- Deep_Finalize (V._parent, False);
-- exception
-- when Id : others =>
-- if not Raised then
......@@ -7142,10 +7131,9 @@ package body Exp_Ch7 is
-- Generate:
-- if F then
-- Finalize (V); -- No_Exception_Propagation
-- begin
-- Finalize (V);
-- exception
-- when others =>
-- if not Raised then
......@@ -7207,8 +7195,7 @@ package body Exp_Ch7 is
else
if Exceptions_OK then
Append_To (Bod_Stmts,
Build_Raise_Statement (Finalizer_Data));
Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
end if;
return
......
gcc/ada/exp_ch9.adb
......@@ -4315,15 +4315,18 @@ package body Exp_Ch9 is
if Nkind (Op_Spec) = N_Function_Specification then
if Exc_Safe then
R := Make_Temporary (Loc, 'R');
Unprot_Call :=
Make_Object_Declaration (Loc,
Defining_Identifier => R,
Constant_Present => True,
Object_Definition => New_Copy (Result_Definition (N_Op_Spec)),
Expression =>
Constant_Present => True,
Object_Definition =>
New_Copy (Result_Definition (N_Op_Spec)),
Expression =>
Make_Function_Call (Loc,
Name => Make_Identifier (Loc,
Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
Name =>
Make_Identifier (Loc,
Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals));
Return_Stmt :=
......@@ -4331,12 +4334,14 @@ package body Exp_Ch9 is
Expression => New_Occurrence_Of (R, Loc));
else
Unprot_Call := Make_Simple_Return_Statement (Loc,
Expression => Make_Function_Call (Loc,
Name =>
Make_Identifier (Loc,
Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals));
Unprot_Call :=
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name =>
Make_Identifier (Loc,
Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals));
end if;
Lock_Kind := RE_Lock_Read_Only;
......@@ -4344,7 +4349,7 @@ package body Exp_Ch9 is
else
Unprot_Call :=
Make_Procedure_Call_Statement (Loc,
Name =>
Name =>
Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals);
......@@ -4354,10 +4359,11 @@ package body Exp_Ch9 is
-- Wrap call in block that will be covered by an at_end handler
if not Exc_Safe then
Unprot_Call := Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Unprot_Call)));
Unprot_Call :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Unprot_Call)));
end if;
-- Make the protected subprogram body. This locks the protected
......@@ -4379,21 +4385,20 @@ package body Exp_Ch9 is
Object_Parm :=
Make_Attribute_Reference (Loc,
Prefix =>
Prefix =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uObject),
Selector_Name => Make_Identifier (Loc, Name_uObject)),
Attribute_Name => Name_Unchecked_Access);
Lock_Stmt := Make_Procedure_Call_Statement (Loc,
Name => Lock_Name,
Parameter_Associations => New_List (Object_Parm));
Lock_Stmt :=
Make_Procedure_Call_Statement (Loc,
Name => Lock_Name,
Parameter_Associations => New_List (Object_Parm));
if Abort_Allowed then
Stmts := New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc),
Parameter_Associations => Empty_List),
Build_Runtime_Call (Loc, RE_Abort_Defer),
Lock_Stmt);
else
......@@ -4417,20 +4422,21 @@ package body Exp_Ch9 is
Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts);
if Nkind (Op_Spec) = N_Function_Specification then
Append (Return_Stmt, Stmts);
Append (Make_Block_Statement (Loc,
Declarations => New_List (Unprot_Call),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts)), Pre_Stmts);
Append_To (Stmts, Return_Stmt);
Append_To (Pre_Stmts,
Make_Block_Statement (Loc,
Declarations => New_List (Unprot_Call),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts)));
Stmts := Pre_Stmts;
end if;
end if;
Sub_Body :=
Make_Subprogram_Body (Loc,
Declarations => Empty_List,
Specification => P_Op_Spec,
Declarations => Empty_List,
Specification => P_Op_Spec,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
......@@ -4594,11 +4600,7 @@ package body Exp_Ch9 is
-- Abort_Undefer;
if Abort_Allowed then
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc),
Parameter_Associations => Empty_List));
Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
end if;
end Build_Protected_Subprogram_Call_Cleanup;
......@@ -7169,6 +7171,8 @@ package body Exp_Ch9 is
Name => New_Occurrence_Of (Proc, Loc)));
end Rewrite_Abortable_Part;
-- Start of processing for Expand_N_Asynchronous_Select
begin
Process_Statements_For_Controlled_Objects (Trig);
Process_Statements_For_Controlled_Objects (Abrt);
......@@ -7426,23 +7430,19 @@ package body Exp_Ch9 is
Name_uDisp_Asynchronous_Select),
Loc),
Parameter_Associations =>
New_List (
New_Copy_Tree (Obj), -- <object>
New_Occurrence_Of (S, Loc), -- S
Make_Attribute_Reference (Loc, -- P'Address
Prefix => New_Occurrence_Of (P, Loc),
Attribute_Name => Name_Address),
Make_Identifier (Loc, Name_uD), -- D
New_Occurrence_Of (B, Loc)))); -- B
Parameter_Associations => New_List (
New_Copy_Tree (Obj), -- <object>
New_Occurrence_Of (S, Loc), -- S
Make_Attribute_Reference (Loc, -- P'Address
Prefix => New_Occurrence_Of (P, Loc),
Attribute_Name => Name_Address),
Make_Identifier (Loc, Name_uD), -- D
New_Occurrence_Of (B, Loc)))); -- B
-- Generate:
-- Abort_Defer;
Prepend_To (TaskE_Stmts,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc),
Parameter_Associations => No_List));
Prepend_To (TaskE_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
-- Generate:
-- Abort_Undefer;
......@@ -7450,10 +7450,8 @@ package body Exp_Ch9 is
Cleanup_Stmts := New_Copy_List_Tree (Astats);
Prepend_To (Cleanup_Stmts,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc),
Parameter_Associations => No_List));
Prepend_To
(Cleanup_Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
-- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
-- will generate a _clean for the additional status flag.
......@@ -7640,9 +7638,7 @@ package body Exp_Ch9 is
Hdle := New_List (Build_Abort_Block_Handler (Loc));
Prepend_To (Astats,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc)));
Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer));
Abortable_Block :=
Make_Block_Statement (Loc,
......@@ -7788,17 +7784,14 @@ package body Exp_Ch9 is
Has_Created_Identifier => True,
Is_Asynchronous_Call_Block => True);
if Exception_Mechanism = Back_End_Exceptions then
-- Aborts are not deferred at beginning of exception handlers
-- in ZCX.
-- Aborts are not deferred at beginning of exception handlers in
-- ZCX.
if Exception_Mechanism = Back_End_Exceptions then
Handler_Stmt := Make_Null_Statement (Loc);
else
Handler_Stmt := Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc),
Parameter_Associations => No_List);
Handler_Stmt := Build_Runtime_Call (Loc, RE_Abort_Undefer);
end if;
Stmts := New_List (
......@@ -7881,9 +7874,7 @@ package body Exp_Ch9 is
Hdle := New_List (Build_Abort_Block_Handler (Loc));
Prepend_To (Astats,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc)));
Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer));
Abortable_Block :=
Make_Block_Statement (Loc,
......@@ -7927,10 +7918,7 @@ package body Exp_Ch9 is
-- Protected the call against abort
Prepend_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc),
Parameter_Associations => Empty_List));
Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
end if;
Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param);
......@@ -10762,9 +10750,7 @@ package body Exp_Ch9 is
-- analysis with unknown calls, so don't do it.
if not CodePeer_Mode then
Call :=
Make_Procedure_Call_Statement (Eloc,
Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Eloc));
Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
Insert_Before
(First (Statements (Handled_Statement_Sequence
(Accept_Statement (Alt)))),
......
gcc/ada/exp_intr.adb
......@@ -1022,6 +1022,7 @@ package body Exp_Intr is
Abrt_Blk : Node_Id := Empty;
Abrt_Blk_Id : Entity_Id;
Abrt_HSS : Node_Id;
AUD : Entity_Id;
Fin_Blk : Node_Id;
Fin_Call : Node_Id;
......@@ -1031,10 +1032,6 @@ package body Exp_Intr is
Gen_Code : Node_Id;
Obj_Ref : Node_Id;
Dummy : Entity_Id;
-- This variable captures an unused dummy internal entity, see the
-- comment associated with its use.
begin
-- Nothing to do if we know the argument is null
......@@ -1048,10 +1045,10 @@ package body Exp_Intr is
-- Ex : Exception_Occurrence;
-- Raised : Boolean := False;
-- begin -- aborts allowed
-- begin
-- Abort_Defer;
-- begin -- exception propagation allowed
-- begin
-- [Deep_]Finalize (Obj_Ref);
-- exception
......@@ -1121,50 +1118,51 @@ package body Exp_Intr is
Exception_Handlers => New_List (
Build_Exception_Handler (Fin_Data))));
-- The finalization action must be protected by an abort defer
-- undefer pair when aborts are allowed. Generate:
-- Otherwise exception propagation is not allowed
-- begin
-- Abort_Defer;
-- <Fin_Blk>
-- at end
-- Abort_Undefer_Direct;
-- end;
else
Fin_Blk := Fin_Call;
end if;
if Abort_Allowed then
AUD := RTE (RE_Abort_Undefer_Direct);
-- The finalization action must be protected by an abort defer and
-- undefer pair when aborts are allowed. Generate:
Abrt_Blk :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Build_Runtime_Call (Loc, RE_Abort_Defer),
Fin_Blk),
At_End_Proc => New_Occurrence_Of (AUD, Loc)));
-- begin
-- Abort_Defer;
-- <Fin_Blk>
-- at end
-- Abort_Undefer_Direct;
-- end;
Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id);
if Abort_Allowed then
AUD := RTE (RE_Abort_Undefer_Direct);
-- Present the Abort_Undefer_Direct function to the backend so
-- that it can inline the call to the function.
Abrt_HSS :=
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Build_Runtime_Call (Loc, RE_Abort_Defer),
Fin_Blk),
At_End_Proc => New_Occurrence_Of (AUD, Loc));
Add_Inlined_Body (AUD, N);
Append_To (Stmts, Abrt_Blk);
Abrt_Blk :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence => Abrt_HSS);
-- Otherwise aborts are not allowed. Generate a dummy entity to
-- ensure that the internal symbols are in sync when a unit is
-- compiled with and without aborts.
Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id);
Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id);
else
Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
Append_To (Stmts, Fin_Blk);
end if;
-- Present the Abort_Undefer_Direct function to the backend so
-- that it can inline the call to the function.
-- Otherwise exception propagation is not allowed
Add_Inlined_Body (AUD, N);
-- Otherwise aborts are not allowed
else
Append_To (Stmts, Fin_Call);
Abrt_Blk := Fin_Blk;
end if;
Append_To (Stmts, Abrt_Blk);
end if;
-- For a task type, call Free_Task before freeing the ATCB. We used to
......@@ -1174,8 +1172,8 @@ package body Exp_Intr is
-- (the task will be freed once it terminates).
if Is_Task_Type (Desig_Typ) then
Append_To
(Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg)));
Append_To (Stmts,
Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg)));
-- For composite types that contain tasks, recurse over the structure
-- to build the selectors for the task subcomponents.
......@@ -1411,15 +1409,6 @@ package body Exp_Intr is
Rewrite (N, Gen_Code);
Analyze (N);
-- If we generated a block with an At_End_Proc, expand the exception
-- handler. We need to wait until after everything else is analyzed.
if Present (Abrt_Blk) then
Expand_At_End_Handler
(HSS => Handled_Statement_Sequence (Abrt_Blk),
Blk_Id => Entity (Identifier (Abrt_Blk)));
end if;
end Expand_Unc_Deallocation;
-----------------------
......
gcc/ada/exp_util.adb
......@@ -9453,19 +9453,4 @@ package body Exp_Util is
and then not Is_Predicate_Function_M (S);
end Within_Internal_Subprogram;
----------------------------
-- Wrap_Cleanup_Procedure --
----------------------------
procedure Wrap_Cleanup_Procedure (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Stseq : constant Node_Id := Handled_Statement_Sequence (N);
Stmts : constant List_Id := Statements (Stseq);
begin
if Abort_Allowed then
Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
end if;
end Wrap_Cleanup_Procedure;
end Exp_Util;
gcc/ada/exp_util.ads
......@@ -1020,15 +1020,6 @@ package Exp_Util is
-- predefined primitive operation. Some expansion activity (e.g. predicate
-- checks) is disabled in such.
procedure Wrap_Cleanup_Procedure (N : Node_Id);
-- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer call
-- at the start of the statement sequence, and an Abort_Undefer call at the
-- end of the statement sequence. All cleanup routines (i.e. those that are
-- called from "at end" handlers) must defer abort on entry and undefer
-- abort on exit. Note that it is assumed that the code for the procedure
-- does not contain any return statements which would allow the flow of
-- control to escape doing the undefer call.
private
pragma Inline (Duplicate_Subexpr);
pragma Inline (Force_Evaluation);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment