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. If N is
- -- neither of these constructs, the routine returns a new 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;
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 --
-----------------------
-- objects that need finalization. When flag Preprocess is set, the
-- routine will simply count the total number of controlled objects in
-- Decls. Flag Top_Level denotes whether the processing is done for
- -- objects in nested package decparations or instances.
+ -- objects in nested package declarations or instances.
procedure Process_Object_Declaration
(Decl : Node_Id;
-- 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);
-- The object is of the form:
-- Obj : Typ [:= Expr];
--
- -- Do not process the incomplete view of a deferred constant
+ -- Do not process the incomplete view of a deferred constant.
+ -- Do not consider tag-to-class-wide conversions.
elsif not Is_Imported (Obj_Id)
and then Needs_Finalization (Obj_Typ)
and then not (Ekind (Obj_Id) = E_Constant
and then not Has_Completion (Obj_Id))
+ and then not Is_Tag_To_CW_Conversion (Obj_Id)
then
Processing_Actions;
then
Processing_Actions (Has_No_Init => True);
+ -- Processing for "hook" objects generated for controlled
+ -- transients declared inside an Expression_With_Actions.
+
elsif Is_Access_Type (Obj_Typ)
and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
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.
Fin_Stmts := No_List;
if Is_Simple_Protected_Type (Obj_Typ) then
- Fin_Stmts :=
- New_List (Cleanup_Protected_Object (Decl, Obj_Ref));
+ Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
+ if Present (Fin_Call) then
+ Fin_Stmts := New_List (Fin_Call);
+ end if;
elsif Has_Simple_Protected_Object (Obj_Typ) then
if Is_Record_Type (Obj_Typ) then
-- 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));
if For_Package_Spec then
Process_Declarations
(Priv_Decls, Preprocess => True, Top_Level => True);
+ end if;
- -- The preprocessing has determined that the context has objects
- -- that need finalization actions. Private declarations are
- -- processed first in order to preserve possible dependencies
- -- between public and private objects.
+ -- The current context may lack controlled objects, but require some
+ -- other form of completion (task termination for instance). In such
+ -- cases, the finalizer must be created and carry the additional
+ -- statements.
- if Has_Ctrl_Objs then
- Build_Components;
- Process_Declarations (Priv_Decls);
- end if;
+ if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
+ Build_Components;
end if;
- -- Process the public declarations
+ -- The preprocessing has determined that the context has controlled
+ -- objects or library-level tagged types.
+
+ 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.
+
+ if For_Package_Spec then
+ Process_Declarations (Priv_Decls);
+ end if;
- if Has_Ctrl_Objs then
- Build_Components;
Process_Declarations (Decls);
end if;
-- 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');
+ A_Expr := New_Reference_To (RTE (RE_Triggered_By_Abort), Loc);
- 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 :=
- 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 and .NET/JVM targets use the specialized routine
+ -- Raise_From_Controlled_Operation.
- -- .NET/JVM
-
- if VM_Target /= No_VM then
- Proc_Id := RTE (RE_Reraise_Occurrence);
-
- -- Standard run-time library, this case handles finalization exceptions
- -- raised during an abort.
-
- elsif 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));
+ if RTE_Available (RE_Raise_From_Controlled_Operation) then
+ 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;
-----------------------------
Wrap_Node : Node_Id;
begin
- -- Nothing to do for virtual machines where memory is GCed
-
- if VM_Target /= No_VM then
- return;
- end if;
-
-- Do not create a transient scope if we are already inside one
for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
elsif Scope_Stack.Table (S).Entity = Standard_Standard then
exit;
-
end if;
end loop;
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;
and then VM_Target = No_VM;
Actions_Required : constant Boolean :=
- Has_Controlled_Objects (N)
+ Requires_Cleanup_Actions (N)
or else Is_Asynchronous_Call
or else Is_Master
or else Is_Protected_Body
-- Build dispatch tables of library level tagged types
- if Is_Library_Level_Entity (Spec_Ent) then
- if Tagged_Type_Expansion then
- Build_Static_Dispatch_Tables (N);
-
- -- In VM targets there is no need to build dispatch tables but
- -- we must generate the corresponding Type Specific Data record.
-
- elsif Unit (Cunit (Main_Unit)) = N then
-
- -- If the runtime package Ada_Tags has not been loaded then
- -- this package does not have tagged type declarations and
- -- there is no need to search for tagged types to generate
- -- their TSDs.
-
- if RTU_Loaded (Ada_Tags) then
- Build_VM_TSDs (N);
- end if;
- end if;
+ if Tagged_Type_Expansion
+ and then Is_Library_Level_Entity (Spec_Ent)
+ then
+ Build_Static_Dispatch_Tables (N);
end if;
Build_Task_Activation_Call (N);
-- Build dispatch tables of library level tagged types
- if Is_Compilation_Unit (Id)
- or else (Is_Generic_Instance (Id)
- and then Is_Library_Level_Entity (Id))
+ if Tagged_Type_Expansion
+ and then (Is_Compilation_Unit (Id)
+ or else (Is_Generic_Instance (Id)
+ and then Is_Library_Level_Entity (Id)))
then
- if Tagged_Type_Expansion then
- Build_Static_Dispatch_Tables (N);
-
- -- In VM targets there is no need to build dispatch tables, but we
- -- must generate the corresponding Type Specific Data record.
-
- elsif Unit (Cunit (Main_Unit)) = N then
-
- -- If the runtime package Ada_Tags has not been loaded then
- -- this package does not have tagged types and there is no need
- -- to search for tagged types to generate their TSDs.
-
- if RTU_Loaded (Ada_Tags) then
-
- -- Enter the scope of the package because the new declarations
- -- are appended at the end of the package and must be analyzed
- -- in that context.
-
- Push_Scope (Id);
-
- if Is_Generic_Instance (Main_Unit_Entity) then
- if Package_Instantiation (Main_Unit_Entity) = N then
- Build_VM_TSDs (N);
- end if;
-
- else
- Build_VM_TSDs (N);
- end if;
-
- Pop_Scope;
- end if;
- end if;
+ Build_Static_Dispatch_Tables (N);
end if;
-- Note: it is not necessary to worry about generating a subprogram
-- 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;
-- sometimes generate a loop and create transient objects inside
-- the loop.
- elsif Nkind (Stmt) = N_Loop_Statement then
- Process_Transient_Objects
- (First_Object => First (Statements (Stmt)),
- Last_Object => Last (Statements (Stmt)),
- Related_Node => Related_Node);
+ elsif Nkind (Related_Node) = N_Object_Declaration
+ and then Is_Array_Type (Base_Type
+ (Etype (Defining_Identifier (Related_Node))))
+ and then Nkind (Stmt) = N_Loop_Statement
+ then
+ declare
+ Block_HSS : Node_Id := First (Statements (Stmt));
+
+ begin
+ -- The loop statements may have been wrapped in a block by
+ -- Process_Statements_For_Controlled_Objects, inspect the
+ -- handled sequence of statements.
+
+ if Nkind (Block_HSS) = N_Block_Statement
+ and then No (Next (Block_HSS))
+ then
+ Block_HSS := Handled_Statement_Sequence (Block_HSS);
+
+ Process_Transient_Objects
+ (First_Object => First (Statements (Block_HSS)),
+ Last_Object => Last (Statements (Block_HSS)),
+ Related_Node => Related_Node);
+
+ -- Inspect the statements of the loop
+
+ else
+ Process_Transient_Objects
+ (First_Object => First (Statements (Stmt)),
+ Last_Object => Last (Statements (Stmt)),
+ Related_Node => Related_Node);
+ end if;
+ end;
-- Terminate the scan after the last object has been processed
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;
For_Parent : Boolean := False) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Obj_Ref);
+ Atyp : Entity_Id;
Fin_Id : Entity_Id := Empty;
Ref : Node_Id;
Utyp : Entity_Id;
if Is_Class_Wide_Type (Typ) then
Utyp := Root_Type (Typ);
+ Atyp := Utyp;
Ref := Obj_Ref;
elsif Is_Concurrent_Type (Typ) then
Utyp := Corresponding_Record_Type (Typ);
+ Atyp := Empty;
Ref := Convert_Concurrent (Obj_Ref, Typ);
elsif Is_Private_Type (Typ)
and then Is_Concurrent_Type (Full_View (Typ))
then
Utyp := Corresponding_Record_Type (Full_View (Typ));
+ Atyp := Typ;
Ref := Convert_Concurrent (Obj_Ref, Full_View (Typ));
else
Utyp := Typ;
+ Atyp := Typ;
Ref := Obj_Ref;
end if;
-- instead.
if Utyp /= Base_Type (Utyp) then
- pragma Assert (Is_Private_Type (Typ));
+ pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp));
Utyp := Base_Type (Utyp);
Ref := Unchecked_Convert_To (Utyp, Ref);
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:
-- Procedure call or raise statement
begin
- -- .NET/JVM runtime: add choice parameter E and pass it to Reraise_
- -- Occurrence.
+ -- Standard runtime, .NET/JVM targets: add choice parameter E and pass
+ -- it to Raise_From_Controlled_Operation so that the original exception
+ -- name and message can be recorded in the exception message for
+ -- Program_Error.
- if VM_Target /= No_VM then
- E_Occ := Make_Defining_Identifier (Loc, Name_E);
- Raise_Node :=
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Reraise_Occurrence), Loc),
- Parameter_Associations => New_List (
- New_Reference_To (E_Occ, Loc)));
-
- -- Standard runtime: add choice parameter E and pass it to Raise_From_
- -- Controlled_Operation so that the original exception name and message
- -- can be recorded in the exception message for Program_Error.
-
- elsif RTE_Available (RE_Raise_From_Controlled_Operation) then
+ if RTE_Available (RE_Raise_From_Controlled_Operation) then
E_Occ := Make_Defining_Identifier (Loc, Name_E);
Raise_Node :=
Make_Procedure_Call_Statement (Loc,
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 --
OSDN Git Service
