-- Local variables
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
+
Built : Boolean := False;
+ Blk_Decl : Node_Id := Empty;
+ Blk_Decls : List_Id := No_List;
+ Blk_Ins : Node_Id;
+ Blk_Stmts : List_Id;
Desig_Typ : Entity_Id;
- Expr : Node_Id;
- Fin_Block : Node_Id;
+ Fin_Call : Node_Id;
Fin_Data : Finalization_Exception_Data;
- Fin_Decls : List_Id;
- Fin_Insrt : Node_Id;
- Last_Fin : Node_Id := Empty;
+ Fin_Stmts : List_Id;
+ Hook_Clr : Node_Id := Empty;
+ Hook_Id : Entity_Id;
+ Hook_Ins : Node_Id;
+ Init_Expr : Node_Id;
Loc : Source_Ptr;
+ Obj_Decl : Node_Id;
Obj_Id : Entity_Id;
Obj_Ref : Node_Id;
Obj_Typ : Entity_Id;
- Prev_Fin : Node_Id := Empty;
- Ptr_Id : Entity_Id;
- Stmt : Node_Id;
- Stmts : List_Id;
- Temp_Id : Entity_Id;
- Temp_Ins : Node_Id;
+ Ptr_Typ : Entity_Id;
-- Start of processing for Process_Transient_Objects
begin
+ -- The expansion performed by this routine 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;
+
+ -- declare
+ -- Abrt : constant Boolean := ...;
+ -- Ex : Exception_Occurrence;
+ -- Raised : Boolean := False;
+
+ -- begin
+ -- begin
+ -- Hook_N := null;
+ -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
+
+ -- exception
+ -- when others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
+ -- end;
+ -- . . .
+ -- begin
+ -- Hook_1 := null;
+ -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
+
+ -- exception
+ -- when others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
+ -- end;
+
+ -- 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);
+ -- end;
+
-- Recognize a scenario where the transient context is an object
-- declaration initialized by a build-in-place function call:
and then Present (BIP_Initialization_Call (Defining_Identifier (N)))
then
Must_Hook := True;
- Fin_Insrt := BIP_Initialization_Call (Defining_Identifier (N));
+ Blk_Ins := BIP_Initialization_Call (Defining_Identifier (N));
-- Search the context for at least one subprogram call. If found, the
-- machinery exports all transient objects to the enclosing finalizer
else
Detect_Subprogram_Call (N);
- Fin_Insrt := Last_Object;
+ Blk_Ins := Last_Object;
+ end if;
+
+ if Clean then
+ Insert_List_After_And_Analyze (Blk_Ins, Act_Cleanup);
end if;
-- Examine all objects in the list First_Object .. Last_Object
- Stmt := First_Object;
- while Present (Stmt) loop
- if Nkind (Stmt) = N_Object_Declaration
- and then Analyzed (Stmt)
- and then Is_Finalizable_Transient (Stmt, N)
+ Obj_Decl := First_Object;
+ while Present (Obj_Decl) loop
+ if Nkind (Obj_Decl) = N_Object_Declaration
+ and then Analyzed (Obj_Decl)
+ and then Is_Finalizable_Transient (Obj_Decl, N)
-- Do not process the node to be wrapped since it will be
-- handled by the enclosing finalizer.
- and then Stmt /= Related_Node
+ and then Obj_Decl /= Related_Node
then
- Loc := Sloc (Stmt);
- Obj_Id := Defining_Identifier (Stmt);
+ Loc := Sloc (Obj_Decl);
+ Obj_Id := Defining_Identifier (Obj_Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
Desig_Typ := Obj_Typ;
Desig_Typ := Available_View (Designated_Type (Desig_Typ));
end if;
- -- Create the necessary entities and declarations the first
- -- time around.
-
- if not Built then
- Built := True;
- Fin_Decls := New_List;
-
- Build_Object_Declarations (Fin_Data, Fin_Decls, Loc);
- end if;
-
- -- Transient variables associated with subprogram calls need
- -- extra processing. These variables are usually created right
+ -- Transient objects associated with subprogram calls need
+ -- extra processing. These objects are usually created right
-- before the call and finalized immediately after the call.
-- If an exception occurs during the call, the clean up code
-- is skipped due to the sudden change in control and the
if Must_Hook then
- -- Step 1: Create an access type which provides a reference
- -- to the transient object. Generate:
-
- -- Ann : access [all] <Desig_Typ>;
+ -- Create an access type which provides a reference to the
+ -- transient object. Generate:
+ -- type Ptr_Typ is access [all] Desig_Typ;
- Ptr_Id := Make_Temporary (Loc, 'A');
+ Ptr_Typ := Make_Temporary (Loc, 'A');
- Insert_Action (Stmt,
+ Insert_Action (Obj_Decl,
Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ptr_Id,
+ Defining_Identifier => Ptr_Typ,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present =>
Subtype_Indication =>
New_Occurrence_Of (Desig_Typ, Loc))));
- -- Step 2: Create a temporary which acts as a hook to the
- -- transient object. Generate:
-
- -- Temp : Ptr_Id := null;
+ -- Create a temporary which acts as a hook to the transient
+ -- object. Generate:
+ -- Hook : Ptr_Typ := null;
- Temp_Id := Make_Temporary (Loc, 'T');
+ Hook_Id := Make_Temporary (Loc, 'T');
- Insert_Action (Stmt,
+ Insert_Action (Obj_Decl,
Make_Object_Declaration (Loc,
- Defining_Identifier => Temp_Id,
+ Defining_Identifier => Hook_Id,
Object_Definition =>
- New_Occurrence_Of (Ptr_Id, Loc)));
+ New_Occurrence_Of (Ptr_Typ, Loc)));
- -- Mark the temporary as a transient hook. This signals the
- -- machinery in Build_Finalizer to recognize this special
- -- case.
+ -- Mark the temporary as a hook. This signals the machinery
+ -- in Build_Finalizer to recognize this special case.
- Set_Status_Flag_Or_Transient_Decl (Temp_Id, Stmt);
+ Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
- -- Step 3: Hook the transient object to the temporary
+ -- Hook the transient object to the temporary. Generate:
+ -- Hook := Ptr_Typ (Obj_Id);
+ -- <or>
+ -- Hook := Obj_Id'Unrestricted_Access;
if Is_Access_Type (Obj_Typ) then
- Expr :=
- Convert_To (Ptr_Id, New_Occurrence_Of (Obj_Id, Loc));
+ Init_Expr :=
+ Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
+
else
- Expr :=
+ Init_Expr :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Obj_Id, Loc),
Attribute_Name => Name_Unrestricted_Access);
end if;
- -- Generate:
- -- Temp := Ptr_Id (Obj_Id);
- -- <or>
- -- Temp := Obj_Id'Unrestricted_Access;
-
-- When the transient object is initialized by an aggregate,
-- the hook must capture the object after the last component
-- assignment takes place. Only then is the object fully
if Ekind (Obj_Id) = E_Variable
and then Present (Last_Aggregate_Assignment (Obj_Id))
then
- Temp_Ins := Last_Aggregate_Assignment (Obj_Id);
+ Hook_Ins := Last_Aggregate_Assignment (Obj_Id);
-- Otherwise the hook seizes the related object immediately
else
- Temp_Ins := Stmt;
+ Hook_Ins := Obj_Decl;
end if;
- Insert_After_And_Analyze (Temp_Ins,
+ Insert_After_And_Analyze (Hook_Ins,
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Temp_Id, Loc),
- Expression => Expr));
+ Name => New_Occurrence_Of (Hook_Id, Loc),
+ Expression => Init_Expr));
+
+ -- The transient object is about to be finalized by the
+ -- clean up code following the subprogram call. In order
+ -- to avoid double finalization, clear the hook.
+
+ -- Generate:
+ -- Hook := null;
+
+ Hook_Clr :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Hook_Id, Loc),
+ Expression => Make_Null (Loc));
end if;
- Stmts := New_List;
+ -- Before generating the clean up code for the first transient
+ -- object, create a wrapper block which houses all hook clear
+ -- statements and finalization calls. This wrapper is needed by
+ -- the back-end.
- -- The transient object is about to be finalized by the clean
- -- up code following the subprogram call. In order to avoid
- -- double finalization, clear the hook.
+ if not Built then
+ Built := True;
+ Blk_Stmts := New_List;
- -- Generate:
- -- Temp := null;
+ -- Create the declarations of all entities that participate
+ -- in exception detection and propagation.
- if Must_Hook then
- Append_To (Stmts,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Temp_Id, Loc),
- Expression => Make_Null (Loc)));
+ if Exceptions_OK then
+ Blk_Decls := New_List;
+
+ -- Generate:
+ -- Abrt : constant Boolean := ...;
+ -- Ex : Exception_Occurrence;
+ -- Raised : Boolean := False;
+
+ Build_Object_Declarations (Fin_Data, Blk_Decls, Loc);
+
+ -- Generate:
+ -- if Raised and then not Abrt then
+ -- Raise_From_Controlled_Operation (Ex);
+ -- end if;
+
+ Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data));
+ end if;
+
+ Blk_Decl :=
+ Make_Block_Statement (Loc,
+ Declarations => Blk_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Blk_Stmts));
end if;
-- Generate:
-- [Deep_]Finalize (Obj_Ref);
- -- Set type of dereference, so that proper conversion are
- -- generated when operation is inherited.
-
Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
if Is_Access_Type (Obj_Typ) then
Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
- Set_Etype (Obj_Ref, Directly_Designated_Type (Obj_Typ));
+ Set_Etype (Obj_Ref, Desig_Typ);
end if;
- Append_To (Stmts,
- Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ));
+ Fin_Call :=
+ Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ);
- -- Generate:
- -- [Temp := null;]
+ -- 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);
-- exception
-- end if;
-- end;
- Fin_Block :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts,
- Exception_Handlers => New_List (
- Build_Exception_Handler (Fin_Data))));
+ if Exceptions_OK then
+ Fin_Stmts := New_List;
- -- The single raise statement must be inserted after all the
- -- finalization blocks, and we put everything into a wrapper
- -- block to clearly expose the construct to the back-end.
+ if Present (Hook_Clr) then
+ Append_To (Fin_Stmts, Hook_Clr);
+ end if;
- if Present (Prev_Fin) then
- Insert_Before_And_Analyze (Prev_Fin, Fin_Block);
- else
- Insert_After_And_Analyze (Fin_Insrt,
+ Append_To (Fin_Stmts, Fin_Call);
+
+ Prepend_To (Blk_Stmts,
Make_Block_Statement (Loc,
- Declarations => Fin_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Fin_Block))));
+ Statements => Fin_Stmts,
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Fin_Data)))));
- Last_Fin := Fin_Block;
- end if;
+ -- Otherwise generate:
+ -- [Temp := null;]
+ -- [Deep_]Finalize (Obj_Ref);
+
+ else
+ Prepend_To (Blk_Stmts, Fin_Call);
- Prev_Fin := Fin_Block;
+ if Present (Hook_Clr) then
+ Prepend_To (Blk_Stmts, Hook_Clr);
+ end if;
+ end if;
end if;
-- Terminate the scan after the last object has been processed to
-- avoid touching unrelated code.
- if Stmt = Last_Object then
+ if Obj_Decl = Last_Object then
exit;
end if;
- Next (Stmt);
+ Next (Obj_Decl);
end loop;
- if Clean then
- if Present (Prev_Fin) then
- Insert_List_Before_And_Analyze (Prev_Fin, Act_Cleanup);
- else
- Insert_List_After_And_Analyze (Fin_Insrt, Act_Cleanup);
- end if;
- end if;
-
- -- Generate:
- -- if Raised and then not Abort then
- -- Raise_From_Controlled_Operation (E);
- -- end if;
-
- if Built and then Present (Last_Fin) then
- Insert_After_And_Analyze (Last_Fin,
- Build_Raise_Statement (Fin_Data));
+ if Present (Blk_Decl) then
+ Insert_After_And_Analyze (Blk_Ins, Blk_Decl);
end if;
end Process_Transient_Objects;
-- Expand_Unc_Deallocation --
-----------------------------
- -- Generate the following Code :
-
- -- if Arg /= null then
- -- <Finalize_Call> (.., T'Class(Arg.all), ..); -- for controlled types
- -- Free (Arg);
- -- Arg := Null;
- -- end if;
-
- -- For a task, we also generate a call to Free_Task to ensure that the
- -- task itself is freed if it is terminated, ditto for a simple protected
- -- object, with a call to Finalize_Protection. For composite types that
- -- have tasks or simple protected objects as components, we traverse the
- -- structures to find and terminate those components.
-
procedure Expand_Unc_Deallocation (N : Node_Id) is
Arg : constant Node_Id := First_Actual (N);
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (Arg);
- Desig_T : constant Entity_Id := Designated_Type (Typ);
- Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ));
- Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp);
+ Desig_Typ : constant Entity_Id := Designated_Type (Typ);
+ Needs_Fin : constant Boolean := Needs_Finalization (Desig_Typ);
+ Root_Typ : constant Entity_Id := Underlying_Type (Root_Type (Typ));
+ Pool : constant Entity_Id := Associated_Storage_Pool (Root_Typ);
Stmts : constant List_Id := New_List;
- Needs_Fin : constant Boolean := Needs_Finalization (Desig_T);
-
- Finalizer_Data : Finalization_Exception_Data;
-
- Blk : Node_Id := Empty;
- Blk_Id : Entity_Id;
- Deref : Node_Id;
- Final_Code : List_Id;
- Free_Arg : Node_Id;
- Free_Node : Node_Id;
- Gen_Code : Node_Id;
Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N);
-- This captures whether we know the argument to be non-null so that
-- that we analyze some generated statements before properly attaching
-- them to the tree, and that can disturb current value settings.
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
+
+ Abrt_Blk : Node_Id := Empty;
+ Abrt_Blk_Id : Entity_Id;
+ AUD : Entity_Id;
+ Fin_Blk : Node_Id;
+ Fin_Call : Node_Id;
+ Fin_Data : Finalization_Exception_Data;
+ Free_Arg : Node_Id;
+ Free_Nod : 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.
return;
end if;
- -- Processing for pointer to controlled type
+ -- Processing for pointer to controlled types. Generate:
+
+ -- Abrt : constant Boolean := ...;
+ -- Ex : Exception_Occurrence;
+ -- Raised : Boolean := False;
+
+ -- begin -- aborts allowed
+ -- Abort_Defer;
+
+ -- begin -- exception propagation allowed
+ -- [Deep_]Finalize (Obj_Ref);
+
+ -- exception
+ -- when others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
+ -- end;
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
+
+ -- Depending on whether exception propagation is enabled and/or aborts
+ -- are allowed, the generated code may lack block statements.
if Needs_Fin then
- Deref :=
+ Obj_Ref :=
Make_Explicit_Dereference (Loc,
Prefix => Duplicate_Subexpr_No_Checks (Arg));
- -- If the type is tagged, then we must force dispatching on the
- -- finalization call because the designated type may not be the
- -- actual type of the object.
+ -- If the designated type is tagged, the finalization call must
+ -- dispatch because the designated type may not be the actual type
+ -- of the object.
- if Is_Tagged_Type (Desig_T)
- and then not Is_Class_Wide_Type (Desig_T)
- then
- Deref := Unchecked_Convert_To (Class_Wide_Type (Desig_T), Deref);
-
- elsif not Is_Tagged_Type (Desig_T) then
+ if Is_Tagged_Type (Desig_Typ) then
+ if not Is_Class_Wide_Type (Desig_Typ) then
+ Obj_Ref :=
+ Unchecked_Convert_To (Class_Wide_Type (Desig_Typ), Obj_Ref);
+ end if;
- -- Set type of result, to force a conversion when needed (see
- -- exp_ch7, Convert_View), given that Deep_Finalize may be
- -- inherited from the parent type, and we need the type of the
- -- expression to see whether the conversion is in fact needed.
+ -- Otherwise the designated type is untagged. Set the type of the
+ -- dereference explicitly to force a conversion when needed given
+ -- that [Deep_]Finalize may be inherited from a parent type.
- Set_Etype (Deref, Desig_T);
+ else
+ Set_Etype (Obj_Ref, Desig_Typ);
end if;
- -- The finalization call is expanded wrapped in a block to catch any
- -- possible exception. If an exception does occur, then Program_Error
- -- must be raised following the freeing of the object and its removal
- -- from the finalization collection's list. We set a flag to record
- -- that an exception was raised, and save its occurrence for use in
- -- the later raise.
- --
-- Generate:
- -- Abort : constant Boolean :=
- -- Exception_Occurrence (Get_Current_Excep.all.all) =
- -- Standard'Abort_Signal'Identity;
- -- <or>
- -- Abort : constant Boolean := False; -- no abort
+ -- [Deep_]Finalize (Obj_Ref);
+
+ Fin_Call := Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ);
- -- E : Exception_Occurrence;
+ -- Generate:
+ -- Abrt : constant Boolean := ...;
+ -- Ex : Exception_Occurrence;
-- Raised : Boolean := False;
- --
+
-- begin
- -- [Deep_]Finalize (Obj);
+ -- <Fin_Call>
+
-- exception
-- when others =>
- -- Raised := True;
- -- Save_Occurrence (E, Get_Current_Excep.all.all);
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
-- end;
- Build_Object_Declarations (Finalizer_Data, Stmts, Loc);
+ if Exceptions_OK then
+ Build_Object_Declarations (Fin_Data, Stmts, Loc);
- Final_Code := New_List (
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Final_Call (Obj_Ref => Deref, Typ => Desig_T)),
- Exception_Handlers => New_List (
- Build_Exception_Handler (Finalizer_Data)))));
+ Fin_Blk :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Fin_Call),
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Fin_Data))));
- -- If aborts are allowed, then the finalization code must be
- -- protected by an abort defer/undefer pair.
+ -- The finalization action must be protected by an abort defer
+ -- undefer pair when aborts are allowed. Generate:
- if Abort_Allowed then
- Prepend_To (Final_Code, Build_Runtime_Call (Loc, RE_Abort_Defer));
+ -- begin
+ -- Abort_Defer;
+ -- <Fin_Blk>
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
- declare
- AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
+ if Abort_Allowed then
+ AUD := RTE (RE_Abort_Undefer_Direct);
- begin
- Blk :=
+ Abrt_Blk :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Final_Code,
+ Statements => New_List (
+ Build_Runtime_Call (Loc, RE_Abort_Defer),
+ Fin_Blk),
At_End_Proc => New_Occurrence_Of (AUD, Loc)));
+ Add_Block_Identifier (Abrt_Blk, 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);
- end;
+ Append_To (Stmts, Abrt_Blk);
- Add_Block_Identifier (Blk, Blk_Id);
+ -- 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.
- Append (Blk, Stmts);
+ else
+ Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
+ Append_To (Stmts, Fin_Blk);
+ end if;
- else
- -- Generate a dummy entity to ensure that the internal symbols are
- -- in sync when a unit is compiled with and without aborts.
+ -- Otherwise exception propagation is not allowed
- Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
- Append_List_To (Stmts, Final_Code);
+ else
+ Append_To (Stmts, Fin_Call);
end if;
end if;
- -- For a task type, call Free_Task before freeing the ATCB
-
- if Is_Task_Type (Desig_T) then
-
- -- We used to detect the case of Abort followed by a Free here,
- -- because the Free wouldn't actually free if it happens before
- -- the aborted task actually terminates. The warning was removed,
- -- because Free now works properly (the task will be freed once
- -- it terminates).
+ -- For a task type, call Free_Task before freeing the ATCB. We used to
+ -- detect the case of Abort followed by a Free here, because the Free
+ -- wouldn't actually free if it happens before the aborted task actually
+ -- terminates. The warning was removed, because Free now works properly
+ -- (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)));
-- For composite types that contain tasks, recurse over the structure
-- to build the selectors for the task subcomponents.
- elsif Has_Task (Desig_T) then
- if Is_Record_Type (Desig_T) then
- Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T));
+ elsif Has_Task (Desig_Typ) then
+ if Is_Array_Type (Desig_Typ) then
+ Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_Typ));
- elsif Is_Array_Type (Desig_T) then
- Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T));
+ elsif Is_Record_Type (Desig_Typ) then
+ Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_Typ));
end if;
end if;
-- Same for simple protected types. Eventually call Finalize_Protection
-- before freeing the PO for each protected component.
- if Is_Simple_Protected_Type (Desig_T) then
+ if Is_Simple_Protected_Type (Desig_Typ) then
Append_To (Stmts,
Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg)));
- elsif Has_Simple_Protected_Object (Desig_T) then
- if Is_Record_Type (Desig_T) then
- Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T));
- elsif Is_Array_Type (Desig_T) then
- Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T));
+ elsif Has_Simple_Protected_Object (Desig_Typ) then
+ if Is_Array_Type (Desig_Typ) then
+ Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_Typ));
+
+ elsif Is_Record_Type (Desig_Typ) then
+ Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_Typ));
end if;
end if;
-- a renaming rather than a constant to ensure that the original context
-- is always set to null after the deallocation takes place.
- Free_Arg := Duplicate_Subexpr_No_Checks (Arg, Renaming_Req => True);
- Free_Node := Make_Free_Statement (Loc, Empty);
- Append_To (Stmts, Free_Node);
- Set_Storage_Pool (Free_Node, Pool);
+ Free_Arg := Duplicate_Subexpr_No_Checks (Arg, Renaming_Req => True);
+ Free_Nod := Make_Free_Statement (Loc, Empty);
+ Append_To (Stmts, Free_Nod);
+ Set_Storage_Pool (Free_Nod, Pool);
-- Attach to tree before analysis of generated subtypes below
-- Deallocate (which is allowed), then the actual will simply be set
-- to null.
- elsif Present (Get_Rep_Pragma
- (Etype (Pool), Name_Simple_Storage_Pool_Type))
+ elsif Present
+ (Get_Rep_Pragma (Etype (Pool), Name_Simple_Storage_Pool_Type))
then
declare
- Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
- Dealloc_Op : Entity_Id;
+ Pool_Typ : constant Entity_Id := Base_Type (Etype (Pool));
+ Dealloc : Entity_Id;
+
begin
- Dealloc_Op := Get_Name_Entity_Id (Name_Deallocate);
- while Present (Dealloc_Op) loop
- if Scope (Dealloc_Op) = Scope (Pool_Type)
- and then Present (First_Formal (Dealloc_Op))
- and then Etype (First_Formal (Dealloc_Op)) = Pool_Type
+ Dealloc := Get_Name_Entity_Id (Name_Deallocate);
+ while Present (Dealloc) loop
+ if Scope (Dealloc) = Scope (Pool_Typ)
+ and then Present (First_Formal (Dealloc))
+ and then Etype (First_Formal (Dealloc)) = Pool_Typ
then
- Set_Procedure_To_Call (Free_Node, Dealloc_Op);
+ Set_Procedure_To_Call (Free_Nod, Dealloc);
exit;
else
- Dealloc_Op := Homonym (Dealloc_Op);
+ Dealloc := Homonym (Dealloc);
end if;
end loop;
end;
-- Deallocate through the class-wide Deallocate_Any.
elsif Is_Class_Wide_Type (Etype (Pool)) then
- Set_Procedure_To_Call (Free_Node, RTE (RE_Deallocate_Any));
+ Set_Procedure_To_Call (Free_Nod, RTE (RE_Deallocate_Any));
-- Case of a specific pool type: make a statically bound call
else
- Set_Procedure_To_Call (Free_Node,
- Find_Prim_Op (Etype (Pool), Name_Deallocate));
+ Set_Procedure_To_Call
+ (Free_Nod, Find_Prim_Op (Etype (Pool), Name_Deallocate));
end if;
end if;
- if Present (Procedure_To_Call (Free_Node)) then
+ if Present (Procedure_To_Call (Free_Nod)) then
-- For all cases of a Deallocate call, the back-end needs to be able
-- to compute the size of the object being freed. This may require
-- size parameter computed by GIGI. Same for an access to
-- unconstrained packed array.
- if Is_Class_Wide_Type (Desig_T)
+ if Is_Class_Wide_Type (Desig_Typ)
or else
- (Is_Array_Type (Desig_T)
- and then not Is_Constrained (Desig_T)
- and then Is_Packed (Desig_T))
+ (Is_Array_Type (Desig_Typ)
+ and then not Is_Constrained (Desig_Typ)
+ and then Is_Packed (Desig_Typ))
then
declare
Deref : constant Node_Id :=
-- Perform minor decoration as it is needed by the side effect
-- removal mechanism.
- Set_Etype (Deref, Desig_T);
- Set_Parent (Deref, Free_Node);
- D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_T);
+ Set_Etype (Deref, Desig_Typ);
+ Set_Parent (Deref, Free_Nod);
+ D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_Typ);
if Nkind (D_Subtyp) in N_Has_Entity then
D_Type := Entity (D_Subtyp);
Freeze_Itype (D_Type, Deref);
- Set_Actual_Designated_Subtype (Free_Node, D_Type);
+ Set_Actual_Designated_Subtype (Free_Nod, D_Type);
end;
-
end if;
end if;
if Is_Interface (Directly_Designated_Type (Typ))
and then Tagged_Type_Expansion
then
- Set_Expression (Free_Node,
+ Set_Expression (Free_Nod,
Unchecked_Convert_To (Typ,
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (RE_Base_Address), Loc),
+ Name =>
+ New_Occurrence_Of (RTE (RE_Base_Address), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Free_Arg)))));
-- free (Obj_Ptr)
else
- Set_Expression (Free_Node, Free_Arg);
+ Set_Expression (Free_Nod, Free_Arg);
end if;
-- Only remaining step is to set result to null, or generate a raise of
-- exception occurrence.
-- Generate:
- -- if Raised and then not Abort then
+ -- if Raised and then not Abrt then
-- raise Program_Error; -- for restricted RTS
-- <or>
-- Raise_From_Controlled_Operation (E); -- all other cases
-- end if;
- if Needs_Fin then
- Append_To (Stmts, Build_Raise_Statement (Finalizer_Data));
+ if Needs_Fin and then Exceptions_OK then
+ Append_To (Stmts, Build_Raise_Statement (Fin_Data));
end if;
-- If we know the argument is non-null, then make a block statement
else
Gen_Code :=
Make_Implicit_If_Statement (N,
- Condition =>
+ Condition =>
Make_Op_Ne (Loc,
Left_Opnd => Duplicate_Subexpr (Arg),
Right_Opnd => Make_Null (Loc)),
-- 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 (Blk) then
+ if Present (Abrt_Blk) then
Expand_At_End_Handler
- (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk)));
+ (HSS => Handled_Statement_Sequence (Abrt_Blk),
+ Blk_Id => Entity (Identifier (Abrt_Blk)));
end if;
end Expand_Unc_Deallocation;
projects / gcc.git / commitdiff