-- 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.
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);
-- 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
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)
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;
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
Set_No_Elaboration_Check (Fin_Call);
- Append_To (Fin_Stmts,
+ Append_To (Init_Stmts,
Make_Block_Statement (Loc,
Declarations => No_List,
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;
----------------------
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].
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
-- 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
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
else
-- Generate:
- -- [Deep_]Finalize (Obj); -- No_Exception_Propagation
-
- -- begin -- Exception handlers allowed
+ -- begin
-- [Deep_]Finalize (Obj);
-- exception
-- Raised : Boolean := False;
-- begin
+ -- Abort_Defer;
+
-- begin
-- Hook_N := null;
-- [Deep_]Finalize (Ctrl_Trans_Obj_N);
-- 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
-- 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);
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;
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;
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
-- 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
-- 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;
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
---------------------------------
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;
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) *
-- 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 =>
-- <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;
-----------------------------
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
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
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
-- Generate:
-- if F then
- -- Adjust (V); -- No_Exception_Propagation
-
- -- begin -- Exception handlers allowed
+ -- begin
-- Adjust (V);
+
-- exception
-- when others =>
-- if not Raised then
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
-------------------------------
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;
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
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
-- Generate:
-- if F then
- -- Finalize (V); -- No_Exception_Propagation
-
-- begin
-- Finalize (V);
+
-- exception
-- when others =>
-- if not Raised then
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
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 :=
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;
else
Unprot_Call :=
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals);
-- 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
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
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));
-- 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;
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);
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;
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.
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,
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 (
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,
-- 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);
-- 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)))),
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;
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
-- Ex : Exception_Occurrence;
-- Raised : Boolean := False;
- -- begin -- aborts allowed
+ -- begin
-- Abort_Defer;
- -- begin -- exception propagation allowed
+ -- begin
-- [Deep_]Finalize (Obj_Ref);
-- exception
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
-- (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.
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;
-----------------------
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;
-- 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);
projects / gcc.git / commitdiff