function Build_Cleanup_Statements (N : Node_Id) return List_Id;
-- Create the clean up calls for an asynchronous call block, task master,
- -- protected subprogram body, task allocation block or task body. Generate
- -- code to unregister the external tags of all library-level tagged types
- -- found in the declarations and/or statements of N. If the context does
- -- not contain the above constructs or types, the routine returns an empty
- -- list.
-
- function Build_Exception_Handler
- (Loc : Source_Ptr;
- E_Id : Entity_Id;
- Raised_Id : Entity_Id;
- For_Library : Boolean := False) return Node_Id;
- -- Subsidiary to Build_Finalizer, Make_Deep_Array_Body and Make_Deep_Record
- -- _Body. Create an exception handler of the following form:
- --
- -- when others =>
- -- if not Raised_Id then
- -- Raised_Id := True;
- -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
- -- end if;
- --
- -- If flag For_Library is set (and not in restricted profile):
- --
- -- when others =>
- -- if not Raised_Id then
- -- Raised_Id := True;
- -- Save_Library_Occurrence (Get_Current_Excep.all.all);
- -- end if;
- --
- -- E_Id denotes the defining identifier of a local exception occurrence.
- -- Raised_Id is the entity of a local boolean flag. Flag For_Library is
- -- used when operating at the library level, when enabled the current
- -- exception will be saved to a global location.
+ -- protected subprogram body, task allocation block or task body. If the
+ -- context does not contain the above constructs, the routine returns an
+ -- empty list.
procedure Build_Finalizer
(N : Node_Id;
-- whether the inner logic should be dictated by state counters.
function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
- -- Subsidiary to Make_Finalize_Address_Body and Make_Deep_Array_Body.
- -- Generate the following statements:
+ -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
+ -- Make_Deep_Record_Body. Generate the following statements:
--
-- declare
-- type Acc_Typ is access all Typ;
Is_Asynchronous_Call : constant Boolean :=
Nkind (N) = N_Block_Statement
and then Is_Asynchronous_Call_Block (N);
-
Is_Master : constant Boolean :=
- not Nkind_In (N, N_Entry_Body,
- N_Package_Body,
- N_Package_Declaration)
+ Nkind (N) /= N_Entry_Body
and then Is_Task_Master (N);
Is_Protected_Body : constant Boolean :=
Nkind (N) = N_Subprogram_Body
Loc : constant Source_Ptr := Sloc (N);
Stmts : constant List_Id := New_List;
- procedure Unregister_Tagged_Types (Decls : List_Id);
- -- Unregister the external tag of each tagged type found in the list
- -- Decls. The generated statements are added to list Stmts.
-
- -----------------------------
- -- Unregister_Tagged_Types --
- -----------------------------
-
- procedure Unregister_Tagged_Types (Decls : List_Id) is
- Decl : Node_Id;
- DT_Ptr : Entity_Id;
- Typ : Entity_Id;
-
- begin
- if No (Decls) or else Is_Empty_List (Decls) then
- return;
- end if;
-
- -- Process all declarations or statements in reverse order
-
- Decl := Last_Non_Pragma (Decls);
- while Present (Decl) loop
- if Nkind (Decl) = N_Full_Type_Declaration then
- Typ := Defining_Identifier (Decl);
-
- if Is_Tagged_Type (Typ)
- and then Is_Library_Level_Entity (Typ)
- and then Convention (Typ) = Convention_Ada
- and then Present (Access_Disp_Table (Typ))
- and then RTE_Available (RE_Unregister_Tag)
- and then not No_Run_Time_Mode
- and then not Is_Abstract_Type (Typ)
- then
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
-
- -- Generate:
- -- Ada.Tags.Unregister_Tag (<Typ>P);
-
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Unregister_Tag), Loc),
- Parameter_Associations => New_List (
- New_Reference_To (DT_Ptr, Loc))));
- end if;
- end if;
-
- Prev_Non_Pragma (Decl);
- end loop;
- end Unregister_Tagged_Types;
-
- -- Start of processing for Build_Cleanup_Statements
-
begin
if Is_Task_Body then
if Restricted_Profile then
end;
end if;
- -- Inspect all declaration and/or statement lists of N for library-level
- -- tagged types. Generate code to unregister the external tag of such a
- -- type.
-
- if Nkind (N) = N_Package_Declaration then
- Unregister_Tagged_Types (Private_Declarations (Specification (N)));
- Unregister_Tagged_Types (Visible_Declarations (Specification (N)));
-
- -- Accept statement, block, entry body, package body, protected body,
- -- subprogram body or task body.
-
- else
- if Present (Handled_Statement_Sequence (N)) then
- Unregister_Tagged_Types
- (Statements (Handled_Statement_Sequence (N)));
- end if;
-
- Unregister_Tagged_Types (Declarations (N));
- end if;
-
return Stmts;
end Build_Cleanup_Statements;
return
Make_Exception_Handler (Loc,
- Exception_Choices => New_List (
- Make_Others_Choice (Loc)),
-
+ Exception_Choices =>
+ New_List (Make_Others_Choice (Loc)),
Statements => New_List (
Make_If_Statement (Loc,
Condition =>
Parameter_Associations => Actuals)))));
end Build_Exception_Handler;
- -----------------------------------
- -- Build_Finalization_Collection --
- -----------------------------------
+ -------------------------------
+ -- Build_Finalization_Master --
+ -------------------------------
- procedure Build_Finalization_Collection
+ procedure Build_Finalization_Master
(Typ : Entity_Id;
Ins_Node : Node_Id := Empty;
Encl_Scope : Entity_Id := Empty)
is
Desig_Typ : constant Entity_Id := Directly_Designated_Type (Typ);
+ Ptr_Typ : Entity_Id := Root_Type (Base_Type (Typ));
function In_Deallocation_Instance (E : Entity_Id) return Boolean;
-- Determine whether entity E is inside a wrapper package created for
return False;
end In_Deallocation_Instance;
- -- Start of processing for Build_Finalization_Collection
+ -- Start of processing for Build_Finalization_Master
begin
+ if Is_Private_Type (Ptr_Typ)
+ and then Present (Full_View (Ptr_Typ))
+ then
+ Ptr_Typ := Full_View (Ptr_Typ);
+ end if;
+
-- Certain run-time configurations and targets do not provide support
-- for controlled types.
if Restriction_Active (No_Finalization) then
return;
+ -- Do not process C, C++, CIL and Java types since it is assumend that
+ -- the non-Ada side will handle their clean up.
+
+ elsif Convention (Desig_Typ) = Convention_C
+ or else Convention (Desig_Typ) = Convention_CIL
+ or else Convention (Desig_Typ) = Convention_CPP
+ or else Convention (Desig_Typ) = Convention_Java
+ then
+ return;
+
-- Various machinery such as freezing may have already created a
- -- collection.
+ -- finalization master.
- elsif Present (Associated_Collection (Typ)) then
+ elsif Present (Finalization_Master (Ptr_Typ)) then
return;
-- Do not process types that return on the secondary stack
- -- ??? The need for a secondary stack should be revisited and perhaps
- -- changed.
-
- elsif Present (Associated_Storage_Pool (Typ))
- and then Is_RTE (Associated_Storage_Pool (Typ), RE_SS_Pool)
+ elsif Present (Associated_Storage_Pool (Ptr_Typ))
+ and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
then
return;
-- Do not process types which may never allocate an object
- elsif No_Pool_Assigned (Typ) then
+ elsif No_Pool_Assigned (Ptr_Typ) then
return;
-- Do not process access types coming from Ada.Unchecked_Deallocation
-- instances. Even though the designated type may be controlled, the
-- access type will never participate in allocation.
- elsif In_Deallocation_Instance (Typ) then
+ elsif In_Deallocation_Instance (Ptr_Typ) then
return;
-- Ignore the general use of anonymous access types unless the context
- -- requires a collection.
+ -- requires a finalization master.
- elsif Ekind (Typ) = E_Anonymous_Access_Type
+ elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type
and then No (Ins_Node)
then
return;
-- Do not process non-library access types when restriction No_Nested_
- -- Finalization is in effect since collections are controlled objects.
+ -- Finalization is in effect since masters are controlled objects.
elsif Restriction_Active (No_Nested_Finalization)
- and then not Is_Library_Level_Entity (Typ)
+ and then not Is_Library_Level_Entity (Ptr_Typ)
then
return;
end if;
declare
- Loc : constant Source_Ptr := Sloc (Typ);
- Actions : constant List_Id := New_List;
- Coll_Id : Entity_Id;
- Pool_Id : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (Ptr_Typ);
+ Actions : constant List_Id := New_List;
+ Fin_Mas_Id : Entity_Id;
+ Pool_Id : Entity_Id;
begin
-- Generate:
- -- Fnn : Finalization_Collection;
+ -- Fnn : aliased Finalization_Master;
- -- Source access types use fixed names for their collections since
- -- the collection is inserted only once in the same source unit and
- -- there is no possible name overlap. Internally-generated access
- -- types on the other hand use temporaries as collection names due
- -- to possible name collisions.
+ -- Source access types use fixed master names since the master is
+ -- inserted in the same source unit only once. The only exception to
+ -- this are instances using the same access type as generic actual.
- if Comes_From_Source (Typ) then
- Coll_Id :=
+ if Comes_From_Source (Ptr_Typ)
+ and then not Inside_A_Generic
+ then
+ Fin_Mas_Id :=
Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "FC"));
+ Chars => New_External_Name (Chars (Ptr_Typ), "FM"));
+
+ -- Internally generated access types use temporaries as their names
+ -- due to possible collision with identical names coming from other
+ -- packages.
+
else
- Coll_Id := Make_Temporary (Loc, 'F');
+ Fin_Mas_Id := Make_Temporary (Loc, 'F');
end if;
Append_To (Actions,
Make_Object_Declaration (Loc,
- Defining_Identifier => Coll_Id,
+ Defining_Identifier => Fin_Mas_Id,
+ Aliased_Present => True,
Object_Definition =>
- New_Reference_To (RTE (RE_Finalization_Collection), Loc)));
+ New_Reference_To (RTE (RE_Finalization_Master), Loc)));
-- Storage pool selection and attribute decoration of the generated
- -- collection. Since .NET/JVM compilers do not support pools, this
- -- step is skipped.
+ -- master. Since .NET/JVM compilers do not support pools, this step
+ -- is skipped.
if VM_Target = No_VM then
-- If the access type has a user-defined pool, use it as the base
-- storage medium for the finalization pool.
- if Present (Associated_Storage_Pool (Typ)) then
- Pool_Id := Associated_Storage_Pool (Typ);
-
- -- Access subtypes must use the storage pool of their base type
-
- elsif Ekind (Typ) = E_Access_Subtype then
- declare
- Base_Typ : constant Entity_Id := Base_Type (Typ);
-
- begin
- if No (Associated_Storage_Pool (Base_Typ)) then
- Pool_Id := Get_Global_Pool_For_Access_Type (Base_Typ);
- Set_Associated_Storage_Pool (Base_Typ, Pool_Id);
- else
- Pool_Id := Associated_Storage_Pool (Base_Typ);
- end if;
- end;
+ if Present (Associated_Storage_Pool (Ptr_Typ)) then
+ Pool_Id := Associated_Storage_Pool (Ptr_Typ);
-- The default choice is the global pool
else
- Pool_Id := Get_Global_Pool_For_Access_Type (Typ);
- Set_Associated_Storage_Pool (Typ, Pool_Id);
+ Pool_Id := Get_Global_Pool_For_Access_Type (Ptr_Typ);
+ Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
end if;
-- Generate:
- -- Set_Storage_Pool_Ptr (Fnn, Pool_Id'Unchecked_Access);
+ -- Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access);
Append_To (Actions,
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Reference_To (RTE (RE_Set_Storage_Pool_Ptr), Loc),
+ New_Reference_To (RTE (RE_Set_Base_Pool), Loc),
Parameter_Associations => New_List (
- New_Reference_To (Coll_Id, Loc),
+ New_Reference_To (Fin_Mas_Id, Loc),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Pool_Id, Loc),
Attribute_Name => Name_Unrestricted_Access))));
end if;
- Set_Associated_Collection (Typ, Coll_Id);
+ Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
- -- A finalization collection created for an anonymous access type
- -- must be inserted before a context-dependent node.
+ -- A finalization master created for an anonymous access type must be
+ -- inserted before a context-dependent node.
if Present (Ins_Node) then
Push_Scope (Encl_Scope);
Pop_Scope;
- elsif Ekind (Typ) = E_Access_Subtype
- or else (Ekind (Desig_Typ) = E_Incomplete_Type
- and then Has_Completion_In_Body (Desig_Typ))
+ elsif Ekind (Desig_Typ) = E_Incomplete_Type
+ and then Has_Completion_In_Body (Desig_Typ)
then
- Insert_Actions (Parent (Typ), Actions);
+ Insert_Actions (Parent (Ptr_Typ), Actions);
-- If the designated type is not yet frozen, then append the actions
-- to that type's freeze actions. The actions need to be appended to
then
Append_Freeze_Actions (Desig_Typ, Actions);
- elsif Present (Freeze_Node (Typ))
- and then not Analyzed (Freeze_Node (Typ))
+ elsif Present (Freeze_Node (Ptr_Typ))
+ and then not Analyzed (Freeze_Node (Ptr_Typ))
then
- Append_Freeze_Actions (Typ, Actions);
+ Append_Freeze_Actions (Ptr_Typ, Actions);
-- If there's a pool created locally for the access type, then we
- -- need to ensure that the collection gets created after the pool
- -- object, because otherwise we can have a forward reference, so
- -- we force the collection actions to be inserted and analyzed after
- -- the pool entity. Note that both the access type and its designated
- -- type may have already been frozen and had their freezing actions
- -- analyzed at this point. (This seems a little unclean.???)
+ -- need to ensure that the master gets created after the pool object,
+ -- because otherwise we can have a forward reference, so we force the
+ -- master actions to be inserted and analyzed after the pool entity.
+ -- Note that both the access type and its designated type may have
+ -- already been frozen and had their freezing actions analyzed at
+ -- this point. (This seems a little unclean.???)
elsif VM_Target = No_VM
- and then Scope (Pool_Id) = Scope (Typ)
+ and then Scope (Pool_Id) = Scope (Ptr_Typ)
then
Insert_List_After_And_Analyze (Parent (Pool_Id), Actions);
else
- Insert_Actions (Parent (Typ), Actions);
+ Insert_Actions (Parent (Ptr_Typ), Actions);
end if;
end;
- end Build_Finalization_Collection;
+ end Build_Finalization_Master;
---------------------
-- Build_Finalizer --
-- A general flag which denotes whether N has at least one controlled
-- object.
+ Has_Tagged_Types : Boolean := False;
+ -- A general flag which indicates whether N has at least one library-
+ -- level tagged type declaration.
+
HSS : Node_Id := Empty;
-- The sequence of statements of N (if available)
Jump_Alts : List_Id := No_List;
-- Jump block alternatives. Depending on the value of the state counter,
- -- the control flow jumps to a sequence of finalization statments. This
+ -- the control flow jumps to a sequence of finalization statements. This
-- list contains the following:
--
-- when <counter value> =>
Spec_Decls : List_Id := Top_Decls;
Stmts : List_Id := No_List;
+ Tagged_Type_Stmts : List_Id := No_List;
+ -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
+ -- tagged types found in N.
+
-----------------------
-- Local subprograms --
-----------------------
-- where Decl does not have initialization call(s). Flag Is_Protected
-- is set when Decl denotes a simple protected object.
+ procedure Process_Tagged_Type_Declaration (Decl : Node_Id);
+ -- Generate all the code necessary to unregister the external tag of a
+ -- tagged type.
+
----------------------
-- Build_Components --
----------------------
else
Finalizer_Stmts := New_List;
end if;
+
+ if Has_Tagged_Types then
+ Tagged_Type_Stmts := New_List;
+ end if;
end Build_Components;
----------------------
-- The local exception does not need to be reraised for library-
-- level finalizers. Generate:
--
- -- if Raised then
- -- Raise_From_Controlled_Operation (E, Abort);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
-- end if;
if not For_Package
end if;
end if;
+ -- Add the library-level tagged type unregistration machinery before
+ -- the jump block circuitry. This ensures that external tags will be
+ -- removed even if a finalization exception occurs at some point.
+
+ if Has_Tagged_Types then
+ Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts);
+ end if;
+
-- Add a call to the previous At_End handler if it exists. The call
-- must always precede the jump block.
-- Generate:
-- procedure Fin_Id is
- -- Abort : constant Boolean :=
- -- Exception_Occurrence (Get_Current_Excep.all.all) =
- -- Standard'Abort_Signal'Identity;
+ -- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
and then Exceptions_OK
then
Prepend_List_To (Finalizer_Decls,
- Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id));
+ Build_Object_Declarations
+ (Loc, Abort_Id, E_Id, Raised_Id, For_Package));
end if;
-- Create the body of the finalizer
Is_Protected : Boolean := False)
is
begin
- if Preprocess then
- Counter_Val := Counter_Val + 1;
- Has_Ctrl_Objs := True;
+ -- Library-level tagged type
- if Top_Level
- and then No (Last_Top_Level_Ctrl_Construct)
- then
- Last_Top_Level_Ctrl_Construct := Decl;
+ if Nkind (Decl) = N_Full_Type_Declaration then
+ if Preprocess then
+ Has_Tagged_Types := True;
+
+ if Top_Level
+ and then No (Last_Top_Level_Ctrl_Construct)
+ then
+ Last_Top_Level_Ctrl_Construct := Decl;
+ end if;
+
+ else
+ Process_Tagged_Type_Declaration (Decl);
end if;
+
+ -- Controlled object declaration
+
else
- Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
+ if Preprocess then
+ Counter_Val := Counter_Val + 1;
+ Has_Ctrl_Objs := True;
+
+ if Top_Level
+ and then No (Last_Top_Level_Ctrl_Construct)
+ then
+ Last_Top_Level_Ctrl_Construct := Decl;
+ end if;
+
+ else
+ Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
+ end if;
end if;
end Processing_Actions;
Decl := Last_Non_Pragma (Decls);
while Present (Decl) loop
+ -- Library-level tagged types
+
+ if Nkind (Decl) = N_Full_Type_Declaration then
+ Typ := Defining_Identifier (Decl);
+
+ if Is_Tagged_Type (Typ)
+ and then Is_Library_Level_Entity (Typ)
+ and then Convention (Typ) = Convention_Ada
+ and then Present (Access_Disp_Table (Typ))
+ and then RTE_Available (RE_Register_Tag)
+ and then not No_Run_Time_Mode
+ and then not Is_Abstract_Type (Typ)
+ then
+ Processing_Actions;
+ end if;
+
-- Regular object declarations
- if Nkind (Decl) = N_Object_Declaration then
+ elsif Nkind (Decl) = N_Object_Declaration then
Obj_Id := Defining_Identifier (Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
Expr := Expression (Decl);
end if;
-- Inspect the freeze node of an access-to-controlled type and
- -- look for a delayed finalization collection. This case arises
- -- when the freeze actions are inserted at a later time than the
+ -- look for a delayed finalization master. This case arises when
+ -- the freeze actions are inserted at a later time than the
-- expansion of the context. Since Build_Finalizer is never called
- -- on a single construct twice, the collection will be ultimately
+ -- on a single construct twice, the master will be ultimately
-- left out and never finalized. This is also needed for freeze
-- actions of designated types themselves, since in some cases the
- -- finalization collection is associated with a designated type's
+ -- finalization master is associated with a designated type's
-- freeze node rather than that of the access type (see handling
- -- for freeze actions in Build_Finalization_Collection).
+ -- for freeze actions in Build_Finalization_Master).
elsif Nkind (Decl) = N_Freeze_Entity
and then Present (Actions (Decl))
-- Freeze nodes are considered to be identical to packages
-- and blocks in terms of nesting. The difference is that
- -- a finalization collection created inside the freeze node
- -- is at the same nesting level as the node itself.
+ -- a finalization master created inside the freeze node is
+ -- at the same nesting level as the node itself.
Process_Declarations (Actions (Decl), Preprocess);
- -- The freeze node contains a finalization collection
+ -- The freeze node contains a finalization master
if Preprocess
and then Top_Level
-- following cleanup code:
--
-- if BIPallocfrom > Secondary_Stack'Pos
- -- and then BIPcollection /= null
+ -- and then BIPfinalizationmaster /= null
-- then
-- declare
-- type Ptr_Typ is access Obj_Typ;
- -- for Ptr_Typ'Storage_Pool use Base_Pool (BIPcollection);
+ -- for Ptr_Typ'Storage_Pool
+ -- use Base_Pool (BIPfinalizationmaster);
--
-- begin
-- Free (Ptr_Typ (Temp));
function Build_BIP_Cleanup_Stmts
(Func_Id : Entity_Id) return Node_Id
is
- Collect : constant Entity_Id :=
- Build_In_Place_Formal (Func_Id, BIP_Collection);
- Decls : constant List_Id := New_List;
- Obj_Typ : constant Entity_Id := Etype (Func_Id);
- Temp_Id : constant Entity_Id :=
- Entity (Prefix (Name (Parent (Obj_Id))));
+ Decls : constant List_Id := New_List;
+ Fin_Mas_Id : constant Entity_Id :=
+ Build_In_Place_Formal
+ (Func_Id, BIP_Finalization_Master);
+ Obj_Typ : constant Entity_Id := Etype (Func_Id);
+ Temp_Id : constant Entity_Id :=
+ Entity (Prefix (Name (Parent (Obj_Id))));
Cond : Node_Id;
Free_Blk : Node_Id;
begin
-- Generate:
- -- Pool_Id renames Base_Pool (BIPcollection.all).all;
+ -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
Pool_Id := Make_Temporary (Loc, 'P');
New_Reference_To (RTE (RE_Base_Pool), Loc),
Parameter_Associations => New_List (
Make_Explicit_Dereference (Loc,
- Prefix => New_Reference_To (Collect, Loc)))))));
+ Prefix => New_Reference_To (Fin_Mas_Id, Loc)))))));
-- Create an access type which uses the storage pool of the
- -- caller's collection.
+ -- caller's finalization master.
-- Generate:
-- type Ptr_Typ is access Obj_Typ;
Make_Access_To_Object_Definition (Loc,
Subtype_Indication => New_Reference_To (Obj_Typ, Loc))));
- -- Perform minor decoration in order to set the collection and the
+ -- Perform minor decoration in order to set the master and the
-- storage pool attributes.
Set_Ekind (Ptr_Typ, E_Access_Type);
- Set_Associated_Collection (Ptr_Typ, Collect);
+ Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
-- Create an explicit free statement. Note that the free uses the
Statements => New_List (Free_Stmt)));
-- Generate:
- -- if BIPcollection /= null then
+ -- if BIPfinalizationmaster /= null then
Cond :=
Make_Op_Ne (Loc,
- Left_Opnd => New_Reference_To (Collect, Loc),
+ Left_Opnd => New_Reference_To (Fin_Mas_Id, Loc),
Right_Opnd => Make_Null (Loc));
-- For constrained or tagged results escalate the condition to
-- include the allocation format. Generate:
--
-- if BIPallocform > Secondary_Stack'Pos
- -- and then BIPcollection /= null
+ -- and then BIPfinalizationmaster /= null
-- then
if not Is_Constrained (Obj_Typ)
-- call and if it is, try to match the name of the call with the
-- [Deep_]Initialize proc of Typ.
+ function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
+ -- Given a statement which is part of a list, return the next
+ -- real statement while skipping over dynamic elab checks.
+
------------------
-- Is_Init_Call --
------------------
and then Nkind (Name (N)) = N_Identifier
then
declare
- Call_Nam : constant Name_Id := Chars (Entity (Name (N)));
+ Call_Ent : constant Entity_Id := Entity (Name (N));
Deep_Init : constant Entity_Id :=
TSS (Typ, TSS_Deep_Initialize);
Init : Entity_Id := Empty;
if Is_Controlled (Typ) then
Init := Find_Prim_Op (Typ, Name_Initialize);
+
+ if Present (Init) then
+ Init := Ultimate_Alias (Init);
+ end if;
end if;
return
(Present (Deep_Init)
- and then Chars (Deep_Init) = Call_Nam)
+ and then Call_Ent = Deep_Init)
or else
(Present (Init)
- and then Chars (Init) = Call_Nam);
+ and then Call_Ent = Init);
end;
end if;
return False;
end Is_Init_Call;
+ -----------------------------
+ -- Next_Suitable_Statement --
+ -----------------------------
+
+ function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
+ Result : Node_Id := Next (Stmt);
+
+ begin
+ -- Skip over access-before-elaboration checks
+
+ if Dynamic_Elaboration_Checks
+ and then Nkind (Result) = N_Raise_Program_Error
+ then
+ Result := Next (Result);
+ end if;
+
+ return Result;
+ end Next_Suitable_Statement;
+
-- Start of processing for Find_Last_Init
begin
Utyp := Typ;
end if;
+ if Is_Private_Type (Utyp)
+ and then Present (Full_View (Utyp))
+ then
+ Utyp := Full_View (Utyp);
+ end if;
+
-- The init procedures are arranged as follows:
-- Object : Controlled_Type;
-- where the user-defined initialize may be optional or may appear
-- inside a block when abort deferral is needed.
- Nod_1 := Next (Decl);
+ Nod_1 := Next_Suitable_Statement (Decl);
if Present (Nod_1) then
- Nod_2 := Next (Nod_1);
+ Nod_2 := Next_Suitable_Statement (Nod_1);
-- The statement following an object declaration is always a
-- call to the type init proc.
-- If we are dealing with a return object of a build-in-place
-- function, generate the following cleanup statements:
--
- -- if BIPallocfrom > Secondary_Stack'Pos then
+ -- if BIPallocfrom > Secondary_Stack'Pos
+ -- and then BIPfinalizationmaster /= null
+ -- then
-- declare
-- type Ptr_Typ is access Obj_Typ;
-- for Ptr_Typ'Storage_Pool use
- -- Base_Pool (BIPcollection.all).all;
+ -- Base_Pool (BIPfinalizationmaster.all).all;
--
-- begin
-- Free (Ptr_Typ (Temp));
-- end if;
--
-- The generated code effectively detaches the temporary from the
- -- caller finalization chain and deallocates the object. This is
+ -- caller finalization master and deallocates the object. This is
-- disabled on .NET/JVM because pools are not supported.
- -- H505-021 This needs to be revisited on .NET/JVM
-
if VM_Target = No_VM and then Is_Return_Object (Obj_Id) then
declare
Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
begin
if Is_Build_In_Place_Function (Func_Id)
- and then Needs_BIP_Collection (Func_Id)
+ and then Needs_BIP_Finalization_Master (Func_Id)
then
Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
end if;
Counter_Val := Counter_Val - 1;
end Process_Object_Declaration;
+ -------------------------------------
+ -- Process_Tagged_Type_Declaration --
+ -------------------------------------
+
+ procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
+ Typ : constant Entity_Id := Defining_Identifier (Decl);
+ DT_Ptr : constant Entity_Id :=
+ Node (First_Elmt (Access_Disp_Table (Typ)));
+ begin
+ -- Generate:
+ -- Ada.Tags.Unregister_Tag (<Typ>P);
+
+ Append_To (Tagged_Type_Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Unregister_Tag), Loc),
+ Parameter_Associations => New_List (
+ New_Reference_To (DT_Ptr, Loc))));
+ end Process_Tagged_Type_Declaration;
+
-- Start of processing for Build_Finalizer
begin
Fin_Id := Empty;
- -- Step 1: Extract all lists which may contain controlled objects
+ -- Step 1: Extract all lists which may contain controlled objects or
+ -- library-level tagged types.
if For_Package_Spec then
Decls := Visible_Declarations (Specification (N));
-- cases, the finalizer must be created and carry the additional
-- statements.
- if Acts_As_Clean or else Has_Ctrl_Objs then
+ if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
Build_Components;
end if;
- -- The preprocessing has determined that the context has objects that
- -- need finalization actions.
+ -- The preprocessing has determined that the context has controlled
+ -- objects or library-level tagged types.
- if Has_Ctrl_Objs then
+ if Has_Ctrl_Objs or Has_Tagged_Types then
-- Private declarations are processed first in order to preserve
-- possible dependencies between public and private objects.
-- cases, the finalizer must be created and carry the additional
-- statements.
- if Acts_As_Clean or else Has_Ctrl_Objs then
+ if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
Build_Components;
end if;
- if Has_Ctrl_Objs then
+ if Has_Ctrl_Objs or Has_Tagged_Types then
Process_Declarations (Stmts);
Process_Declarations (Decls);
end if;
-- Step 3: Finalizer creation
- if Acts_As_Clean or else Has_Ctrl_Objs then
+ if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
Create_Finalizer;
end if;
end Build_Finalizer;
-------------------------------
function Build_Object_Declarations
- (Loc : Source_Ptr;
- Abort_Id : Entity_Id;
- E_Id : Entity_Id;
- Raised_Id : Entity_Id) return List_Id
+ (Loc : Source_Ptr;
+ Abort_Id : Entity_Id;
+ E_Id : Entity_Id;
+ Raised_Id : Entity_Id;
+ For_Package : Boolean := False) return List_Id
is
A_Expr : Node_Id;
E_Decl : Node_Id;
-- does not include routine Raise_From_Controlled_Operation which is the
-- the sole user of flag Abort.
+ -- This is not needed for library-level finalizers as they are called
+ -- by the environment task and cannot be aborted.
+
if Abort_Allowed
and then VM_Target = No_VM
+ and then not For_Package
then
- declare
- Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'E');
-
- begin
- -- Generate:
- -- Temp : constant Exception_Occurrence_Access :=
- -- Get_Current_Excep.all;
-
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp_Id,
- Constant_Present => True,
- Object_Definition =>
- New_Reference_To (RTE (RE_Exception_Occurrence_Access), Loc),
- Expression =>
- Make_Function_Call (Loc,
- Name =>
- Make_Explicit_Dereference (Loc,
- Prefix =>
- New_Reference_To
- (RTE (RE_Get_Current_Excep), Loc)))));
-
- -- Generate:
- -- Temp /= null
- -- and then Exception_Identity (Temp.all) =
- -- Standard'Abort_Signal'Identity;
+ A_Expr := New_Reference_To (RTE (RE_Triggered_By_Abort), Loc);
- A_Expr :=
- Make_And_Then (Loc,
- Left_Opnd =>
- Make_Op_Ne (Loc,
- Left_Opnd => New_Reference_To (Temp_Id, Loc),
- Right_Opnd => Make_Null (Loc)),
-
- Right_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Exception_Identity), Loc),
- Parameter_Associations => New_List (
- Make_Explicit_Dereference (Loc,
- Prefix => New_Reference_To (Temp_Id, Loc)))),
-
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Reference_To (Stand.Abort_Signal, Loc),
- Attribute_Name => Name_Identity)));
- end;
-
- -- No abort or .NET/JVM
+ -- No abort, .NET/JVM or library-level finalizers
else
A_Expr := New_Reference_To (Standard_False, Loc);
E_Id : Entity_Id;
Raised_Id : Entity_Id) return Node_Id
is
- Params : List_Id;
- Proc_Id : Entity_Id;
+ Stmt : Node_Id;
begin
- -- The default parameter is the local exception occurrence
-
- Params := New_List (New_Reference_To (E_Id, Loc));
-
- -- Standard run-time, .NET/JVM targets, this case handles finalization
- -- exceptions raised during an abort.
+ -- Standard run-time and .NET/JVM targets use the specialized routine
+ -- Raise_From_Controlled_Operation.
if RTE_Available (RE_Raise_From_Controlled_Operation) then
- Proc_Id := RTE (RE_Raise_From_Controlled_Operation);
- Append_To (Params, New_Reference_To (Abort_Id, Loc));
+ Stmt :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To
+ (RTE (RE_Raise_From_Controlled_Operation), Loc),
+ Parameter_Associations =>
+ New_List (New_Reference_To (E_Id, Loc)));
-- Restricted runtime: exception messages are not supported and hence
- -- Raise_From_Controlled_Operation is not supported.
+ -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
+ -- instead.
else
- Proc_Id := RTE (RE_Reraise_Occurrence);
+ Stmt :=
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Finalize_Raised_Exception);
end if;
-- Generate:
- -- if Raised_Id then
- -- <Proc_Id> (<Params>);
+ -- if Raised_Id and then not Abort_Id then
+ -- Raise_From_Controlled_Operation (E_Id);
+ -- <or>
+ -- raise Program_Error; -- restricted runtime
-- end if;
return
Make_If_Statement (Loc,
- Condition => New_Reference_To (Raised_Id, Loc),
- Then_Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (Proc_Id, Loc),
- Parameter_Associations => Params)));
+ Condition =>
+ Make_And_Then (Loc,
+ Left_Opnd => New_Reference_To (Raised_Id, Loc),
+ Right_Opnd =>
+ Make_Op_Not (Loc,
+ Right_Opnd => New_Reference_To (Abort_Id, Loc))),
+
+ Then_Statements => New_List (Stmt));
end Build_Raise_Statement;
-----------------------------
elsif Nkind (Wrap_Node) = N_Iteration_Scheme then
null;
+ -- In formal verification mode, if the node to wrap is a pragma check,
+ -- this node and enclosed expression are not expanded, so do not apply
+ -- any transformations here.
+
+ elsif ALFA_Mode
+ and then Nkind (Wrap_Node) = N_Pragma
+ and then Get_Pragma_Id (Wrap_Node) = Pragma_Check
+ then
+ null;
+
else
Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
Set_Scope_Is_Transient;
if Ekind (Spec_Ent) /= E_Generic_Package then
Build_Finalizer
(N => N,
- Clean_Stmts => Build_Cleanup_Statements (N),
+ Clean_Stmts => No_List,
Mark_Id => Empty,
Top_Decls => No_List,
Defer_Abort => False,
if Ekind (Id) /= E_Generic_Package then
Build_Finalizer
(N => N,
- Clean_Stmts => Build_Cleanup_Statements (N),
+ Clean_Stmts => No_List,
Mark_Id => Empty,
Top_Decls => No_List,
Defer_Abort => False,
-- exception
-- when others =>
- -- if not Rnn then
- -- Rnn := True;
+ -- if not Raised then
+ -- Raised := True;
-- Save_Occurrence
-- (Enn, Get_Current_Excep.all.all);
-- end if;
end loop;
-- Generate:
- -- if Rnn then
- -- Raise_From_Controlled_Operation (E, Abort);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
-- end if;
if Built
Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
end if;
- -- For types that are both controlled and have controlled components,
- -- generate a call to Deep_Adjust.
-
- elsif Is_Controlled (Utyp)
- and then Has_Controlled_Component (Utyp)
- then
- Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
-
- -- For types that are not controlled themselves, but contain controlled
- -- components or can be extended by types with controlled components,
- -- create a call to Deep_Adjust.
+ -- Class-wide types, interfaces and types with controlled components
elsif Is_Class_Wide_Type (Typ)
+ or else Is_Interface (Typ)
or else Has_Controlled_Component (Utyp)
then
if Is_Tagged_Type (Utyp) then
Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
end if;
- -- For types that are derived from Controlled and do not have controlled
- -- components, build a call to Adjust.
+ -- Derivations from [Limited_]Controlled
+
+ elsif Is_Controlled (Utyp) then
+ if Has_Controlled_Component (Utyp) then
+ Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
+ else
+ Adj_Id := Find_Prim_Op (Utyp, Name_Of (Adjust_Case));
+ end if;
+
+ -- Tagged types
+
+ elsif Is_Tagged_Type (Utyp) then
+ Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
else
- Adj_Id := Find_Prim_Op (Utyp, Name_Of (Adjust_Case));
+ raise Program_Error;
end if;
if Present (Adj_Id) then
(Obj_Ref : Node_Id;
Ptr_Typ : Entity_Id) return Node_Id
is
+ pragma Assert (VM_Target /= No_VM);
+
Loc : constant Source_Ptr := Sloc (Obj_Ref);
begin
return
Name =>
New_Reference_To (RTE (RE_Attach), Loc),
Parameter_Associations => New_List (
- New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
+ New_Reference_To (Finalization_Master (Ptr_Typ), Loc),
Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
end Make_Attach_Call;
-- controlled elements. Generate:
--
-- declare
- -- Temp : constant Exception_Occurrence_Access :=
- -- Get_Current_Excep.all;
- -- Abort : constant Boolean :=
- -- Temp /= null
- -- and then Exception_Identity (Temp_Id.all) =
- -- Standard'Abort_Signal'Identity;
+ -- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
--
-- ...
-- end loop;
--
- -- if Raised then
- -- Raise_From_Controlled_Operation (E, Abort);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
-- exception
-- when others =>
-- declare
- -- Temp : constant Exception_Occurrence_Access :=
- -- Get_Current_Excep.all;
- -- Abort : constant Boolean :=
- -- Temp /= null
- -- and then Exception_Identity (Temp_Id.all) =
- -- Standard'Abort_Signal'Identity;
+ -- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
-- E : Exception_Occurence;
-- end loop;
-- end;
- -- if Raised then
- -- Raise_From_Controlled_Operation (E, Abort);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
-- end if;
-- raise;
-- the conditional raise:
-- declare
- -- Abort : constant Boolean :=
- -- Exception_Occurrence (Get_Current_Excep.all.all) =
- -- Standard'Abort_Signal'Identity;
+ -- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
-- begin
-- <core loop>
- -- if Raised then -- Expection handlers allowed
- -- Raise_From_Controlled_Operation (E, Abort);
+ -- if Raised and then not Abort then -- Expection handlers OK
+ -- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
-- raised flag and the conditional raise.
-- declare
- -- Abort : constant Boolean :=
- -- Exception_Occurrence (Get_Current_Excep.all.all) =
- -- Standard'Abort_Signal'Identity;
+ -- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
-- <final loop>
- -- if Raised then -- Exception handlers allowed
- -- Raise_From_Controlled_Operation (E, Abort);
+ -- if Raised and then not Abort then -- Exception handlers OK
+ -- Raise_From_Controlled_Operation (E);
-- end if;
- -- raise; -- Exception handlers allowed
+ -- raise; -- Exception handlers OK
-- end;
Stmts := New_List (Build_Counter_Assignment, Final_Loop);
-- have discriminants and contain variant parts. Generate:
--
-- begin
- -- Root_Controlled (V).Finalized := False;
- --
-- begin
-- [Deep_]Adjust (V.Comp_1);
-- exception
-- end;
-- end if;
--
- -- if Raised then
- -- Raise_From_Controlled_Object (E, Abort);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
-- may have discriminants and contain variant parts. Generate:
--
-- declare
- -- Temp : constant Exception_Occurrence_Access :=
- -- Get_Current_Excep.all;
- -- Abort : constant Boolean :=
- -- Temp /= null
- -- and then Exception_Identity (Temp_Id.all) =
- -- Standard'Abort_Signal'Identity;
+ -- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
-- E : Exception_Occurence;
-- Raised : Boolean := False;
--
-- begin
- -- if Root_Controlled (V).Finalized then
- -- return;
- -- end if;
- --
-- if F then
-- begin
-- Finalize (V); -- If applicable
-- end if;
-- end;
--
- -- Root_Controlled (V).Finalized := True;
- --
- -- if Raised then
- -- Raise_From_Controlled_Object (E, Abort);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
-- Generate:
-- declare
- -- Abort : constant Boolean :=
- -- Exception_Occurrence (Get_Current_Excep.all.all) =
- -- Standard'Abort_Signal'Identity;
+ -- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
-- Raised : Boolean := False;
-- begin
- -- Root_Controlled (V).Finalized := False;
-
-- <adjust statements>
- -- if Raised then
- -- Raise_From_Controlled_Operation (E, Abort);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
-- Generate:
-- declare
- -- Abort : constant Boolean :=
- -- Exception_Occurrence (Get_Current_Excep.all.all) =
- -- Standard'Abort_Signal'Identity;
+ -- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
-- Raised : Boolean := False;
-- begin
- -- if V.Finalized then
- -- return;
- -- end if;
-
-- <finalize statements>
- -- V.Finalized := True;
- -- if Raised then
- -- Raise_From_Controlled_Operation (E, Abort);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
end if;
- -- For types that are both controlled and have controlled components,
- -- generate a call to Deep_Finalize.
-
- elsif Is_Controlled (Utyp)
- and then Has_Controlled_Component (Utyp)
- then
- Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
-
- -- For types that are not controlled themselves, but contain controlled
- -- components or can be extended by types with controlled components,
- -- create a call to Deep_Finalize.
+ -- Class-wide types, interfaces and types with controlled components
elsif Is_Class_Wide_Type (Typ)
or else Is_Interface (Typ)
Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
end if;
- -- For types that are derived from Controlled and do not have controlled
- -- components, build a call to Finalize.
+ -- Derivations from [Limited_]Controlled
+
+ elsif Is_Controlled (Utyp) then
+ if Has_Controlled_Component (Utyp) then
+ Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
+ else
+ Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
+ end if;
+
+ -- Tagged types
+
+ elsif Is_Tagged_Type (Utyp) then
+ Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
else
- Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
+ raise Program_Error;
end if;
if Present (Fin_Id) then
--------------------------------
procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
+ Is_Task : constant Boolean :=
+ Ekind (Typ) = E_Record_Type
+ and then Is_Concurrent_Record_Type (Typ)
+ and then Ekind (Corresponding_Concurrent_Type (Typ)) =
+ E_Task_Type;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Proc_Id : Entity_Id;
+ Stmts : List_Id;
+
begin
+ -- The corresponding records of task types are not controlled by design.
+ -- For the sake of completeness, create an empty Finalize_Address to be
+ -- used in task class-wide allocations.
+
+ if Is_Task then
+ null;
+
-- Nothing to do if the type is not controlled or it already has a
-- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
-- come from source. These are usually generated for completeness and
-- do not need the Finalize_Address primitive.
- if not Needs_Finalization (Typ)
+ elsif not Needs_Finalization (Typ)
+ or else Is_Abstract_Type (Typ)
or else Present (TSS (Typ, TSS_Finalize_Address))
or else
(Is_Class_Wide_Type (Typ)
return;
end if;
- declare
- Loc : constant Source_Ptr := Sloc (Typ);
- Proc_Id : Entity_Id;
+ Proc_Id :=
+ Make_Defining_Identifier (Loc,
+ Make_TSS_Name (Typ, TSS_Finalize_Address));
- begin
- Proc_Id :=
- Make_Defining_Identifier (Loc,
- Make_TSS_Name (Typ, TSS_Finalize_Address));
+ -- Generate:
+ -- procedure <Typ>FD (V : System.Address) is
+ -- begin
+ -- null; -- for tasks
+ --
+ -- declare -- for all other types
+ -- type Pnn is access all Typ;
+ -- for Pnn'Storage_Size use 0;
+ -- begin
+ -- [Deep_]Finalize (Pnn (V).all);
+ -- end;
+ -- end TypFD;
- -- Generate:
- -- procedure TypFD (V : System.Address) is
- -- begin
- -- declare
- -- type Pnn is access all Typ;
- -- for Pnn'Storage_Size use 0;
- -- begin
- -- [Deep_]Finalize (Pnn (V).all);
- -- end;
- -- end TypFD;
+ if Is_Task then
+ Stmts := New_List (Make_Null_Statement (Loc));
+ else
+ Stmts := Make_Finalize_Address_Stmts (Typ);
+ end if;
- Discard_Node (
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Proc_Id,
+ Discard_Node (
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Proc_Id,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_V),
- Parameter_Type =>
- New_Reference_To (RTE (RE_Address), Loc)))),
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_V),
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Address), Loc)))),
- Declarations => No_List,
+ Declarations => No_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements =>
- Make_Finalize_Address_Stmts (Typ))));
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts)));
- Set_TSS (Typ, Proc_Id);
- end;
+ Set_TSS (Typ, Proc_Id);
end Make_Finalize_Address_Body;
---------------------------------
-- Generate:
-- when E : others =>
- -- Raise_From_Controlled_Operation (E, False);
+ -- Raise_From_Controlled_Operation (E);
-- or:
New_Reference_To
(RTE (RE_Raise_From_Controlled_Operation), Loc),
Parameter_Associations => New_List (
- New_Reference_To (E_Occ, Loc),
- New_Reference_To (Standard_False, Loc)));
+ New_Reference_To (E_Occ, Loc)));
-- Restricted runtime: exception messages are not supported
Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
end Make_Local_Deep_Finalize;
- ----------------------------------------
- -- Make_Set_Finalize_Address_Ptr_Call --
- ----------------------------------------
+ ------------------------------------
+ -- Make_Set_Finalize_Address_Call --
+ ------------------------------------
- function Make_Set_Finalize_Address_Ptr_Call
+ function Make_Set_Finalize_Address_Call
(Loc : Source_Ptr;
Typ : Entity_Id;
Ptr_Typ : Entity_Id) return Node_Id
end if;
-- Generate:
- -- Set_Finalize_Address_Ptr
- -- (<Ptr_Typ>FC, <Utyp>FD'Unrestricted_Access);
+ -- Set_Finalize_Address (<Ptr_Typ>FM, <Utyp>FD'Unrestricted_Access);
return
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Reference_To (RTE (RE_Set_Finalize_Address_Ptr), Loc),
-
+ New_Reference_To (RTE (RE_Set_Finalize_Address), Loc),
Parameter_Associations => New_List (
- New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
-
+ New_Reference_To (Finalization_Master (Ptr_Typ), Loc),
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (TSS (Utyp, TSS_Finalize_Address), Loc),
Attribute_Name => Name_Unrestricted_Access)));
- end Make_Set_Finalize_Address_Ptr_Call;
+ end Make_Set_Finalize_Address_Call;
--------------------------
-- Make_Transient_Block --