------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 7 -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -- This package contains virtually all expansion mechanisms related to -- - controlled types -- - transient scopes with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Exp_Ch6; use Exp_Ch6; with Exp_Ch9; use Exp_Ch9; with Exp_Ch11; use Exp_Ch11; with Exp_Dbug; use Exp_Dbug; with Exp_Dist; use Exp_Dist; with Exp_Disp; use Exp_Disp; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Lib; use Lib; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sinfo; use Sinfo; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Snames; use Snames; with Stand; use Stand; with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; package body Exp_Ch7 is -------------------------------- -- Transient Scope Management -- -------------------------------- -- A transient scope is created when temporary objects are created by the -- compiler. These temporary objects are allocated on the secondary stack -- and the transient scope is responsible for finalizing the object when -- appropriate and reclaiming the memory at the right time. The temporary -- objects are generally the objects allocated to store the result of a -- function returning an unconstrained or a tagged value. Expressions -- needing to be wrapped in a transient scope (functions calls returning -- unconstrained or tagged values) may appear in 3 different contexts which -- lead to 3 different kinds of transient scope expansion: -- 1. In a simple statement (procedure call, assignment, ...). In this -- case the instruction is wrapped into a transient block. See -- Wrap_Transient_Statement for details. -- 2. In an expression of a control structure (test in a IF statement, -- expression in a CASE statement, ...). See Wrap_Transient_Expression -- for details. -- 3. In a expression of an object_declaration. No wrapping is possible -- here, so the finalization actions, if any, are done right after the -- declaration and the secondary stack deallocation is done in the -- proper enclosing scope. See Wrap_Transient_Declaration for details. -- Note about functions returning tagged types: it has been decided to -- always allocate their result in the secondary stack, even though is not -- absolutely mandatory when the tagged type is constrained because the -- caller knows the size of the returned object and thus could allocate the -- result in the primary stack. An exception to this is when the function -- builds its result in place, as is done for functions with inherently -- limited result types for Ada 2005. In that case, certain callers may -- pass the address of a constrained object as the target object for the -- function result. -- By allocating tagged results in the secondary stack a number of -- implementation difficulties are avoided: -- - If it is a dispatching function call, the computation of the size of -- the result is possible but complex from the outside. -- - If the returned type is controlled, the assignment of the returned -- value to the anonymous object involves an Adjust, and we have no -- easy way to access the anonymous object created by the back end. -- - If the returned type is class-wide, this is an unconstrained type -- anyway. -- Furthermore, the small loss in efficiency which is the result of this -- decision is not such a big deal because functions returning tagged types -- are not as common in practice compared to functions returning access to -- a tagged type. -------------------------------------------------- -- Transient Blocks and Finalization Management -- -------------------------------------------------- function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id; -- N is a node which may generate a transient scope. Loop over the parent -- pointers of N until it find the appropriate node to wrap. If it returns -- Empty, it means that no transient scope is needed in this context. procedure Insert_Actions_In_Scope_Around (N : Node_Id); -- Insert the before-actions kept in the scope stack before N, and the -- after-actions after N, which must be a member of a list. function Make_Transient_Block (Loc : Source_Ptr; Action : Node_Id; Par : Node_Id) return Node_Id; -- Action is a single statement or object declaration. Par is the proper -- parent of the generated block. Create a transient block whose name is -- the current scope and the only handled statement is Action. If Action -- involves controlled objects or secondary stack usage, the corresponding -- cleanup actions are performed at the end of the block. procedure Set_Node_To_Be_Wrapped (N : Node_Id); -- Set the field Node_To_Be_Wrapped of the current scope -- ??? The entire comment needs to be rewritten ----------------------------- -- Finalization Management -- ----------------------------- -- This part describe how Initialization/Adjustment/Finalization procedures -- are generated and called. Two cases must be considered, types that are -- Controlled (Is_Controlled flag set) and composite types that contain -- controlled components (Has_Controlled_Component flag set). In the first -- case the procedures to call are the user-defined primitive operations -- Initialize/Adjust/Finalize. In the second case, GNAT generates -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge -- of calling the former procedures on the controlled components. -- For records with Has_Controlled_Component set, a hidden "controller" -- component is inserted. This controller component contains its own -- finalization list on which all controlled components are attached -- creating an indirection on the upper-level Finalization list. This -- technique facilitates the management of objects whose number of -- controlled components changes during execution. This controller -- component is itself controlled and is attached to the upper-level -- finalization chain. Its adjust primitive is in charge of calling adjust -- on the components and adjusting the finalization pointer to match their -- new location (see a-finali.adb). -- It is not possible to use a similar technique for arrays that have -- Has_Controlled_Component set. In this case, deep procedures are -- generated that call initialize/adjust/finalize + attachment or -- detachment on the finalization list for all component. -- Initialize calls: they are generated for declarations or dynamic -- allocations of Controlled objects with no initial value. They are always -- followed by an attachment to the current Finalization Chain. For the -- dynamic allocation case this the chain attached to the scope of the -- access type definition otherwise, this is the chain of the current -- scope. -- Adjust Calls: They are generated on 2 occasions: (1) for declarations -- or dynamic allocations of Controlled objects with an initial value. -- (2) after an assignment. In the first case they are followed by an -- attachment to the final chain, in the second case they are not. -- Finalization Calls: They are generated on (1) scope exit, (2) -- assignments, (3) unchecked deallocations. In case (3) they have to -- be detached from the final chain, in case (2) they must not and in -- case (1) this is not important since we are exiting the scope anyway. -- Other details: -- Type extensions will have a new record controller at each derivation -- level containing controlled components. The record controller for -- the parent/ancestor is attached to the finalization list of the -- extension's record controller (i.e. the parent is like a component -- of the extension). -- For types that are both Is_Controlled and Has_Controlled_Components, -- the record controller and the object itself are handled separately. -- It could seem simpler to attach the object at the end of its record -- controller but this would not tackle view conversions properly. -- A classwide type can always potentially have controlled components -- but the record controller of the corresponding actual type may not -- be known at compile time so the dispatch table contains a special -- field that allows to compute the offset of the record controller -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset. -- Here is a simple example of the expansion of a controlled block : -- declare -- X : Controlled; -- Y : Controlled := Init; -- -- type R is record -- C : Controlled; -- end record; -- W : R; -- Z : R := (C => X); -- begin -- X := Y; -- W := Z; -- end; -- -- is expanded into -- -- declare -- _L : System.FI.Finalizable_Ptr; -- procedure _Clean is -- begin -- Abort_Defer; -- System.FI.Finalize_List (_L); -- Abort_Undefer; -- end _Clean; -- X : Controlled; -- begin -- Abort_Defer; -- Initialize (X); -- Attach_To_Final_List (_L, Finalizable (X), 1); -- at end: Abort_Undefer; -- Y : Controlled := Init; -- Adjust (Y); -- Attach_To_Final_List (_L, Finalizable (Y), 1); -- -- type R is record -- C : Controlled; -- end record; -- W : R; -- begin -- Abort_Defer; -- Deep_Initialize (W, _L, 1); -- at end: Abort_Under; -- Z : R := (C => X); -- Deep_Adjust (Z, _L, 1); -- begin -- _Assign (X, Y); -- Deep_Finalize (W, False); -- -- W := Z; -- -- Deep_Adjust (W, _L, 0); -- at end -- _Clean; -- end; type Final_Primitives is (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case); -- This enumeration type is defined in order to ease sharing code for -- building finalization procedures for composite types. Name_Of : constant array (Final_Primitives) of Name_Id := (Initialize_Case => Name_Initialize, Adjust_Case => Name_Adjust, Finalize_Case => Name_Finalize, Address_Case => Name_Finalize_Address); Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type := (Initialize_Case => TSS_Deep_Initialize, Adjust_Case => TSS_Deep_Adjust, Finalize_Case => TSS_Deep_Finalize, Address_Case => TSS_Finalize_Address); procedure Build_Array_Deep_Procs (Typ : Entity_Id); -- Build the deep Initialize/Adjust/Finalize for a record Typ with -- Has_Controlled_Component set and store them using the TSS mechanism. 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 the -- context does not contain the above constructs, the routine returns an -- empty list. procedure Build_Finalizer (N : Node_Id; Clean_Stmts : List_Id; Mark_Id : Entity_Id; Top_Decls : List_Id; Defer_Abort : Boolean; Fin_Id : out Entity_Id); -- N may denote an accept statement, block, entry body, package body, -- package spec, protected body, subprogram body, and a task body. Create -- a procedure which contains finalization calls for all controlled objects -- declared in the declarative or statement region of N. The calls are -- built in reverse order relative to the original declarations. In the -- case of a tack body, the routine delays the creation of the finalizer -- until all statements have been moved to the task body procedure. -- Clean_Stmts may contain additional context-dependent code used to abort -- asynchronous calls or complete tasks (see Build_Cleanup_Statements). -- Mark_Id is the secondary stack used in the current context or Empty if -- missing. Top_Decls is the list on which the declaration of the finalizer -- is attached in the non-package case. Defer_Abort indicates that the -- statements passed in perform actions that require abort to be deferred, -- such as for task termination. Fin_Id is the finalizer declaration -- entity. procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id); -- N is a construct which contains a handled sequence of statements, Fin_Id -- is the entity of a finalizer. Create an At_End handler which covers the -- statements of N and calls Fin_Id. If the handled statement sequence has -- an exception handler, the statements will be wrapped in a block to avoid -- unwanted interaction with the new At_End handler. procedure Build_Record_Deep_Procs (Typ : Entity_Id); -- Build the deep Initialize/Adjust/Finalize for a record Typ with -- Has_Component_Component set and store them using the TSS mechanism. procedure Check_Visibly_Controlled (Prim : Final_Primitives; Typ : Entity_Id; E : in out Entity_Id; Cref : in out Node_Id); -- The controlled operation declared for a derived type may not be -- overriding, if the controlled operations of the parent type are hidden, -- for example when the parent is a private type whose full view is -- controlled. For other primitive operations we modify the name of the -- operation to indicate that it is not overriding, but this is not -- possible for Initialize, etc. because they have to be retrievable by -- name. Before generating the proper call to one of these operations we -- check whether Typ is known to be controlled at the point of definition. -- If it is not then we must retrieve the hidden operation of the parent -- and use it instead. This is one case that might be solved more cleanly -- once Overriding pragmas or declarations are in place. function Convert_View (Proc : Entity_Id; Arg : Node_Id; Ind : Pos := 1) return Node_Id; -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the -- argument being passed to it. Ind indicates which formal of procedure -- Proc we are trying to match. This function will, if necessary, generate -- a conversion between the partial and full view of Arg to match the type -- of the formal of Proc, or force a conversion to the class-wide type in -- the case where the operation is abstract. function Enclosing_Function (E : Entity_Id) return Entity_Id; -- Given an arbitrary entity, traverse the scope chain looking for the -- first enclosing function. Return Empty if no function was found. function Make_Call (Loc : Source_Ptr; Proc_Id : Entity_Id; Param : Node_Id; For_Parent : Boolean := False) return Node_Id; -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of -- routine [Deep_]Adjust / Finalize and an object parameter, create an -- adjust / finalization call. Flag For_Parent should be set when field -- _parent is being processed. function Make_Deep_Proc (Prim : Final_Primitives; Typ : Entity_Id; Stmts : List_Id) return Node_Id; -- This function generates the tree for Deep_Initialize, Deep_Adjust or -- Deep_Finalize procedures according to the first parameter, these -- procedures operate on the type Typ. The Stmts parameter gives the body -- of the procedure. function Make_Deep_Array_Body (Prim : Final_Primitives; Typ : Entity_Id) return List_Id; -- This function generates the list of statements for implementing -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to -- the first parameter, these procedures operate on the array type Typ. function Make_Deep_Record_Body (Prim : Final_Primitives; Typ : Entity_Id; Is_Local : Boolean := False) return List_Id; -- This function generates the list of statements for implementing -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to -- the first parameter, these procedures operate on the record type Typ. -- Flag Is_Local is used in conjunction with Deep_Finalize to designate -- 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, Make_Deep_Array_Body and -- Make_Deep_Record_Body. Generate the following statements: -- -- declare -- type Acc_Typ is access all Typ; -- for Acc_Typ'Storage_Size use 0; -- begin -- [Deep_]Finalize (Acc_Typ (V).all); -- end; ---------------------------- -- Build_Array_Deep_Procs -- ---------------------------- procedure Build_Array_Deep_Procs (Typ : Entity_Id) is begin Set_TSS (Typ, Make_Deep_Proc (Prim => Initialize_Case, Typ => Typ, Stmts => Make_Deep_Array_Body (Initialize_Case, Typ))); if not Is_Immutably_Limited_Type (Typ) then Set_TSS (Typ, Make_Deep_Proc (Prim => Adjust_Case, Typ => Typ, Stmts => Make_Deep_Array_Body (Adjust_Case, Typ))); end if; -- Do not generate Deep_Finalize and Finalize_Address if finalization is -- suppressed since these routine will not be used. if not Restriction_Active (No_Finalization) then Set_TSS (Typ, Make_Deep_Proc (Prim => Finalize_Case, Typ => Typ, Stmts => Make_Deep_Array_Body (Finalize_Case, Typ))); -- Create TSS primitive Finalize_Address for non-VM targets. JVM and -- .NET do not support address arithmetic and unchecked conversions. if VM_Target = No_VM then Set_TSS (Typ, Make_Deep_Proc (Prim => Address_Case, Typ => Typ, Stmts => Make_Deep_Array_Body (Address_Case, Typ))); end if; end if; end Build_Array_Deep_Procs; ------------------------------ -- Build_Cleanup_Statements -- ------------------------------ function Build_Cleanup_Statements (N : Node_Id) return List_Id is Is_Asynchronous_Call : constant Boolean := Nkind (N) = N_Block_Statement and then Is_Asynchronous_Call_Block (N); Is_Master : constant Boolean := Nkind (N) /= N_Entry_Body and then Is_Task_Master (N); Is_Protected_Body : constant Boolean := Nkind (N) = N_Subprogram_Body and then Is_Protected_Subprogram_Body (N); Is_Task_Allocation : constant Boolean := Nkind (N) = N_Block_Statement and then Is_Task_Allocation_Block (N); Is_Task_Body : constant Boolean := Nkind (Original_Node (N)) = N_Task_Body; Loc : constant Source_Ptr := Sloc (N); Stmts : constant List_Id := New_List; begin if Is_Task_Body then if Restricted_Profile then Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Restricted_Task)); else Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task)); end if; elsif Is_Master then if Restriction_Active (No_Task_Hierarchy) = False then Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master)); end if; -- Add statements to unlock the protected object parameter and to -- undefer abort. If the context is a protected procedure and the object -- has entries, call the entry service routine. -- NOTE: The generated code references _object, a parameter to the -- procedure. elsif Is_Protected_Body then declare Spec : constant Node_Id := Parent (Corresponding_Spec (N)); Conc_Typ : Entity_Id; Nam : Node_Id; Param : Node_Id; Param_Typ : Entity_Id; begin -- Find the _object parameter representing the protected object Param := First (Parameter_Specifications (Spec)); loop Param_Typ := Etype (Parameter_Type (Param)); if Ekind (Param_Typ) = E_Record_Type then Conc_Typ := Corresponding_Concurrent_Type (Param_Typ); end if; exit when No (Param) or else Present (Conc_Typ); Next (Param); end loop; pragma Assert (Present (Param)); -- If the associated protected object has entries, a protected -- procedure has to service entry queues. In this case generate: -- Service_Entries (_object._object'Access); if Nkind (Specification (N)) = N_Procedure_Specification and then Has_Entries (Conc_Typ) then case Corresponding_Runtime_Package (Conc_Typ) is when System_Tasking_Protected_Objects_Entries => Nam := New_Reference_To (RTE (RE_Service_Entries), Loc); when System_Tasking_Protected_Objects_Single_Entry => Nam := New_Reference_To (RTE (RE_Service_Entry), Loc); when others => raise Program_Error; end case; Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => Nam, Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Reference_To ( Defining_Identifier (Param), Loc), Selector_Name => Make_Identifier (Loc, Name_uObject)), Attribute_Name => Name_Unchecked_Access)))); else -- Generate: -- Unlock (_object._object'Access); case Corresponding_Runtime_Package (Conc_Typ) is when System_Tasking_Protected_Objects_Entries => Nam := New_Reference_To (RTE (RE_Unlock_Entries), Loc); when System_Tasking_Protected_Objects_Single_Entry => Nam := New_Reference_To (RTE (RE_Unlock_Entry), Loc); when System_Tasking_Protected_Objects => Nam := New_Reference_To (RTE (RE_Unlock), Loc); when others => raise Program_Error; end case; Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => Nam, Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Reference_To (Defining_Identifier (Param), Loc), Selector_Name => Make_Identifier (Loc, Name_uObject)), Attribute_Name => Name_Unchecked_Access)))); end if; -- Generate: -- Abort_Undefer; if Abort_Allowed then Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc), Parameter_Associations => Empty_List)); end if; end; -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated -- tasks. Other unactivated tasks are completed by Complete_Task or -- Complete_Master. -- NOTE: The generated code references _chain, a local object elsif Is_Task_Allocation then -- Generate: -- Expunge_Unactivated_Tasks (_chain); -- where _chain is the list of tasks created by the allocator but not -- yet activated. This list will be empty unless the block completes -- abnormally. Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Expunge_Unactivated_Tasks), Loc), Parameter_Associations => New_List ( New_Reference_To (Activation_Chain_Entity (N), Loc)))); -- Attempt to cancel an asynchronous entry call whenever the block which -- contains the abortable part is exited. -- NOTE: The generated code references Cnn, a local object elsif Is_Asynchronous_Call then declare Cancel_Param : constant Entity_Id := Entry_Cancel_Parameter (Entity (Identifier (N))); begin -- If it is of type Communication_Block, this must be a protected -- entry call. Generate: -- if Enqueued (Cancel_Param) then -- Cancel_Protected_Entry_Call (Cancel_Param); -- end if; if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then Append_To (Stmts, Make_If_Statement (Loc, Condition => Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Enqueued), Loc), Parameter_Associations => New_List ( New_Reference_To (Cancel_Param, Loc))), Then_Statements => New_List ( Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Cancel_Protected_Entry_Call), Loc), Parameter_Associations => New_List ( New_Reference_To (Cancel_Param, Loc)))))); -- Asynchronous delay, generate: -- Cancel_Async_Delay (Cancel_Param); elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Cancel_Param, Loc), Attribute_Name => Name_Unchecked_Access)))); -- Task entry call, generate: -- Cancel_Task_Entry_Call (Cancel_Param); else Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Cancel_Task_Entry_Call), Loc), Parameter_Associations => New_List ( New_Reference_To (Cancel_Param, Loc)))); end if; end; end if; return Stmts; end Build_Cleanup_Statements; ----------------------------- -- Build_Controlling_Procs -- ----------------------------- procedure Build_Controlling_Procs (Typ : Entity_Id) is begin if Is_Array_Type (Typ) then Build_Array_Deep_Procs (Typ); else pragma Assert (Is_Record_Type (Typ)); Build_Record_Deep_Procs (Typ); end if; end Build_Controlling_Procs; ----------------------------- -- Build_Exception_Handler -- ----------------------------- function Build_Exception_Handler (Data : Finalization_Exception_Data; For_Library : Boolean := False) return Node_Id is Actuals : List_Id; Proc_To_Call : Entity_Id; Except : Node_Id; Stmts : List_Id; begin pragma Assert (Present (Data.Raised_Id)); if Exception_Extra_Info or else (For_Library and not Restricted_Profile) then if Exception_Extra_Info then -- Generate: -- Get_Current_Excep.all Except := Make_Function_Call (Data.Loc, Name => Make_Explicit_Dereference (Data.Loc, Prefix => New_Reference_To (RTE (RE_Get_Current_Excep), Data.Loc))); else -- Generate: -- null Except := Make_Null (Data.Loc); end if; if For_Library and then not Restricted_Profile then Proc_To_Call := RTE (RE_Save_Library_Occurrence); Actuals := New_List (Except); else Proc_To_Call := RTE (RE_Save_Occurrence); -- The dereference occurs only when Exception_Extra_Info is true, -- and therefore Except is not null. Actuals := New_List ( New_Reference_To (Data.E_Id, Data.Loc), Make_Explicit_Dereference (Data.Loc, Except)); end if; -- Generate: -- when others => -- if not Raised_Id then -- Raised_Id := True; -- Save_Occurrence (E_Id, Get_Current_Excep.all.all); -- or -- Save_Library_Occurrence (Get_Current_Excep.all); -- end if; Stmts := New_List ( Make_If_Statement (Data.Loc, Condition => Make_Op_Not (Data.Loc, Right_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc)), Then_Statements => New_List ( Make_Assignment_Statement (Data.Loc, Name => New_Reference_To (Data.Raised_Id, Data.Loc), Expression => New_Reference_To (Standard_True, Data.Loc)), Make_Procedure_Call_Statement (Data.Loc, Name => New_Reference_To (Proc_To_Call, Data.Loc), Parameter_Associations => Actuals)))); else -- Generate: -- Raised_Id := True; Stmts := New_List ( Make_Assignment_Statement (Data.Loc, Name => New_Reference_To (Data.Raised_Id, Data.Loc), Expression => New_Reference_To (Standard_True, Data.Loc))); end if; -- Generate: -- when others => return Make_Exception_Handler (Data.Loc, Exception_Choices => New_List (Make_Others_Choice (Data.Loc)), Statements => Stmts); end Build_Exception_Handler; ------------------------------- -- Build_Finalization_Master -- ------------------------------- 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 -- an instance of Ada.Unchecked_Deallocation. ------------------------------ -- In_Deallocation_Instance -- ------------------------------ function In_Deallocation_Instance (E : Entity_Id) return Boolean is Pkg : constant Entity_Id := Scope (E); Par : Node_Id := Empty; begin if Ekind (Pkg) = E_Package and then Present (Related_Instance (Pkg)) and then Ekind (Related_Instance (Pkg)) = E_Procedure then Par := Generic_Parent (Parent (Related_Instance (Pkg))); return Present (Par) and then Chars (Par) = Name_Unchecked_Deallocation and then Chars (Scope (Par)) = Name_Ada and then Scope (Scope (Par)) = Standard_Standard; end if; return False; end In_Deallocation_Instance; -- 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 -- finalization master. elsif Present (Finalization_Master (Ptr_Typ)) then return; -- Do not process types that return on the secondary stack 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 (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 (Ptr_Typ) then return; -- Ignore the general use of anonymous access types unless the context -- requires a finalization master. 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 masters are controlled objects. elsif Restriction_Active (No_Nested_Finalization) and then not Is_Library_Level_Entity (Ptr_Typ) then return; -- For .NET/JVM targets, allow the processing of access-to-controlled -- types where the designated type is explicitly derived from [Limited_] -- Controlled. elsif VM_Target /= No_VM and then not Is_Controlled (Desig_Typ) then return; -- Do not create finalization masters in Alfa mode because they result -- in unwanted expansion. elsif Alfa_Mode then return; end if; declare 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 : aliased Finalization_Master; -- 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 (Ptr_Typ) and then not Inside_A_Generic then Fin_Mas_Id := Make_Defining_Identifier (Loc, 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 Fin_Mas_Id := Make_Temporary (Loc, 'F'); end if; Append_To (Actions, Make_Object_Declaration (Loc, Defining_Identifier => Fin_Mas_Id, Aliased_Present => True, Object_Definition => New_Reference_To (RTE (RE_Finalization_Master), Loc))); -- Storage pool selection and attribute decoration of the generated -- 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 (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 (Ptr_Typ); Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); end if; -- Generate: -- Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access); Append_To (Actions, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Set_Base_Pool), Loc), Parameter_Associations => New_List ( 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_Finalization_Master (Ptr_Typ, Fin_Mas_Id); -- 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); -- Treat use clauses as declarations and insert directly in front -- of them. if Nkind_In (Ins_Node, N_Use_Package_Clause, N_Use_Type_Clause) then Insert_List_Before_And_Analyze (Ins_Node, Actions); else Insert_Actions (Ins_Node, Actions); end if; Pop_Scope; elsif Ekind (Desig_Typ) = E_Incomplete_Type and then Has_Completion_In_Body (Desig_Typ) then 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 -- whichever type is frozen later, similarly to what Freeze_Type does -- for appending the storage pool declaration for an access type. -- Otherwise, the call to Set_Storage_Pool_Ptr might reference the -- pool object before it's declared. However, it's not clear that -- this is exactly the right test to accomplish that here. ??? elsif Present (Freeze_Node (Desig_Typ)) and then not Analyzed (Freeze_Node (Desig_Typ)) then Append_Freeze_Actions (Desig_Typ, Actions); elsif Present (Freeze_Node (Ptr_Typ)) and then not Analyzed (Freeze_Node (Ptr_Typ)) then Append_Freeze_Actions (Ptr_Typ, Actions); -- If there's a pool created locally for the access type, then we -- 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 (Ptr_Typ) then Insert_List_After_And_Analyze (Parent (Pool_Id), Actions); else Insert_Actions (Parent (Ptr_Typ), Actions); end if; end; end Build_Finalization_Master; --------------------- -- Build_Finalizer -- --------------------- procedure Build_Finalizer (N : Node_Id; Clean_Stmts : List_Id; Mark_Id : Entity_Id; Top_Decls : List_Id; Defer_Abort : Boolean; Fin_Id : out Entity_Id) is Acts_As_Clean : constant Boolean := Present (Mark_Id) or else (Present (Clean_Stmts) and then Is_Non_Empty_List (Clean_Stmts)); Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body; For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration; For_Package : constant Boolean := For_Package_Body or else For_Package_Spec; Loc : constant Source_Ptr := Sloc (N); -- NOTE: Local variable declarations are conservative and do not create -- structures right from the start. Entities and lists are created once -- it has been established that N has at least one controlled object. Components_Built : Boolean := False; -- A flag used to avoid double initialization of entities and lists. If -- the flag is set then the following variables have been initialized: -- Counter_Id -- Finalizer_Decls -- Finalizer_Stmts -- Jump_Alts Counter_Id : Entity_Id := Empty; Counter_Val : Int := 0; -- Name and value of the state counter Decls : List_Id := No_List; -- Declarative region of N (if available). If N is a package declaration -- Decls denotes the visible declarations. Finalizer_Data : Finalization_Exception_Data; -- Data for the exception Finalizer_Decls : List_Id := No_List; -- Local variable declarations. This list holds the label declarations -- of all jump block alternatives as well as the declaration of the -- local exception occurence and the raised flag: -- E : Exception_Occurrence; -- Raised : Boolean := False; -- L : label; Finalizer_Insert_Nod : Node_Id := Empty; -- Insertion point for the finalizer body. Depending on the context -- (Nkind of N) and the individual grouping of controlled objects, this -- node may denote a package declaration or body, package instantiation, -- block statement or a counter update statement. Finalizer_Stmts : List_Id := No_List; -- The statement list of the finalizer body. It contains the following: -- -- Abort_Defer; -- Added if abort is allowed -- -- Added if exists -- -- Added if Acts_As_Clean -- -- Added if Has_Ctrl_Objs -- -- Added if Has_Ctrl_Objs -- -- Added if Mark_Id exists -- Abort_Undefer; -- Added if abort is allowed Has_Ctrl_Objs : Boolean := False; -- 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 statements. This -- list contains the following: -- -- when => -- goto L; Jump_Block_Insert_Nod : Node_Id := Empty; -- Specific point in the finalizer statements where the jump block is -- inserted. Last_Top_Level_Ctrl_Construct : Node_Id := Empty; -- The last controlled construct encountered when processing the top -- level lists of N. This can be a nested package, an instantiation or -- an object declaration. Prev_At_End : Entity_Id := Empty; -- The previous at end procedure of the handled statements block of N Priv_Decls : List_Id := No_List; -- The private declarations of N if N is a package declaration Spec_Id : Entity_Id := Empty; 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 -- ----------------------- procedure Build_Components; -- Create all entites and initialize all lists used in the creation of -- the finalizer. procedure Create_Finalizer; -- Create the spec and body of the finalizer and insert them in the -- proper place in the tree depending on the context. procedure Process_Declarations (Decls : List_Id; Preprocess : Boolean := False; Top_Level : Boolean := False); -- Inspect a list of declarations or statements which may contain -- 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 declarations or instances. procedure Process_Object_Declaration (Decl : Node_Id; Has_No_Init : Boolean := False; Is_Protected : Boolean := False); -- Generate all the machinery associated with the finalization of a -- single object. Flag Has_No_Init is used to denote certain contexts -- 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 -- ---------------------- procedure Build_Components is Counter_Decl : Node_Id; Counter_Typ : Entity_Id; Counter_Typ_Decl : Node_Id; begin pragma Assert (Present (Decls)); -- This routine might be invoked several times when dealing with -- constructs that have two lists (either two declarative regions -- or declarations and statements). Avoid double initialization. if Components_Built then return; end if; Components_Built := True; if Has_Ctrl_Objs then -- Create entities for the counter, its type, the local exception -- and the raised flag. Counter_Id := Make_Temporary (Loc, 'C'); Counter_Typ := Make_Temporary (Loc, 'T'); Finalizer_Decls := New_List; Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc, For_Package); -- Since the total number of controlled objects is always known, -- build a subtype of Natural with precise bounds. This allows -- the backend to optimize the case statement. Generate: -- -- subtype Tnn is Natural range 0 .. Counter_Val; Counter_Typ_Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Counter_Typ, Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To (Standard_Natural, Loc), Constraint => Make_Range_Constraint (Loc, Range_Expression => Make_Range (Loc, Low_Bound => Make_Integer_Literal (Loc, Uint_0), High_Bound => Make_Integer_Literal (Loc, Counter_Val))))); -- Generate the declaration of the counter itself: -- -- Counter : Integer := 0; Counter_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Counter_Id, Object_Definition => New_Reference_To (Counter_Typ, Loc), Expression => Make_Integer_Literal (Loc, 0)); -- Set the type of the counter explicitly to prevent errors when -- examining object declarations later on. Set_Etype (Counter_Id, Counter_Typ); -- The counter and its type are inserted before the source -- declarations of N. Prepend_To (Decls, Counter_Decl); Prepend_To (Decls, Counter_Typ_Decl); -- The counter and its associated type must be manually analized -- since N has already been analyzed. Use the scope of the spec -- when inserting in a package. if For_Package then Push_Scope (Spec_Id); Analyze (Counter_Typ_Decl); Analyze (Counter_Decl); Pop_Scope; else Analyze (Counter_Typ_Decl); Analyze (Counter_Decl); end if; Jump_Alts := New_List; end if; -- If the context requires additional clean up, the finalization -- machinery is added after the clean up code. if Acts_As_Clean then Finalizer_Stmts := Clean_Stmts; Jump_Block_Insert_Nod := Last (Finalizer_Stmts); else Finalizer_Stmts := New_List; end if; if Has_Tagged_Types then Tagged_Type_Stmts := New_List; end if; end Build_Components; ---------------------- -- Create_Finalizer -- ---------------------- procedure Create_Finalizer is Body_Id : Entity_Id; Fin_Body : Node_Id; Fin_Spec : Node_Id; Jump_Block : Node_Id; Label : Node_Id; Label_Id : Entity_Id; function New_Finalizer_Name return Name_Id; -- Create a fully qualified name of a package spec or body finalizer. -- The generated name is of the form: xx__yy__finalize_[spec|body]. ------------------------ -- New_Finalizer_Name -- ------------------------ function New_Finalizer_Name return Name_Id is procedure New_Finalizer_Name (Id : Entity_Id); -- Place "__" in the name buffer. If the identifier -- has a non-standard scope, process the scope first. ------------------------ -- New_Finalizer_Name -- ------------------------ procedure New_Finalizer_Name (Id : Entity_Id) is begin if Scope (Id) = Standard_Standard then Get_Name_String (Chars (Id)); else New_Finalizer_Name (Scope (Id)); Add_Str_To_Name_Buffer ("__"); Add_Str_To_Name_Buffer (Get_Name_String (Chars (Id))); end if; end New_Finalizer_Name; -- Start of processing for New_Finalizer_Name begin -- Create the fully qualified name of the enclosing scope New_Finalizer_Name (Spec_Id); -- Generate: -- __finalize_[spec|body] Add_Str_To_Name_Buffer ("__finalize_"); if For_Package_Spec then Add_Str_To_Name_Buffer ("spec"); else Add_Str_To_Name_Buffer ("body"); end if; return Name_Find; end New_Finalizer_Name; -- Start of processing for Create_Finalizer begin -- Step 1: Creation of the finalizer name -- Packages must use a distinct name for their finalizers since the -- binder will have to generate calls to them by name. The name is -- of the following form: -- xx__yy__finalize_[spec|body] if For_Package then Fin_Id := Make_Defining_Identifier (Loc, New_Finalizer_Name); Set_Has_Qualified_Name (Fin_Id); Set_Has_Fully_Qualified_Name (Fin_Id); -- The default name is _finalizer else Fin_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Name_uFinalizer)); -- The visibility semantics of AT_END handlers force a strange -- separation of spec and body for stack-related finalizers: -- declare : Enclosing_Scope -- procedure _finalizer; -- begin -- -- procedure _finalizer is -- ... -- at end -- _finalizer; -- end; -- Both spec and body are within the same construct and scope, but -- the body is part of the handled sequence of statements. This -- placement confuses the elaboration mechanism on targets where -- AT_END handlers are expanded into "when all others" handlers: -- exception -- when all others => -- _finalizer; -- appears to require elab checks -- at end -- _finalizer; -- end; -- Since the compiler guarantees that the body of a _finalizer is -- always inserted in the same construct where the AT_END handler -- resides, there is no need for elaboration checks. Set_Kill_Elaboration_Checks (Fin_Id); end if; -- Step 2: Creation of the finalizer specification -- Generate: -- procedure Fin_Id; Fin_Spec := Make_Subprogram_Declaration (Loc, Specification => Make_Procedure_Specification (Loc, Defining_Unit_Name => Fin_Id)); -- Step 3: Creation of the finalizer body if Has_Ctrl_Objs then -- Add L0, the default destination to the jump block Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0)); Set_Entity (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id))); Label := Make_Label (Loc, Label_Id); -- Generate: -- L0 : label; Prepend_To (Finalizer_Decls, Make_Implicit_Label_Declaration (Loc, Defining_Identifier => Entity (Label_Id), Label_Construct => Label)); -- Generate: -- when others => -- goto L0; Append_To (Jump_Alts, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List (Make_Others_Choice (Loc)), Statements => New_List ( Make_Goto_Statement (Loc, Name => New_Reference_To (Entity (Label_Id), Loc))))); -- Generate: -- <> Append_To (Finalizer_Stmts, Label); -- Create the jump block which controls the finalization flow -- depending on the value of the state counter. Jump_Block := Make_Case_Statement (Loc, Expression => Make_Identifier (Loc, Chars (Counter_Id)), Alternatives => Jump_Alts); if Acts_As_Clean and then Present (Jump_Block_Insert_Nod) then Insert_After (Jump_Block_Insert_Nod, Jump_Block); else Prepend_To (Finalizer_Stmts, Jump_Block); 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. if Present (Prev_At_End) then Prepend_To (Finalizer_Stmts, Make_Procedure_Call_Statement (Loc, Prev_At_End)); -- Clear the At_End handler since we have already generated the -- proper replacement call for it. Set_At_End_Proc (HSS, Empty); end if; -- Release the secondary stack mark if Present (Mark_Id) then Append_To (Finalizer_Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_SS_Release), Loc), Parameter_Associations => New_List ( New_Reference_To (Mark_Id, Loc)))); end if; -- Protect the statements with abort defer/undefer. This is only when -- aborts are allowed and the clean up statements require deferral or -- there are controlled objects to be finalized. if Abort_Allowed and then (Defer_Abort or else Has_Ctrl_Objs) then Prepend_To (Finalizer_Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Abort_Defer), Loc))); Append_To (Finalizer_Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))); end if; -- The local exception does not need to be reraised for library-level -- finalizers. Note that this action must be carried out after object -- clean up, secondary stack release and abort undeferral. Generate: -- if Raised and then not Abort then -- Raise_From_Controlled_Operation (E); -- end if; if Has_Ctrl_Objs and then Exceptions_OK and then not For_Package then Append_To (Finalizer_Stmts, Build_Raise_Statement (Finalizer_Data)); end if; -- Generate: -- procedure Fin_Id is -- Abort : constant Boolean := Triggered_By_Abort; -- -- Abort : constant Boolean := False; -- no abort -- E : Exception_Occurrence; -- All added if flag -- Raised : Boolean := False; -- Has_Ctrl_Objs is set -- L0 : label; -- ... -- Lnn : label; -- begin -- Abort_Defer; -- Added if abort is allowed -- -- Added if exists -- -- Added if Acts_As_Clean -- -- Added if Has_Ctrl_Objs -- -- Added if Has_Ctrl_Objs -- -- Added if Mark_Id exists -- Abort_Undefer; -- Added if abort is allowed -- -- Added if Has_Ctrl_Objs -- end Fin_Id; -- Create the body of the finalizer Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id)); if For_Package then Set_Has_Qualified_Name (Body_Id); Set_Has_Fully_Qualified_Name (Body_Id); end if; Fin_Body := Make_Subprogram_Body (Loc, Specification => Make_Procedure_Specification (Loc, Defining_Unit_Name => Body_Id), Declarations => Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Finalizer_Stmts)); -- Step 4: Spec and body insertion, analysis if For_Package then -- If the package spec has private declarations, the finalizer -- body must be added to the end of the list in order to have -- visibility of all private controlled objects. if For_Package_Spec then if Present (Priv_Decls) then Append_To (Priv_Decls, Fin_Spec); Append_To (Priv_Decls, Fin_Body); else Append_To (Decls, Fin_Spec); Append_To (Decls, Fin_Body); end if; -- For package bodies, both the finalizer spec and body are -- inserted at the end of the package declarations. else Append_To (Decls, Fin_Spec); Append_To (Decls, Fin_Body); end if; -- Push the name of the package Push_Scope (Spec_Id); Analyze (Fin_Spec); Analyze (Fin_Body); Pop_Scope; -- Non-package case else -- Create the spec for the finalizer. The At_End handler must be -- able to call the body which resides in a nested structure. -- Generate: -- declare -- procedure Fin_Id; -- Spec -- begin -- -- procedure Fin_Id is ... -- Body -- -- at end -- Fin_Id; -- At_End handler -- end; pragma Assert (Present (Spec_Decls)); Append_To (Spec_Decls, Fin_Spec); Analyze (Fin_Spec); -- When the finalizer acts solely as a clean up routine, the body -- is inserted right after the spec. if Acts_As_Clean and then not Has_Ctrl_Objs then Insert_After (Fin_Spec, Fin_Body); -- In all other cases the body is inserted after either: -- -- 1) The counter update statement of the last controlled object -- 2) The last top level nested controlled package -- 3) The last top level controlled instantiation else -- Manually freeze the spec. This is somewhat of a hack because -- a subprogram is frozen when its body is seen and the freeze -- node appears right before the body. However, in this case, -- the spec must be frozen earlier since the At_End handler -- must be able to call it. -- -- declare -- procedure Fin_Id; -- Spec -- [Fin_Id] -- Freeze node -- begin -- ... -- at end -- Fin_Id; -- At_End handler -- end; Ensure_Freeze_Node (Fin_Id); Insert_After (Fin_Spec, Freeze_Node (Fin_Id)); Set_Is_Frozen (Fin_Id); -- In the case where the last construct to contain a controlled -- object is either a nested package, an instantiation or a -- freeze node, the body must be inserted directly after the -- construct. if Nkind_In (Last_Top_Level_Ctrl_Construct, N_Freeze_Entity, N_Package_Declaration, N_Package_Body) then Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct; end if; Insert_After (Finalizer_Insert_Nod, Fin_Body); end if; Analyze (Fin_Body); end if; end Create_Finalizer; -------------------------- -- Process_Declarations -- -------------------------- procedure Process_Declarations (Decls : List_Id; Preprocess : Boolean := False; Top_Level : Boolean := False) is Decl : Node_Id; Expr : Node_Id; Obj_Id : Entity_Id; Obj_Typ : Entity_Id; Pack_Id : Entity_Id; Spec : Node_Id; Typ : Entity_Id; Old_Counter_Val : Int; -- This variable is used to determine whether a nested package or -- instance contains at least one controlled object. procedure Processing_Actions (Has_No_Init : Boolean := False; Is_Protected : Boolean := False); -- Depending on the mode of operation of Process_Declarations, either -- increment the controlled object counter, set the controlled object -- flag and store the last top level construct or process the current -- declaration. Flag Has_No_Init is used to propagate scenarios where -- the current declaration may not have initialization proc(s). Flag -- Is_Protected should be set when the current declaration denotes a -- simple protected object. ------------------------ -- Processing_Actions -- ------------------------ procedure Processing_Actions (Has_No_Init : Boolean := False; Is_Protected : Boolean := False) is begin -- Library-level tagged type 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 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; -- Start of processing for Process_Declarations begin if No (Decls) or else Is_Empty_List (Decls) then return; end if; -- Process all declarations in reverse order 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 elsif Nkind (Decl) = N_Object_Declaration then Obj_Id := Defining_Identifier (Decl); Obj_Typ := Base_Type (Etype (Obj_Id)); Expr := Expression (Decl); -- Bypass any form of processing for objects which have their -- finalization disabled. This applies only to objects at the -- library level. if For_Package and then Finalize_Storage_Only (Obj_Typ) then null; -- Transient variables are treated separately in order to -- minimize the size of the generated code. For details, see -- Process_Transient_Objects. elsif Is_Processed_Transient (Obj_Id) then null; -- The object is of the form: -- Obj : Typ [:= Expr]; -- 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_Class_Wide_Conversion (Obj_Id) then Processing_Actions; -- The object is of the form: -- Obj : Access_Typ := Non_BIP_Function_Call'reference; -- Obj : Access_Typ := -- BIP_Function_Call (BIPalloc => 2, ...)'reference; elsif Is_Access_Type (Obj_Typ) and then Needs_Finalization (Available_View (Designated_Type (Obj_Typ))) and then Present (Expr) and then (Is_Secondary_Stack_BIP_Func_Call (Expr) or else (Is_Non_BIP_Func_Call (Expr) and then not Is_Related_To_Func_Return (Obj_Id))) 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 (Status_Flag_Or_Transient_Decl (Obj_Id)) and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = N_Object_Declaration and then Is_Finalizable_Transient (Status_Flag_Or_Transient_Decl (Obj_Id), Decl) then Processing_Actions (Has_No_Init => True); -- Process intermediate results of an if expression with one -- of the alternatives using a controlled function call. elsif Is_Access_Type (Obj_Typ) and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = N_Defining_Identifier and then Present (Expr) and then Nkind (Expr) = N_Null then Processing_Actions (Has_No_Init => True); -- Simple protected objects which use type System.Tasking. -- Protected_Objects.Protection to manage their locks should -- be treated as controlled since they require manual cleanup. -- The only exception is illustrated in the following example: -- package Pkg is -- type Ctrl is new Controlled ... -- procedure Finalize (Obj : in out Ctrl); -- Lib_Obj : Ctrl; -- end Pkg; -- package body Pkg is -- protected Prot is -- procedure Do_Something (Obj : in out Ctrl); -- end Prot; -- protected body Prot is -- procedure Do_Something (Obj : in out Ctrl) is ... -- end Prot; -- procedure Finalize (Obj : in out Ctrl) is -- begin -- Prot.Do_Something (Obj); -- end Finalize; -- end Pkg; -- Since for the most part entities in package bodies depend on -- those in package specs, Prot's lock should be cleaned up -- first. The subsequent cleanup of the spec finalizes Lib_Obj. -- This act however attempts to invoke Do_Something and fails -- because the lock has disappeared. elsif Ekind (Obj_Id) = E_Variable and then not In_Library_Level_Package_Body (Obj_Id) and then (Is_Simple_Protected_Type (Obj_Typ) or else Has_Simple_Protected_Object (Obj_Typ)) then Processing_Actions (Is_Protected => True); end if; -- Specific cases of object renamings elsif Nkind (Decl) = N_Object_Renaming_Declaration then Obj_Id := Defining_Identifier (Decl); Obj_Typ := Base_Type (Etype (Obj_Id)); -- Bypass any form of processing for objects which have their -- finalization disabled. This applies only to objects at the -- library level. if For_Package and then Finalize_Storage_Only (Obj_Typ) then null; -- Return object of a build-in-place function. This case is -- recognized and marked by the expansion of an extended return -- statement (see Expand_N_Extended_Return_Statement). elsif Needs_Finalization (Obj_Typ) and then Is_Return_Object (Obj_Id) and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) then Processing_Actions (Has_No_Init => True); -- Detect a case where a source object has been initialized by -- a controlled function call or another object which was later -- rewritten as a class-wide conversion of Ada.Tags.Displace. -- Obj1 : CW_Type := Src_Obj; -- Obj2 : CW_Type := Function_Call (...); -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj)); -- Tmp : ... := Function_Call (...)'reference; -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp)); elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then Processing_Actions (Has_No_Init => True); end if; -- Inspect the freeze node of an access-to-controlled type and -- 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 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 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_Master). elsif Nkind (Decl) = N_Freeze_Entity and then Present (Actions (Decl)) then Typ := Entity (Decl); if (Is_Access_Type (Typ) and then not Is_Access_Subprogram_Type (Typ) and then Needs_Finalization (Available_View (Designated_Type (Typ)))) or else (Is_Type (Typ) and then Needs_Finalization (Typ)) then Old_Counter_Val := Counter_Val; -- Freeze nodes are considered to be identical to packages -- and blocks in terms of nesting. The difference is that -- 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 master if Preprocess and then Top_Level and then No (Last_Top_Level_Ctrl_Construct) and then Counter_Val > Old_Counter_Val then Last_Top_Level_Ctrl_Construct := Decl; end if; end if; -- Nested package declarations, avoid generics elsif Nkind (Decl) = N_Package_Declaration then Spec := Specification (Decl); Pack_Id := Defining_Unit_Name (Spec); if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then Pack_Id := Defining_Identifier (Pack_Id); end if; if Ekind (Pack_Id) /= E_Generic_Package then Old_Counter_Val := Counter_Val; Process_Declarations (Private_Declarations (Spec), Preprocess); Process_Declarations (Visible_Declarations (Spec), Preprocess); -- Either the visible or the private declarations contain a -- controlled object. The nested package declaration is the -- last such construct. if Preprocess and then Top_Level and then No (Last_Top_Level_Ctrl_Construct) and then Counter_Val > Old_Counter_Val then Last_Top_Level_Ctrl_Construct := Decl; end if; end if; -- Nested package bodies, avoid generics elsif Nkind (Decl) = N_Package_Body then Spec := Corresponding_Spec (Decl); if Ekind (Spec) /= E_Generic_Package then Old_Counter_Val := Counter_Val; Process_Declarations (Declarations (Decl), Preprocess); -- The nested package body is the last construct to contain -- a controlled object. if Preprocess and then Top_Level and then No (Last_Top_Level_Ctrl_Construct) and then Counter_Val > Old_Counter_Val then Last_Top_Level_Ctrl_Construct := Decl; end if; end if; -- Handle a rare case caused by a controlled transient variable -- created as part of a record init proc. The variable is wrapped -- in a block, but the block is not associated with a transient -- scope. elsif Nkind (Decl) = N_Block_Statement and then Inside_Init_Proc then Old_Counter_Val := Counter_Val; if Present (Handled_Statement_Sequence (Decl)) then Process_Declarations (Statements (Handled_Statement_Sequence (Decl)), Preprocess); end if; Process_Declarations (Declarations (Decl), Preprocess); -- Either the declaration or statement list of the block has a -- controlled object. if Preprocess and then Top_Level and then No (Last_Top_Level_Ctrl_Construct) and then Counter_Val > Old_Counter_Val then Last_Top_Level_Ctrl_Construct := Decl; end if; -- Handle the case where the original context has been wrapped in -- a block to avoid interference between exception handlers and -- At_End handlers. Treat the block as transparent and process its -- contents. elsif Nkind (Decl) = N_Block_Statement and then Is_Finalization_Wrapper (Decl) then if Present (Handled_Statement_Sequence (Decl)) then Process_Declarations (Statements (Handled_Statement_Sequence (Decl)), Preprocess); end if; Process_Declarations (Declarations (Decl), Preprocess); end if; Prev_Non_Pragma (Decl); end loop; end Process_Declarations; -------------------------------- -- Process_Object_Declaration -- -------------------------------- procedure Process_Object_Declaration (Decl : Node_Id; Has_No_Init : Boolean := False; Is_Protected : Boolean := False) is Obj_Id : constant Entity_Id := Defining_Identifier (Decl); Loc : constant Source_Ptr := Sloc (Decl); Body_Ins : Node_Id; Count_Ins : Node_Id; Fin_Call : Node_Id; Fin_Stmts : List_Id; Inc_Decl : Node_Id; Label : Node_Id; Label_Id : Entity_Id; Obj_Ref : Node_Id; Obj_Typ : Entity_Id; function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id; -- Once it has been established that the current object is in fact a -- return object of build-in-place function Func_Id, generate the -- following cleanup code: -- -- 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 (BIPfinalizationmaster); -- begin -- Free (Ptr_Typ (Temp)); -- end; -- end if; -- -- Obj_Typ is the type of the current object, Temp is the original -- allocation which Obj_Id renames. procedure Find_Last_Init (Decl : Node_Id; Typ : Entity_Id; Last_Init : out Node_Id; Body_Insert : out Node_Id); -- An object declaration has at least one and at most two init calls: -- that of the type and the user-defined initialize. Given an object -- declaration, Last_Init denotes the last initialization call which -- follows the declaration. Body_Insert denotes the place where the -- finalizer body could be potentially inserted. ----------------------------- -- Build_BIP_Cleanup_Stmts -- ----------------------------- function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id is 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; Free_Stmt : Node_Id; Pool_Id : Entity_Id; Ptr_Typ : Entity_Id; begin -- Generate: -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all; Pool_Id := Make_Temporary (Loc, 'P'); Append_To (Decls, Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Pool_Id, Subtype_Mark => New_Reference_To (RTE (RE_Root_Storage_Pool), Loc), Name => Make_Explicit_Dereference (Loc, Prefix => Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Base_Pool), Loc), Parameter_Associations => New_List ( Make_Explicit_Dereference (Loc, Prefix => New_Reference_To (Fin_Mas_Id, Loc))))))); -- Create an access type which uses the storage pool of the -- caller's finalization master. -- Generate: -- type Ptr_Typ is access Obj_Typ; Ptr_Typ := Make_Temporary (Loc, 'P'); Append_To (Decls, Make_Full_Type_Declaration (Loc, Defining_Identifier => Ptr_Typ, Type_Definition => Make_Access_To_Object_Definition (Loc, Subtype_Indication => New_Reference_To (Obj_Typ, Loc)))); -- Perform minor decoration in order to set the master and the -- storage pool attributes. Set_Ekind (Ptr_Typ, E_Access_Type); 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 -- caller's pool expressed as a renaming. Free_Stmt := Make_Free_Statement (Loc, Expression => Unchecked_Convert_To (Ptr_Typ, New_Reference_To (Temp_Id, Loc))); Set_Storage_Pool (Free_Stmt, Pool_Id); -- Create a block to house the dummy type and the instantiation as -- well as to perform the cleanup the temporary. -- Generate: -- declare -- -- begin -- Free (Ptr_Typ (Temp_Id)); -- end; Free_Blk := Make_Block_Statement (Loc, Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Free_Stmt))); -- Generate: -- if BIPfinalizationmaster /= null then Cond := Make_Op_Ne (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 BIPfinalizationmaster /= null -- then if not Is_Constrained (Obj_Typ) or else Is_Tagged_Type (Obj_Typ) then declare Alloc : constant Entity_Id := Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); begin Cond := Make_And_Then (Loc, Left_Opnd => Make_Op_Gt (Loc, Left_Opnd => New_Reference_To (Alloc, Loc), Right_Opnd => Make_Integer_Literal (Loc, UI_From_Int (BIP_Allocation_Form'Pos (Secondary_Stack)))), Right_Opnd => Cond); end; end if; -- Generate: -- if then -- -- end if; return Make_If_Statement (Loc, Condition => Cond, Then_Statements => New_List (Free_Blk)); end Build_BIP_Cleanup_Stmts; -------------------- -- Find_Last_Init -- -------------------- procedure Find_Last_Init (Decl : Node_Id; Typ : Entity_Id; Last_Init : out Node_Id; Body_Insert : out Node_Id) is Nod_1 : Node_Id := Empty; Nod_2 : Node_Id := Empty; Utyp : Entity_Id; function Is_Init_Call (N : Node_Id; Typ : Entity_Id) return Boolean; -- Given an arbitrary node, determine whether N is a procedure -- 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 -- ------------------ function Is_Init_Call (N : Node_Id; Typ : Entity_Id) return Boolean is begin -- A call to [Deep_]Initialize is always direct if Nkind (N) = N_Procedure_Call_Statement and then Nkind (Name (N)) = N_Identifier then declare Call_Ent : constant Entity_Id := Entity (Name (N)); Deep_Init : constant Entity_Id := TSS (Typ, TSS_Deep_Initialize); Init : Entity_Id := Empty; begin -- A type may have controlled components but not be -- controlled. 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 Call_Ent = Deep_Init) or else (Present (Init) 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 Last_Init := Decl; Body_Insert := Empty; -- Object renamings and objects associated with controlled -- function results do not have initialization calls. if Has_No_Init then return; end if; if Is_Concurrent_Type (Typ) then Utyp := Corresponding_Record_Type (Typ); else 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; -- Controlled_TypeIP (Object); -- [[Deep_]Initialize (Object);] -- where the user-defined initialize may be optional or may appear -- inside a block when abort deferral is needed. Nod_1 := Next_Suitable_Statement (Decl); if Present (Nod_1) then Nod_2 := Next_Suitable_Statement (Nod_1); -- The statement following an object declaration is always a -- call to the type init proc. Last_Init := Nod_1; end if; -- Optional user-defined init or deep init processing if Present (Nod_2) then -- The statement following the type init proc may be a block -- statement in cases where abort deferral is required. if Nkind (Nod_2) = N_Block_Statement then declare HSS : constant Node_Id := Handled_Statement_Sequence (Nod_2); Stmt : Node_Id; begin if Present (HSS) and then Present (Statements (HSS)) then Stmt := First (Statements (HSS)); -- Examine individual block statements and locate the -- call to [Deep_]Initialze. while Present (Stmt) loop if Is_Init_Call (Stmt, Utyp) then Last_Init := Stmt; Body_Insert := Nod_2; exit; end if; Next (Stmt); end loop; end if; end; elsif Is_Init_Call (Nod_2, Utyp) then Last_Init := Nod_2; end if; end if; end Find_Last_Init; -- Start of processing for Process_Object_Declaration begin Obj_Ref := New_Reference_To (Obj_Id, Loc); Obj_Typ := Base_Type (Etype (Obj_Id)); -- Handle access types if Is_Access_Type (Obj_Typ) then Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); Obj_Typ := Directly_Designated_Type (Obj_Typ); end if; Set_Etype (Obj_Ref, Obj_Typ); -- Set a new value for the state counter and insert the statement -- after the object declaration. Generate: -- -- Counter := ; Inc_Decl := Make_Assignment_Statement (Loc, Name => New_Reference_To (Counter_Id, Loc), Expression => Make_Integer_Literal (Loc, Counter_Val)); -- Insert the counter after all initialization has been done. The -- place of insertion depends on the context. When dealing with a -- controlled function, the counter is inserted directly after the -- declaration because such objects lack init calls. Find_Last_Init (Decl, Obj_Typ, Count_Ins, Body_Ins); Insert_After (Count_Ins, Inc_Decl); Analyze (Inc_Decl); -- If the current declaration is the last in the list, the finalizer -- body needs to be inserted after the set counter statement for the -- current object declaration. This is complicated by the fact that -- the set counter statement may appear in abort deferred block. In -- that case, the proper insertion place is after the block. if No (Finalizer_Insert_Nod) then -- Insertion after an abort deffered block if Present (Body_Ins) then Finalizer_Insert_Nod := Body_Ins; else Finalizer_Insert_Nod := Inc_Decl; end if; end if; -- Create the associated label with this object, generate: -- -- L : label; Label_Id := Make_Identifier (Loc, New_External_Name ('L', Counter_Val)); Set_Entity (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id))); Label := Make_Label (Loc, Label_Id); Prepend_To (Finalizer_Decls, Make_Implicit_Label_Declaration (Loc, Defining_Identifier => Entity (Label_Id), Label_Construct => Label)); -- Create the associated jump with this object, generate: -- -- when => -- goto L; Prepend_To (Jump_Alts, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List ( Make_Integer_Literal (Loc, Counter_Val)), Statements => New_List ( Make_Goto_Statement (Loc, Name => New_Reference_To (Entity (Label_Id), Loc))))); -- Insert the jump destination, generate: -- -- <>> Append_To (Finalizer_Stmts, Label); -- Processing for simple protected objects. Such objects require -- manual finalization of their lock managers. if Is_Protected then Fin_Stmts := No_List; if Is_Simple_Protected_Type (Obj_Typ) then 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 Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ); elsif Is_Array_Type (Obj_Typ) then Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ); end if; end if; -- Generate: -- begin -- System.Tasking.Protected_Objects.Finalize_Protection -- (Obj._object); -- exception -- when others => -- null; -- end; if Present (Fin_Stmts) then Append_To (Finalizer_Stmts, Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Fin_Stmts, Exception_Handlers => New_List ( Make_Exception_Handler (Loc, Exception_Choices => New_List ( Make_Others_Choice (Loc)), Statements => New_List ( Make_Null_Statement (Loc))))))); end if; -- Processing for regular controlled objects else -- Generate: -- [Deep_]Finalize (Obj); -- No_Exception_Propagation -- begin -- Exception handlers allowed -- [Deep_]Finalize (Obj); -- exception -- when Id : others => -- if not Raised then -- Raised := True; -- Save_Occurrence (E, Id); -- end if; -- end; Fin_Call := Make_Final_Call ( Obj_Ref => Obj_Ref, Typ => Obj_Typ); -- For CodePeer, the exception handlers normally generated here -- generate complex flowgraphs which result in capacity problems. -- Omitting these handlers for CodePeer is justified as follows: -- If a handler is dead, then omitting it is surely ok -- If a handler is live, then CodePeer should flag the -- potentially-exception-raising construct that causes it -- to be live. That is what we are interested in, not what -- happens after the exception is raised. if Exceptions_OK and not CodePeer_Mode then Fin_Stmts := New_List ( Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Fin_Call), Exception_Handlers => New_List ( Build_Exception_Handler (Finalizer_Data, For_Package))))); -- When exception handlers are prohibited, the finalization call -- appears unprotected. Any exception raised during finalization -- will bypass the circuitry which ensures the cleanup of all -- remaining objects. else Fin_Stmts := New_List (Fin_Call); end if; -- If we are dealing with a return object of a build-in-place -- function, generate the following cleanup statements: -- 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 (BIPfinalizationmaster.all).all; -- begin -- Free (Ptr_Typ (Temp)); -- end; -- end if; -- -- The generated code effectively detaches the temporary from the -- caller finalization master and deallocates the object. This is -- disabled on .NET/JVM because pools are not supported. 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_Finalization_Master (Func_Id) then Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id)); end if; end; end if; if Ekind_In (Obj_Id, E_Constant, E_Variable) and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) then -- Temporaries created for the purpose of "exporting" a -- controlled transient out of an Expression_With_Actions (EWA) -- need guards. The following illustrates the usage of such -- temporaries. -- Access_Typ : access [all] Obj_Typ; -- Temp : Access_Typ := null; -- := ...; -- do -- Ctrl_Trans : [access [all]] Obj_Typ := ...; -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer -- -- Temp := Ctrl_Trans'Unchecked_Access; -- in ... end; -- The finalization machinery does not process EWA nodes as -- this may lead to premature finalization of expressions. Note -- that Temp is marked as being properly initialized regardless -- of whether the initialization of Ctrl_Trans succeeded. Since -- a failed initialization may leave Temp with a value of null, -- add a guard to handle this case: -- if Obj /= null then -- -- end if; if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = N_Object_Declaration then Fin_Stmts := New_List ( Make_If_Statement (Loc, Condition => Make_Op_Ne (Loc, Left_Opnd => New_Reference_To (Obj_Id, Loc), Right_Opnd => Make_Null (Loc)), Then_Statements => Fin_Stmts)); -- Return objects use a flag to aid in processing their -- potential finalization when the enclosing function fails -- to return properly. Generate: -- if not Flag then -- -- end if; else Fin_Stmts := New_List ( Make_If_Statement (Loc, Condition => Make_Op_Not (Loc, Right_Opnd => New_Reference_To (Status_Flag_Or_Transient_Decl (Obj_Id), Loc)), Then_Statements => Fin_Stmts)); end if; end if; end if; Append_List_To (Finalizer_Stmts, Fin_Stmts); -- Since the declarations are examined in reverse, the state counter -- must be decremented in order to keep with the true position of -- objects. 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 (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; -- Do not perform this expansion in Alfa mode because it is not -- necessary. if Alfa_Mode then return; end if; -- 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)); Priv_Decls := Private_Declarations (Specification (N)); -- Retrieve the package spec id Spec_Id := Defining_Unit_Name (Specification (N)); if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then Spec_Id := Defining_Identifier (Spec_Id); end if; -- Accept statement, block, entry body, package body, protected body, -- subprogram body or task body. else Decls := Declarations (N); HSS := Handled_Statement_Sequence (N); if Present (HSS) then if Present (Statements (HSS)) then Stmts := Statements (HSS); end if; if Present (At_End_Proc (HSS)) then Prev_At_End := At_End_Proc (HSS); end if; end if; -- Retrieve the package spec id for package bodies if For_Package_Body then Spec_Id := Corresponding_Spec (N); end if; end if; -- Do not process nested packages since those are handled by the -- enclosing scope's finalizer. Do not process non-expanded package -- instantiations since those will be re-analyzed and re-expanded. if For_Package and then (not Is_Library_Level_Entity (Spec_Id) -- Nested packages are considered to be library level entities, -- but do not need to be processed separately. True library level -- packages have a scope value of 1. or else Scope_Depth_Value (Spec_Id) /= Uint_1 or else (Is_Generic_Instance (Spec_Id) and then Package_Instantiation (Spec_Id) /= N)) then return; end if; -- Step 2: Object [pre]processing if For_Package then -- Preprocess the visible declarations now in order to obtain the -- correct number of controlled object by the time the private -- declarations are processed. Process_Declarations (Decls, Preprocess => True, Top_Level => True); -- From all the possible contexts, only package specifications may -- have private declarations. if For_Package_Spec then Process_Declarations (Priv_Decls, Preprocess => True, Top_Level => True); end if; -- 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 Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then Build_Components; end if; -- 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; Process_Declarations (Decls); end if; -- Non-package case else -- Preprocess both declarations and statements Process_Declarations (Decls, Preprocess => True, Top_Level => True); Process_Declarations (Stmts, Preprocess => True, Top_Level => True); -- At this point it is known that N has controlled objects. Ensure -- that N has a declarative list since the finalizer spec will be -- attached to it. if Has_Ctrl_Objs and then No (Decls) then Set_Declarations (N, New_List); Decls := Declarations (N); Spec_Decls := Decls; end if; -- 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 Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then Build_Components; end if; if Has_Ctrl_Objs or Has_Tagged_Types then Process_Declarations (Stmts); Process_Declarations (Decls); end if; end if; -- Step 3: Finalizer creation if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then Create_Finalizer; end if; end Build_Finalizer; -------------------------- -- Build_Finalizer_Call -- -------------------------- procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is Is_Prot_Body : constant Boolean := Nkind (N) = N_Subprogram_Body and then Is_Protected_Subprogram_Body (N); -- Determine whether N denotes the protected version of a subprogram -- which belongs to a protected type. Loc : constant Source_Ptr := Sloc (N); HSS : Node_Id; begin -- Do not perform this expansion in Alfa mode because we do not create -- finalizers in the first place. if Alfa_Mode then return; end if; -- The At_End handler should have been assimilated by the finalizer HSS := Handled_Statement_Sequence (N); pragma Assert (No (At_End_Proc (HSS))); -- If the construct to be cleaned up is a protected subprogram body, the -- finalizer call needs to be associated with the block which wraps the -- unprotected version of the subprogram. The following illustrates this -- scenario: -- procedure Prot_SubpP is -- procedure finalizer is -- begin -- Service_Entries (Prot_Obj); -- Abort_Undefer; -- end finalizer; -- begin -- . . . -- begin -- Prot_SubpN (Prot_Obj); -- at end -- finalizer; -- end; -- end Prot_SubpP; if Is_Prot_Body then HSS := Handled_Statement_Sequence (Last (Statements (HSS))); -- An At_End handler and regular exception handlers cannot coexist in -- the same statement sequence. Wrap the original statements in a block. elsif Present (Exception_Handlers (HSS)) then declare End_Lab : constant Node_Id := End_Label (HSS); Block : Node_Id; begin Block := Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS); Set_Handled_Statement_Sequence (N, Make_Handled_Sequence_Of_Statements (Loc, New_List (Block))); HSS := Handled_Statement_Sequence (N); Set_End_Label (HSS, End_Lab); end; end if; Set_At_End_Proc (HSS, New_Reference_To (Fin_Id, Loc)); Analyze (At_End_Proc (HSS)); Expand_At_End_Handler (HSS, Empty); end Build_Finalizer_Call; --------------------- -- Build_Late_Proc -- --------------------- procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is begin for Final_Prim in Name_Of'Range loop if Name_Of (Final_Prim) = Nam then Set_TSS (Typ, Make_Deep_Proc (Prim => Final_Prim, Typ => Typ, Stmts => Make_Deep_Record_Body (Final_Prim, Typ))); end if; end loop; end Build_Late_Proc; ------------------------------- -- Build_Object_Declarations -- ------------------------------- procedure Build_Object_Declarations (Data : out Finalization_Exception_Data; Decls : List_Id; Loc : Source_Ptr; For_Package : Boolean := False) is A_Expr : Node_Id; E_Decl : Node_Id; begin pragma Assert (Decls /= No_List); -- Always set the proper location as it may be needed even when -- exception propagation is forbidden. Data.Loc := Loc; if Restriction_Active (No_Exception_Propagation) then Data.Abort_Id := Empty; Data.E_Id := Empty; Data.Raised_Id := Empty; return; end if; Data.Raised_Id := Make_Temporary (Loc, 'R'); -- In certain scenarios, finalization can be triggered by an abort. If -- the finalization itself fails and raises an exception, the resulting -- Program_Error must be supressed and replaced by an abort signal. In -- order to detect this scenario, save the state of entry into the -- finalization code. -- No need to do this for VM case, since VM version of Ada.Exceptions -- 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 Data.Abort_Id := Make_Temporary (Loc, 'A'); A_Expr := New_Reference_To (RTE (RE_Triggered_By_Abort), Loc); -- Generate: -- Abort_Id : constant Boolean := ; Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Data.Abort_Id, Constant_Present => True, Object_Definition => New_Reference_To (Standard_Boolean, Loc), Expression => A_Expr)); else -- No abort, .NET/JVM or library-level finalizers Data.Abort_Id := Empty; end if; if Exception_Extra_Info then Data.E_Id := Make_Temporary (Loc, 'E'); -- Generate: -- E_Id : Exception_Occurrence; E_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Data.E_Id, Object_Definition => New_Reference_To (RTE (RE_Exception_Occurrence), Loc)); Set_No_Initialization (E_Decl); Append_To (Decls, E_Decl); else Data.E_Id := Empty; end if; -- Generate: -- Raised_Id : Boolean := False; Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Data.Raised_Id, Object_Definition => New_Reference_To (Standard_Boolean, Loc), Expression => New_Reference_To (Standard_False, Loc))); end Build_Object_Declarations; --------------------------- -- Build_Raise_Statement -- --------------------------- function Build_Raise_Statement (Data : Finalization_Exception_Data) return Node_Id is Stmt : Node_Id; Expr : Node_Id; begin -- Standard run-time and .NET/JVM targets use the specialized routine -- Raise_From_Controlled_Operation. if Exception_Extra_Info and then RTE_Available (RE_Raise_From_Controlled_Operation) then Stmt := Make_Procedure_Call_Statement (Data.Loc, Name => New_Reference_To (RTE (RE_Raise_From_Controlled_Operation), Data.Loc), Parameter_Associations => New_List (New_Reference_To (Data.E_Id, Data.Loc))); -- Restricted run-time: exception messages are not supported and hence -- Raise_From_Controlled_Operation is not supported. Raise Program_Error -- instead. else Stmt := Make_Raise_Program_Error (Data.Loc, Reason => PE_Finalize_Raised_Exception); end if; -- Generate: -- Raised_Id and then not Abort_Id -- -- Raised_Id Expr := New_Reference_To (Data.Raised_Id, Data.Loc); if Present (Data.Abort_Id) then Expr := Make_And_Then (Data.Loc, Left_Opnd => Expr, Right_Opnd => Make_Op_Not (Data.Loc, Right_Opnd => New_Reference_To (Data.Abort_Id, Data.Loc))); end if; -- Generate: -- if Raised_Id and then not Abort_Id then -- Raise_From_Controlled_Operation (E_Id); -- -- raise Program_Error; -- restricted runtime -- end if; return Make_If_Statement (Data.Loc, Condition => Expr, Then_Statements => New_List (Stmt)); end Build_Raise_Statement; ----------------------------- -- Build_Record_Deep_Procs -- ----------------------------- procedure Build_Record_Deep_Procs (Typ : Entity_Id) is begin Set_TSS (Typ, Make_Deep_Proc (Prim => Initialize_Case, Typ => Typ, Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); if not Is_Immutably_Limited_Type (Typ) then Set_TSS (Typ, Make_Deep_Proc (Prim => Adjust_Case, Typ => Typ, Stmts => Make_Deep_Record_Body (Adjust_Case, Typ))); end if; -- Do not generate Deep_Finalize and Finalize_Address if finalization is -- suppressed since these routine will not be used. if not Restriction_Active (No_Finalization) then Set_TSS (Typ, Make_Deep_Proc (Prim => Finalize_Case, Typ => Typ, Stmts => Make_Deep_Record_Body (Finalize_Case, Typ))); -- Create TSS primitive Finalize_Address for non-VM targets. JVM and -- .NET do not support address arithmetic and unchecked conversions. if VM_Target = No_VM then Set_TSS (Typ, Make_Deep_Proc (Prim => Address_Case, Typ => Typ, Stmts => Make_Deep_Record_Body (Address_Case, Typ))); end if; end if; end Build_Record_Deep_Procs; ------------------- -- Cleanup_Array -- ------------------- function Cleanup_Array (N : Node_Id; Obj : Node_Id; Typ : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (N); Index_List : constant List_Id := New_List; function Free_Component return List_Id; -- Generate the code to finalize the task or protected subcomponents -- of a single component of the array. function Free_One_Dimension (Dim : Int) return List_Id; -- Generate a loop over one dimension of the array -------------------- -- Free_Component -- -------------------- function Free_Component return List_Id is Stmts : List_Id := New_List; Tsk : Node_Id; C_Typ : constant Entity_Id := Component_Type (Typ); begin -- Component type is known to contain tasks or protected objects Tsk := Make_Indexed_Component (Loc, Prefix => Duplicate_Subexpr_No_Checks (Obj), Expressions => Index_List); Set_Etype (Tsk, C_Typ); if Is_Task_Type (C_Typ) then Append_To (Stmts, Cleanup_Task (N, Tsk)); elsif Is_Simple_Protected_Type (C_Typ) then Append_To (Stmts, Cleanup_Protected_Object (N, Tsk)); elsif Is_Record_Type (C_Typ) then Stmts := Cleanup_Record (N, Tsk, C_Typ); elsif Is_Array_Type (C_Typ) then Stmts := Cleanup_Array (N, Tsk, C_Typ); end if; return Stmts; end Free_Component; ------------------------ -- Free_One_Dimension -- ------------------------ function Free_One_Dimension (Dim : Int) return List_Id is Index : Entity_Id; begin if Dim > Number_Dimensions (Typ) then return Free_Component; -- Here we generate the required loop else Index := Make_Temporary (Loc, 'J'); Append (New_Reference_To (Index, Loc), Index_List); return New_List ( Make_Implicit_Loop_Statement (N, Identifier => Empty, Iteration_Scheme => Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, Defining_Identifier => Index, Discrete_Subtype_Definition => Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr (Obj), Attribute_Name => Name_Range, Expressions => New_List ( Make_Integer_Literal (Loc, Dim))))), Statements => Free_One_Dimension (Dim + 1))); end if; end Free_One_Dimension; -- Start of processing for Cleanup_Array begin return Free_One_Dimension (1); end Cleanup_Array; -------------------- -- Cleanup_Record -- -------------------- function Cleanup_Record (N : Node_Id; Obj : Node_Id; Typ : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (N); Tsk : Node_Id; Comp : Entity_Id; Stmts : constant List_Id := New_List; U_Typ : constant Entity_Id := Underlying_Type (Typ); begin if Has_Discriminants (U_Typ) and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration and then Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition and then Present (Variant_Part (Component_List (Type_Definition (Parent (U_Typ))))) then -- For now, do not attempt to free a component that may appear in a -- variant, and instead issue a warning. Doing this "properly" would -- require building a case statement and would be quite a mess. Note -- that the RM only requires that free "work" for the case of a task -- access value, so already we go way beyond this in that we deal -- with the array case and non-discriminated record cases. Error_Msg_N ("task/protected object in variant record will not be freed?", N); return New_List (Make_Null_Statement (Loc)); end if; Comp := First_Component (Typ); while Present (Comp) loop if Has_Task (Etype (Comp)) or else Has_Simple_Protected_Object (Etype (Comp)) then Tsk := Make_Selected_Component (Loc, Prefix => Duplicate_Subexpr_No_Checks (Obj), Selector_Name => New_Occurrence_Of (Comp, Loc)); Set_Etype (Tsk, Etype (Comp)); if Is_Task_Type (Etype (Comp)) then Append_To (Stmts, Cleanup_Task (N, Tsk)); elsif Is_Simple_Protected_Type (Etype (Comp)) then Append_To (Stmts, Cleanup_Protected_Object (N, Tsk)); elsif Is_Record_Type (Etype (Comp)) then -- Recurse, by generating the prefix of the argument to -- the eventual cleanup call. Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp))); elsif Is_Array_Type (Etype (Comp)) then Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp))); end if; end if; Next_Component (Comp); end loop; return Stmts; end Cleanup_Record; ------------------------------ -- Cleanup_Protected_Object -- ------------------------------ function Cleanup_Protected_Object (N : Node_Id; Ref : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); begin -- For restricted run-time libraries (Ravenscar), tasks are -- non-terminating, and protected objects can only appear at library -- level, so we do not want finalization of protected objects. if Restricted_Profile then return Empty; else return Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Finalize_Protection), Loc), Parameter_Associations => New_List (Concurrent_Ref (Ref))); end if; end Cleanup_Protected_Object; ------------------ -- Cleanup_Task -- ------------------ function Cleanup_Task (N : Node_Id; Ref : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); begin -- For restricted run-time libraries (Ravenscar), tasks are -- non-terminating and they can only appear at library level, so we do -- not want finalization of task objects. if Restricted_Profile then return Empty; else return Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Free_Task), Loc), Parameter_Associations => New_List (Concurrent_Ref (Ref))); end if; end Cleanup_Task; ------------------------------ -- Check_Visibly_Controlled -- ------------------------------ procedure Check_Visibly_Controlled (Prim : Final_Primitives; Typ : Entity_Id; E : in out Entity_Id; Cref : in out Node_Id) is Parent_Type : Entity_Id; Op : Entity_Id; begin if Is_Derived_Type (Typ) and then Comes_From_Source (E) and then not Present (Overridden_Operation (E)) then -- We know that the explicit operation on the type does not override -- the inherited operation of the parent, and that the derivation -- is from a private type that is not visibly controlled. Parent_Type := Etype (Typ); Op := Find_Prim_Op (Parent_Type, Name_Of (Prim)); if Present (Op) then E := Op; -- Wrap the object to be initialized into the proper -- unchecked conversion, to be compatible with the operation -- to be called. if Nkind (Cref) = N_Unchecked_Type_Conversion then Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref)); else Cref := Unchecked_Convert_To (Parent_Type, Cref); end if; end if; end if; end Check_Visibly_Controlled; ------------------------------- -- CW_Or_Has_Controlled_Part -- ------------------------------- function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is begin return Is_Class_Wide_Type (T) or else Needs_Finalization (T); end CW_Or_Has_Controlled_Part; ------------------ -- Convert_View -- ------------------ function Convert_View (Proc : Entity_Id; Arg : Node_Id; Ind : Pos := 1) return Node_Id is Fent : Entity_Id := First_Entity (Proc); Ftyp : Entity_Id; Atyp : Entity_Id; begin for J in 2 .. Ind loop Next_Entity (Fent); end loop; Ftyp := Etype (Fent); if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then Atyp := Entity (Subtype_Mark (Arg)); else Atyp := Etype (Arg); end if; if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg); elsif Ftyp /= Atyp and then Present (Atyp) and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp)) and then Base_Type (Underlying_Type (Atyp)) = Base_Type (Underlying_Type (Ftyp)) then return Unchecked_Convert_To (Ftyp, Arg); -- If the argument is already a conversion, as generated by -- Make_Init_Call, set the target type to the type of the formal -- directly, to avoid spurious typing problems. elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion) and then not Is_Class_Wide_Type (Atyp) then Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg))); Set_Etype (Arg, Ftyp); return Arg; else return Arg; end if; end Convert_View; ------------------------ -- Enclosing_Function -- ------------------------ function Enclosing_Function (E : Entity_Id) return Entity_Id is Func_Id : Entity_Id; begin Func_Id := E; while Present (Func_Id) and then Func_Id /= Standard_Standard loop if Ekind (Func_Id) = E_Function then return Func_Id; end if; Func_Id := Scope (Func_Id); end loop; return Empty; end Enclosing_Function; ------------------------------- -- Establish_Transient_Scope -- ------------------------------- -- This procedure is called each time a transient block has to be inserted -- that is to say for each call to a function with unconstrained or tagged -- result. It creates a new scope on the stack scope in order to enclose -- all transient variables generated procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is Loc : constant Source_Ptr := Sloc (N); Wrap_Node : Node_Id; begin -- Do not create a transient scope if we are already inside one for S in reverse Scope_Stack.First .. Scope_Stack.Last loop if Scope_Stack.Table (S).Is_Transient then if Sec_Stack then Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity); end if; return; -- If we have encountered Standard there are no enclosing -- transient scopes. elsif Scope_Stack.Table (S).Entity = Standard_Standard then exit; end if; end loop; Wrap_Node := Find_Node_To_Be_Wrapped (N); -- Case of no wrap node, false alert, no transient scope needed if No (Wrap_Node) then null; -- If the node to wrap is an iteration_scheme, the expression is -- one of the bounds, and the expansion will make an explicit -- declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb), -- so do not apply any transformations here. Same for an Ada 2012 -- iterator specification, where a block is created for the expression -- that build the container. elsif Nkind_In (Wrap_Node, N_Iteration_Scheme, N_Iterator_Specification) 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 Sec_Stack then Set_Uses_Sec_Stack (Current_Scope); Check_Restriction (No_Secondary_Stack, N); end if; Set_Etype (Current_Scope, Standard_Void_Type); Set_Node_To_Be_Wrapped (Wrap_Node); if Debug_Flag_W then Write_Str (" "); Write_Eol; end if; end if; end Establish_Transient_Scope; ---------------------------- -- Expand_Cleanup_Actions -- ---------------------------- procedure Expand_Cleanup_Actions (N : Node_Id) is Scop : constant Entity_Id := Current_Scope; Is_Asynchronous_Call : constant Boolean := Nkind (N) = N_Block_Statement and then Is_Asynchronous_Call_Block (N); Is_Master : constant Boolean := Nkind (N) /= N_Entry_Body and then Is_Task_Master (N); Is_Protected_Body : constant Boolean := Nkind (N) = N_Subprogram_Body and then Is_Protected_Subprogram_Body (N); Is_Task_Allocation : constant Boolean := Nkind (N) = N_Block_Statement and then Is_Task_Allocation_Block (N); Is_Task_Body : constant Boolean := Nkind (Original_Node (N)) = N_Task_Body; Needs_Sec_Stack_Mark : constant Boolean := Uses_Sec_Stack (Scop) and then not Sec_Stack_Needed_For_Return (Scop) and then VM_Target = No_VM; Actions_Required : constant Boolean := Requires_Cleanup_Actions (N, True) or else Is_Asynchronous_Call or else Is_Master or else Is_Protected_Body or else Is_Task_Allocation or else Is_Task_Body or else Needs_Sec_Stack_Mark; HSS : Node_Id := Handled_Statement_Sequence (N); Loc : Source_Ptr; procedure Wrap_HSS_In_Block; -- Move HSS inside a new block along with the original exception -- handlers. Make the newly generated block the sole statement of HSS. ----------------------- -- Wrap_HSS_In_Block -- ----------------------- procedure Wrap_HSS_In_Block is Block : Node_Id; End_Lab : Node_Id; begin -- Preserve end label to provide proper cross-reference information End_Lab := End_Label (HSS); Block := Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS); -- Signal the finalization machinery that this particular block -- contains the original context. Set_Is_Finalization_Wrapper (Block); Set_Handled_Statement_Sequence (N, Make_Handled_Sequence_Of_Statements (Loc, New_List (Block))); HSS := Handled_Statement_Sequence (N); Set_First_Real_Statement (HSS, Block); Set_End_Label (HSS, End_Lab); -- Comment needed here, see RH for 1.306 ??? if Nkind (N) = N_Subprogram_Body then Set_Has_Nested_Block_With_Handler (Scop); end if; end Wrap_HSS_In_Block; -- Start of processing for Expand_Cleanup_Actions begin -- The current construct does not need any form of servicing if not Actions_Required then return; -- If the current node is a rewritten task body and the descriptors have -- not been delayed (due to some nested instantiations), do not generate -- redundant cleanup actions. elsif Is_Task_Body and then Nkind (N) = N_Subprogram_Body and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N)) then return; end if; declare Decls : List_Id := Declarations (N); Fin_Id : Entity_Id; Mark : Entity_Id := Empty; New_Decls : List_Id; Old_Poll : Boolean; begin -- If we are generating expanded code for debugging purposes, use the -- Sloc of the point of insertion for the cleanup code. The Sloc will -- be updated subsequently to reference the proper line in .dg files. -- If we are not debugging generated code, use No_Location instead, -- so that no debug information is generated for the cleanup code. -- This makes the behavior of the NEXT command in GDB monotonic, and -- makes the placement of breakpoints more accurate. if Debug_Generated_Code then Loc := Sloc (Scop); else Loc := No_Location; end if; -- Set polling off. The finalization and cleanup code is executed -- with aborts deferred. Old_Poll := Polling_Required; Polling_Required := False; -- A task activation call has already been built for a task -- allocation block. if not Is_Task_Allocation then Build_Task_Activation_Call (N); end if; if Is_Master then Establish_Task_Master (N); end if; New_Decls := New_List; -- If secondary stack is in use, generate: -- -- Mnn : constant Mark_Id := SS_Mark; -- Suppress calls to SS_Mark and SS_Release if VM_Target, since the -- secondary stack is never used on a VM. if Needs_Sec_Stack_Mark then Mark := Make_Temporary (Loc, 'M'); Append_To (New_Decls, Make_Object_Declaration (Loc, Defining_Identifier => Mark, Object_Definition => New_Reference_To (RTE (RE_Mark_Id), Loc), Expression => Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_SS_Mark), Loc)))); Set_Uses_Sec_Stack (Scop, False); end if; -- If exception handlers are present, wrap the sequence of statements -- in a block since it is not possible to have exception handlers and -- an At_End handler in the same construct. if Present (Exception_Handlers (HSS)) then Wrap_HSS_In_Block; -- Ensure that the First_Real_Statement field is set elsif No (First_Real_Statement (HSS)) then Set_First_Real_Statement (HSS, First (Statements (HSS))); end if; -- Do not move the Activation_Chain declaration in the context of -- task allocation blocks. Task allocation blocks use _chain in their -- cleanup handlers and gigi complains if it is declared in the -- sequence of statements of the scope that declares the handler. if Is_Task_Allocation then declare Chain : constant Entity_Id := Activation_Chain_Entity (N); Decl : Node_Id; begin Decl := First (Decls); while Nkind (Decl) /= N_Object_Declaration or else Defining_Identifier (Decl) /= Chain loop Next (Decl); -- A task allocation block should always include a _chain -- declaration. pragma Assert (Present (Decl)); end loop; Remove (Decl); Prepend_To (New_Decls, Decl); end; end if; -- Ensure the presence of a declaration list in order to successfully -- append all original statements to it. if No (Decls) then Set_Declarations (N, New_List); Decls := Declarations (N); end if; -- Move the declarations into the sequence of statements in order to -- have them protected by the At_End handler. It may seem weird to -- put declarations in the sequence of statement but in fact nothing -- forbids that at the tree level. Append_List_To (Decls, Statements (HSS)); Set_Statements (HSS, Decls); -- Reset the Sloc of the handled statement sequence to properly -- reflect the new initial "statement" in the sequence. Set_Sloc (HSS, Sloc (First (Decls))); -- The declarations of finalizer spec and auxiliary variables replace -- the old declarations that have been moved inward. Set_Declarations (N, New_Decls); Analyze_Declarations (New_Decls); -- Generate finalization calls for all controlled objects appearing -- in the statements of N. Add context specific cleanup for various -- constructs. Build_Finalizer (N => N, Clean_Stmts => Build_Cleanup_Statements (N), Mark_Id => Mark, Top_Decls => New_Decls, Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body or else Is_Master, Fin_Id => Fin_Id); if Present (Fin_Id) then Build_Finalizer_Call (N, Fin_Id); end if; -- Restore saved polling mode Polling_Required := Old_Poll; end; end Expand_Cleanup_Actions; --------------------------- -- Expand_N_Package_Body -- --------------------------- -- Add call to Activate_Tasks if body is an activator (actual processing -- is in chapter 9). -- Generate subprogram descriptor for elaboration routine -- Encode entity names in package body procedure Expand_N_Package_Body (N : Node_Id) is Spec_Ent : constant Entity_Id := Corresponding_Spec (N); Fin_Id : Entity_Id; begin -- This is done only for non-generic packages if Ekind (Spec_Ent) = E_Package then Push_Scope (Corresponding_Spec (N)); -- Build dispatch tables of library level tagged types 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); Pop_Scope; end if; Set_Elaboration_Flag (N, Corresponding_Spec (N)); Set_In_Package_Body (Spec_Ent, False); -- Set to encode entity names in package body before gigi is called Qualify_Entity_Names (N); if Ekind (Spec_Ent) /= E_Generic_Package then Build_Finalizer (N => N, Clean_Stmts => No_List, Mark_Id => Empty, Top_Decls => No_List, Defer_Abort => False, Fin_Id => Fin_Id); if Present (Fin_Id) then declare Body_Ent : Node_Id := Defining_Unit_Name (N); begin if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then Body_Ent := Defining_Identifier (Body_Ent); end if; Set_Finalizer (Body_Ent, Fin_Id); end; end if; end if; end Expand_N_Package_Body; ---------------------------------- -- Expand_N_Package_Declaration -- ---------------------------------- -- Add call to Activate_Tasks if there are tasks declared and the package -- has no body. Note that in Ada 83 this may result in premature activation -- of some tasks, given that we cannot tell whether a body will eventually -- appear. procedure Expand_N_Package_Declaration (N : Node_Id) is Id : constant Entity_Id := Defining_Entity (N); Spec : constant Node_Id := Specification (N); Decls : List_Id; Fin_Id : Entity_Id; No_Body : Boolean := False; -- True in the case of a package declaration that is a compilation -- unit and for which no associated body will be compiled in this -- compilation. begin -- Case of a package declaration other than a compilation unit if Nkind (Parent (N)) /= N_Compilation_Unit then null; -- Case of a compilation unit that does not require a body elsif not Body_Required (Parent (N)) and then not Unit_Requires_Body (Id) then No_Body := True; -- Special case of generating calling stubs for a remote call interface -- package: even though the package declaration requires one, the body -- won't be processed in this compilation (so any stubs for RACWs -- declared in the package must be generated here, along with the spec). elsif Parent (N) = Cunit (Main_Unit) and then Is_Remote_Call_Interface (Id) and then Distribution_Stub_Mode = Generate_Caller_Stub_Body then No_Body := True; end if; -- For a nested instance, delay processing until freeze point if Has_Delayed_Freeze (Id) and then Nkind (Parent (N)) /= N_Compilation_Unit then return; end if; -- For a package declaration that implies no associated body, generate -- task activation call and RACW supporting bodies now (since we won't -- have a specific separate compilation unit for that). if No_Body then Push_Scope (Id); if Has_RACW (Id) then -- Generate RACW subprogram bodies Decls := Private_Declarations (Spec); if No (Decls) then Decls := Visible_Declarations (Spec); end if; if No (Decls) then Decls := New_List; Set_Visible_Declarations (Spec, Decls); end if; Append_RACW_Bodies (Decls, Id); Analyze_List (Decls); end if; if Present (Activation_Chain_Entity (N)) then -- Generate task activation call as last step of elaboration Build_Task_Activation_Call (N); end if; Pop_Scope; end if; -- Build dispatch tables of library level tagged types if Tagged_Type_Expansion and then (Is_Compilation_Unit (Id) or else (Is_Generic_Instance (Id) and then Is_Library_Level_Entity (Id))) then Build_Static_Dispatch_Tables (N); end if; -- Note: it is not necessary to worry about generating a subprogram -- descriptor, since the only way to get exception handlers into a -- package spec is to include instantiations, and that would cause -- generation of subprogram descriptors to be delayed in any case. -- Set to encode entity names in package spec before gigi is called Qualify_Entity_Names (N); if Ekind (Id) /= E_Generic_Package then Build_Finalizer (N => N, Clean_Stmts => No_List, Mark_Id => Empty, Top_Decls => No_List, Defer_Abort => False, Fin_Id => Fin_Id); Set_Finalizer (Id, Fin_Id); end if; end Expand_N_Package_Declaration; ----------------------------- -- Find_Node_To_Be_Wrapped -- ----------------------------- function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is P : Node_Id; The_Parent : Node_Id; begin The_Parent := N; loop P := The_Parent; pragma Assert (P /= Empty); The_Parent := Parent (P); case Nkind (The_Parent) is -- Simple statement can be wrapped when N_Pragma => return The_Parent; -- Usually assignments are good candidate for wrapping except -- when they have been generated as part of a controlled aggregate -- where the wrapping should take place more globally. when N_Assignment_Statement => if No_Ctrl_Actions (The_Parent) then null; else return The_Parent; end if; -- An entry call statement is a special case if it occurs in the -- context of a Timed_Entry_Call. In this case we wrap the entire -- timed entry call. when N_Entry_Call_Statement | N_Procedure_Call_Statement => if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative and then Nkind_In (Parent (Parent (The_Parent)), N_Timed_Entry_Call, N_Conditional_Entry_Call) then return Parent (Parent (The_Parent)); else return The_Parent; end if; -- Object declarations are also a boundary for the transient scope -- even if they are not really wrapped. For further details, see -- Wrap_Transient_Declaration. when N_Object_Declaration | N_Object_Renaming_Declaration | N_Subtype_Declaration => return The_Parent; -- The expression itself is to be wrapped if its parent is a -- compound statement or any other statement where the expression -- is known to be scalar when N_Accept_Alternative | N_Attribute_Definition_Clause | N_Case_Statement | N_Code_Statement | N_Delay_Alternative | N_Delay_Until_Statement | N_Delay_Relative_Statement | N_Discriminant_Association | N_Elsif_Part | N_Entry_Body_Formal_Part | N_Exit_Statement | N_If_Statement | N_Iteration_Scheme | N_Terminate_Alternative => return P; when N_Attribute_Reference => if Is_Procedure_Attribute_Name (Attribute_Name (The_Parent)) then return The_Parent; end if; -- A raise statement can be wrapped. This will arise when the -- expression in a raise_with_expression uses the secondary -- stack, for example. when N_Raise_Statement => return The_Parent; -- If the expression is within the iteration scheme of a loop, -- we must create a declaration for it, followed by an assignment -- in order to have a usable statement to wrap. when N_Loop_Parameter_Specification => return Parent (The_Parent); -- The following nodes contains "dummy calls" which don't need to -- be wrapped. when N_Parameter_Specification | N_Discriminant_Specification | N_Component_Declaration => return Empty; -- The return statement is not to be wrapped when the function -- itself needs wrapping at the outer-level when N_Simple_Return_Statement => declare Applies_To : constant Entity_Id := Return_Applies_To (Return_Statement_Entity (The_Parent)); Return_Type : constant Entity_Id := Etype (Applies_To); begin if Requires_Transient_Scope (Return_Type) then return Empty; else return The_Parent; end if; end; -- If we leave a scope without having been able to find a node to -- wrap, something is going wrong but this can happen in error -- situation that are not detected yet (such as a dynamic string -- in a pragma export) when N_Subprogram_Body | N_Package_Declaration | N_Package_Body | N_Block_Statement => return Empty; -- Otherwise continue the search when others => null; end case; end loop; end Find_Node_To_Be_Wrapped; ------------------------------------- -- Get_Global_Pool_For_Access_Type -- ------------------------------------- function Get_Global_Pool_For_Access_Type (T : Entity_Id) return Entity_Id is begin -- Access types whose size is smaller than System.Address size can exist -- only on VMS. We can't use the usual global pool which returns an -- object of type Address as truncation will make it invalid. To handle -- this case, VMS has a dedicated global pool that returns addresses -- that fit into 32 bit accesses. if Opt.True_VMS_Target and then Esize (T) = 32 then return RTE (RE_Global_Pool_32_Object); else return RTE (RE_Global_Pool_Object); end if; end Get_Global_Pool_For_Access_Type; ---------------------------------- -- Has_New_Controlled_Component -- ---------------------------------- function Has_New_Controlled_Component (E : Entity_Id) return Boolean is Comp : Entity_Id; begin if not Is_Tagged_Type (E) then return Has_Controlled_Component (E); elsif not Is_Derived_Type (E) then return Has_Controlled_Component (E); end if; Comp := First_Component (E); while Present (Comp) loop if Chars (Comp) = Name_uParent then null; elsif Scope (Original_Record_Component (Comp)) = E and then Needs_Finalization (Etype (Comp)) then return True; end if; Next_Component (Comp); end loop; return False; end Has_New_Controlled_Component; --------------------------------- -- Has_Simple_Protected_Object -- --------------------------------- function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is begin if Has_Task (T) then return False; elsif Is_Simple_Protected_Type (T) then return True; elsif Is_Array_Type (T) then return Has_Simple_Protected_Object (Component_Type (T)); elsif Is_Record_Type (T) then declare Comp : Entity_Id; begin Comp := First_Component (T); while Present (Comp) loop if Has_Simple_Protected_Object (Etype (Comp)) then return True; end if; Next_Component (Comp); end loop; return False; end; else return False; end if; end Has_Simple_Protected_Object; ------------------------------------ -- Insert_Actions_In_Scope_Around -- ------------------------------------ procedure Insert_Actions_In_Scope_Around (N : Node_Id) is After : constant List_Id := Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped_After; Before : constant List_Id := Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped_Before; -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack. -- Last), but this was incorrect as Process_Transient_Object may -- introduce new scopes and cause a reallocation of Scope_Stack.Table. procedure Process_Transient_Objects (First_Object : Node_Id; Last_Object : Node_Id; Related_Node : Node_Id); -- First_Object and Last_Object define a list which contains potential -- controlled transient objects. Finalization flags are inserted before -- First_Object and finalization calls are inserted after Last_Object. -- Related_Node is the node for which transient objects have been -- created. ------------------------------- -- Process_Transient_Objects -- ------------------------------- procedure Process_Transient_Objects (First_Object : Node_Id; Last_Object : Node_Id; Related_Node : Node_Id) is function Requires_Hooking return Boolean; -- Determine whether the context requires transient variable export -- to the outer finalizer. This scenario arises when the context may -- raise an exception. ---------------------- -- Requires_Hooking -- ---------------------- function Requires_Hooking return Boolean is begin -- The context is either a procedure or function call or an object -- declaration initialized by a function call. Note that in the -- latter case, a function call that returns on the secondary -- stack is usually rewritten into something else. Its proper -- detection requires examination of the original initialization -- expression. return Nkind (N) in N_Subprogram_Call or else (Nkind (N) = N_Object_Declaration and then Nkind (Original_Node (Expression (N))) = N_Function_Call); end Requires_Hooking; -- Local variables Must_Hook : constant Boolean := Requires_Hooking; Built : Boolean := False; Desig_Typ : Entity_Id; Fin_Block : Node_Id; Fin_Data : Finalization_Exception_Data; Fin_Decls : List_Id; Last_Fin : Node_Id := Empty; Loc : Source_Ptr; Obj_Id : Entity_Id; Obj_Ref : Node_Id; Obj_Typ : Entity_Id; Prev_Fin : Node_Id := Empty; Stmt : Node_Id; Stmts : List_Id; Temp_Id : Entity_Id; -- Start of processing for Process_Transient_Objects begin -- Examine all objects in the list First_Object .. Last_Object Stmt := First_Object; while Present (Stmt) loop if Nkind (Stmt) = N_Object_Declaration and then Analyzed (Stmt) and then Is_Finalizable_Transient (Stmt, N) -- Do not process the node to be wrapped since it will be -- handled by the enclosing finalizer. and then Stmt /= Related_Node then Loc := Sloc (Stmt); Obj_Id := Defining_Identifier (Stmt); Obj_Typ := Base_Type (Etype (Obj_Id)); Desig_Typ := Obj_Typ; Set_Is_Processed_Transient (Obj_Id); -- Handle access types if Is_Access_Type (Desig_Typ) then Desig_Typ := Available_View (Designated_Type (Desig_Typ)); end if; -- Create the necessary entities and declarations the first -- time around. if not Built then Fin_Decls := New_List; Build_Object_Declarations (Fin_Data, Fin_Decls, Loc); Built := True; end if; -- Transient variables associated with subprogram calls need -- extra processing. These variables are usually created right -- before the call and finalized immediately after the call. -- If an exception occurs during the call, the clean up code -- is skipped due to the sudden change in control and the -- transient is never finalized. -- To handle this case, such variables are "exported" to the -- enclosing sequence of statements where their corresponding -- "hooks" are picked up by the finalization machinery. if Must_Hook then declare Expr : Node_Id; Ptr_Id : Entity_Id; begin -- Step 1: Create an access type which provides a -- reference to the transient object. Generate: -- Ann : access [all] ; Ptr_Id := Make_Temporary (Loc, 'A'); Insert_Action (Stmt, Make_Full_Type_Declaration (Loc, Defining_Identifier => Ptr_Id, Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => Ekind (Obj_Typ) = E_General_Access_Type, Subtype_Indication => New_Reference_To (Desig_Typ, Loc)))); -- Step 2: Create a temporary which acts as a hook to -- the transient object. Generate: -- Temp : Ptr_Id := null; Temp_Id := Make_Temporary (Loc, 'T'); Insert_Action (Stmt, Make_Object_Declaration (Loc, Defining_Identifier => Temp_Id, Object_Definition => New_Reference_To (Ptr_Id, Loc))); -- Mark the temporary as a transient hook. This signals -- the machinery in Build_Finalizer to recognize this -- special case. Set_Status_Flag_Or_Transient_Decl (Temp_Id, Stmt); -- Step 3: Hook the transient object to the temporary if Is_Access_Type (Obj_Typ) then Expr := Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc)); else Expr := Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Obj_Id, Loc), Attribute_Name => Name_Unrestricted_Access); end if; -- Generate: -- Temp := Ptr_Id (Obj_Id); -- -- Temp := Obj_Id'Unrestricted_Access; Insert_After_And_Analyze (Stmt, Make_Assignment_Statement (Loc, Name => New_Reference_To (Temp_Id, Loc), Expression => Expr)); end; end if; Stmts := New_List; -- The transient object is about to be finalized by the clean -- up code following the subprogram call. In order to avoid -- double finalization, clear the hook. -- Generate: -- Temp := null; if Must_Hook then Append_To (Stmts, Make_Assignment_Statement (Loc, Name => New_Reference_To (Temp_Id, Loc), Expression => Make_Null (Loc))); end if; -- Generate: -- [Deep_]Finalize (Obj_Ref); Obj_Ref := New_Reference_To (Obj_Id, Loc); if Is_Access_Type (Obj_Typ) then Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); end if; Append_To (Stmts, Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ)); -- Generate: -- [Temp := null;] -- begin -- [Deep_]Finalize (Obj_Ref); -- exception -- when others => -- if not Raised then -- Raised := True; -- Save_Occurrence -- (Enn, Get_Current_Excep.all.all); -- end if; -- end; Fin_Block := Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts, Exception_Handlers => New_List ( Build_Exception_Handler (Fin_Data)))); -- The single raise statement must be inserted after all the -- finalization blocks, and we put everything into a wrapper -- block to clearly expose the construct to the back-end. if Present (Prev_Fin) then Insert_Before_And_Analyze (Prev_Fin, Fin_Block); else Insert_After_And_Analyze (Last_Object, Make_Block_Statement (Loc, Declarations => Fin_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Fin_Block)))); Last_Fin := Fin_Block; end if; Prev_Fin := Fin_Block; end if; -- Terminate the scan after the last object has been processed to -- avoid touching unrelated code. if Stmt = Last_Object then exit; end if; Next (Stmt); end loop; -- Generate: -- if Raised and then not Abort then -- Raise_From_Controlled_Operation (E); -- end if; if Built and then Present (Last_Fin) then Insert_After_And_Analyze (Last_Fin, Build_Raise_Statement (Fin_Data)); end if; end Process_Transient_Objects; -- Start of processing for Insert_Actions_In_Scope_Around begin if No (Before) and then No (After) then return; end if; declare Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped; First_Obj : Node_Id; Last_Obj : Node_Id; Target : Node_Id; begin -- If the node to be wrapped is the trigger of an asynchronous -- select, it is not part of a statement list. The actions must be -- inserted before the select itself, which is part of some list of -- statements. Note that the triggering alternative includes the -- triggering statement and an optional statement list. If the node -- to be wrapped is part of that list, the normal insertion applies. if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative and then not Is_List_Member (Node_To_Wrap) then Target := Parent (Parent (Node_To_Wrap)); else Target := N; end if; First_Obj := Target; Last_Obj := Target; -- Add all actions associated with a transient scope into the main -- tree. There are several scenarios here: -- +--- Before ----+ +----- After ---+ -- 1) First_Obj ....... Target ........ Last_Obj -- 2) First_Obj ....... Target -- 3) Target ........ Last_Obj if Present (Before) then -- Flag declarations are inserted before the first object First_Obj := First (Before); Insert_List_Before (Target, Before); end if; if Present (After) then -- Finalization calls are inserted after the last object Last_Obj := Last (After); Insert_List_After (Target, After); end if; -- Check for transient controlled objects associated with Target and -- generate the appropriate finalization actions for them. Process_Transient_Objects (First_Object => First_Obj, Last_Object => Last_Obj, Related_Node => Target); -- Reset the action lists if Present (Before) then Scope_Stack.Table (Scope_Stack.Last). Actions_To_Be_Wrapped_Before := No_List; end if; if Present (After) then Scope_Stack.Table (Scope_Stack.Last). Actions_To_Be_Wrapped_After := No_List; end if; end; end Insert_Actions_In_Scope_Around; ------------------------------ -- Is_Simple_Protected_Type -- ------------------------------ function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is begin return Is_Protected_Type (T) and then not Uses_Lock_Free (T) and then not Has_Entries (T) and then Is_RTE (Find_Protection_Type (T), RE_Protection); end Is_Simple_Protected_Type; ----------------------- -- Make_Adjust_Call -- ----------------------- function Make_Adjust_Call (Obj_Ref : Node_Id; Typ : Entity_Id; For_Parent : Boolean := False) return Node_Id is Loc : constant Source_Ptr := Sloc (Obj_Ref); Adj_Id : Entity_Id := Empty; Ref : Node_Id := Obj_Ref; Utyp : Entity_Id; begin -- Recover the proper type which contains Deep_Adjust if Is_Class_Wide_Type (Typ) then Utyp := Root_Type (Typ); else Utyp := Typ; end if; Utyp := Underlying_Type (Base_Type (Utyp)); Set_Assignment_OK (Ref); -- Deal with non-tagged derivation of private views if Is_Untagged_Derivation (Typ) then Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); Ref := Unchecked_Convert_To (Utyp, Ref); Set_Assignment_OK (Ref); end if; -- When dealing with the completion of a private type, use the base -- type instead. if Utyp /= Base_Type (Utyp) then pragma Assert (Is_Private_Type (Typ)); Utyp := Base_Type (Utyp); Ref := Unchecked_Convert_To (Utyp, Ref); end if; -- Select the appropriate version of adjust if For_Parent then if Has_Controlled_Component (Utyp) then Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust); end if; -- 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 := Find_Prim_Op (Utyp, TSS_Deep_Adjust); else Adj_Id := TSS (Utyp, TSS_Deep_Adjust); end if; -- 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 raise Program_Error; end if; if Present (Adj_Id) then -- If the object is unanalyzed, set its expected type for use in -- Convert_View in case an additional conversion is needed. if No (Etype (Ref)) and then Nkind (Ref) /= N_Unchecked_Type_Conversion then Set_Etype (Ref, Typ); end if; -- The object reference may need another conversion depending on the -- type of the formal and that of the actual. if not Is_Class_Wide_Type (Typ) then Ref := Convert_View (Adj_Id, Ref); end if; return Make_Call (Loc, Adj_Id, New_Copy_Tree (Ref), For_Parent); else return Empty; end if; end Make_Adjust_Call; ---------------------- -- Make_Attach_Call -- ---------------------- function Make_Attach_Call (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 Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Attach), Loc), Parameter_Associations => New_List ( New_Reference_To (Finalization_Master (Ptr_Typ), Loc), Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref))); end Make_Attach_Call; ---------------------- -- Make_Detach_Call -- ---------------------- function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Obj_Ref); begin return Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Detach), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref))); end Make_Detach_Call; --------------- -- Make_Call -- --------------- function Make_Call (Loc : Source_Ptr; Proc_Id : Entity_Id; Param : Node_Id; For_Parent : Boolean := False) return Node_Id is Params : constant List_Id := New_List (Param); begin -- When creating a call to Deep_Finalize for a _parent field of a -- derived type, disable the invocation of the nested Finalize by giving -- the corresponding flag a False value. if For_Parent then Append_To (Params, New_Reference_To (Standard_False, Loc)); end if; return Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (Proc_Id, Loc), Parameter_Associations => Params); end Make_Call; -------------------------- -- Make_Deep_Array_Body -- -------------------------- function Make_Deep_Array_Body (Prim : Final_Primitives; Typ : Entity_Id) return List_Id is function Build_Adjust_Or_Finalize_Statements (Typ : Entity_Id) return List_Id; -- Create the statements necessary to adjust or finalize an array of -- controlled elements. Generate: -- -- declare -- Abort : constant Boolean := Triggered_By_Abort; -- -- Abort : constant Boolean := False; -- no abort -- -- E : Exception_Occurrence; -- Raised : Boolean := False; -- -- begin -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop -- ^-- in the finalization case -- ... -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop -- begin -- [Deep_]Adjust / Finalize (V (J1, ..., Jn)); -- -- exception -- when others => -- if not Raised then -- Raised := True; -- Save_Occurrence (E, Get_Current_Excep.all.all); -- end if; -- end; -- end loop; -- ... -- end loop; -- -- if Raised and then not Abort then -- Raise_From_Controlled_Operation (E); -- end if; -- end; function Build_Initialize_Statements (Typ : Entity_Id) return List_Id; -- Create the statements necessary to initialize an array of controlled -- elements. Include a mechanism to carry out partial finalization if an -- exception occurs. Generate: -- -- declare -- Counter : Integer := 0; -- -- begin -- for J1 in V'Range (1) loop -- ... -- for JN in V'Range (N) loop -- begin -- [Deep_]Initialize (V (J1, ..., JN)); -- -- Counter := Counter + 1; -- -- exception -- when others => -- declare -- Abort : constant Boolean := Triggered_By_Abort; -- -- Abort : constant Boolean := False; -- no abort -- E : Exception_Occurence; -- Raised : Boolean := False; -- begin -- Counter := -- V'Length (1) * -- V'Length (2) * -- ... -- V'Length (N) - Counter; -- for F1 in reverse V'Range (1) loop -- ... -- for FN in reverse V'Range (N) loop -- if Counter > 0 then -- Counter := Counter - 1; -- else -- begin -- [Deep_]Finalize (V (F1, ..., FN)); -- exception -- when others => -- if not Raised then -- Raised := True; -- Save_Occurrence (E, -- Get_Current_Excep.all.all); -- end if; -- end; -- end if; -- end loop; -- ... -- end loop; -- end; -- -- if Raised and then not Abort then -- Raise_From_Controlled_Operation (E); -- end if; -- -- raise; -- end; -- end loop; -- end loop; -- end; function New_References_To (L : List_Id; Loc : Source_Ptr) return List_Id; -- Given a list of defining identifiers, return a list of references to -- the original identifiers, in the same order as they appear. ----------------------------------------- -- Build_Adjust_Or_Finalize_Statements -- ----------------------------------------- function Build_Adjust_Or_Finalize_Statements (Typ : Entity_Id) return List_Id is Comp_Typ : constant Entity_Id := Component_Type (Typ); Index_List : constant List_Id := New_List; Loc : constant Source_Ptr := Sloc (Typ); Num_Dims : constant Int := Number_Dimensions (Typ); Finalizer_Decls : List_Id := No_List; Finalizer_Data : Finalization_Exception_Data; Call : Node_Id; Comp_Ref : Node_Id; Core_Loop : Node_Id; Dim : Int; J : Entity_Id; Loop_Id : Entity_Id; Stmts : List_Id; Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); procedure Build_Indices; -- Generate the indices used in the dimension loops ------------------- -- Build_Indices -- ------------------- procedure Build_Indices is begin -- Generate the following identifiers: -- Jnn - for initialization for Dim in 1 .. Num_Dims loop Append_To (Index_List, Make_Defining_Identifier (Loc, New_External_Name ('J', Dim))); end loop; end Build_Indices; -- Start of processing for Build_Adjust_Or_Finalize_Statements begin Finalizer_Decls := New_List; Build_Indices; Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); Comp_Ref := Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Name_V), Expressions => New_References_To (Index_List, Loc)); Set_Etype (Comp_Ref, Comp_Typ); -- Generate: -- [Deep_]Adjust (V (J1, ..., JN)) if Prim = Adjust_Case then Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); -- Generate: -- [Deep_]Finalize (V (J1, ..., JN)) else pragma Assert (Prim = Finalize_Case); Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); end if; -- Generate the block which houses the adjust or finalize call: -- ; -- No_Exception_Propagation -- begin -- Exception handlers allowed -- -- exception -- when others => -- if not Raised then -- Raised := True; -- Save_Occurrence (E, Get_Current_Excep.all.all); -- end if; -- end; if Exceptions_OK then Core_Loop := Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Call), Exception_Handlers => New_List ( Build_Exception_Handler (Finalizer_Data)))); else Core_Loop := Call; end if; -- Generate the dimension loops starting from the innermost one -- for Jnn in [reverse] V'Range (Dim) loop -- -- end loop; J := Last (Index_List); Dim := Num_Dims; while Present (J) and then Dim > 0 loop Loop_Id := J; Prev (J); Remove (Loop_Id); Core_Loop := Make_Loop_Statement (Loc, Iteration_Scheme => Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, Defining_Identifier => Loop_Id, Discrete_Subtype_Definition => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_V), Attribute_Name => Name_Range, Expressions => New_List ( Make_Integer_Literal (Loc, Dim))), Reverse_Present => Prim = Finalize_Case)), Statements => New_List (Core_Loop), End_Label => Empty); Dim := Dim - 1; end loop; -- Generate the block which contains the core loop, the declarations -- of the abort flag, the exception occurrence, the raised flag and -- the conditional raise: -- declare -- Abort : constant Boolean := Triggered_By_Abort; -- -- Abort : constant Boolean := False; -- no abort -- E : Exception_Occurrence; -- Raised : Boolean := False; -- begin -- -- if Raised and then not Abort then -- Expection handlers OK -- Raise_From_Controlled_Operation (E); -- end if; -- end; Stmts := New_List (Core_Loop); if Exceptions_OK then Append_To (Stmts, Build_Raise_Statement (Finalizer_Data)); end if; return New_List ( Make_Block_Statement (Loc, Declarations => Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Stmts))); end Build_Adjust_Or_Finalize_Statements; --------------------------------- -- Build_Initialize_Statements -- --------------------------------- function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is Comp_Typ : constant Entity_Id := Component_Type (Typ); Final_List : constant List_Id := New_List; Index_List : constant List_Id := New_List; Loc : constant Source_Ptr := Sloc (Typ); Num_Dims : constant Int := Number_Dimensions (Typ); Counter_Id : Entity_Id; Dim : Int; F : Node_Id; Fin_Stmt : Node_Id; Final_Block : Node_Id; Final_Loop : Node_Id; Finalizer_Data : Finalization_Exception_Data; Finalizer_Decls : List_Id := No_List; Init_Loop : Node_Id; J : Node_Id; Loop_Id : Node_Id; Stmts : List_Id; Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); function Build_Counter_Assignment return Node_Id; -- Generate the following assignment: -- Counter := V'Length (1) * -- ... -- V'Length (N) - Counter; function Build_Finalization_Call return Node_Id; -- Generate a deep finalization call for an array element procedure Build_Indices; -- Generate the initialization and finalization indices used in the -- dimension loops. function Build_Initialization_Call return Node_Id; -- Generate a deep initialization call for an array element ------------------------------ -- Build_Counter_Assignment -- ------------------------------ function Build_Counter_Assignment return Node_Id is Dim : Int; Expr : Node_Id; begin -- Start from the first dimension and generate: -- V'Length (1) Dim := 1; Expr := Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_V), Attribute_Name => Name_Length, Expressions => New_List (Make_Integer_Literal (Loc, Dim))); -- Process the rest of the dimensions, generate: -- Expr * V'Length (N) Dim := Dim + 1; while Dim <= Num_Dims loop Expr := Make_Op_Multiply (Loc, Left_Opnd => Expr, Right_Opnd => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_V), Attribute_Name => Name_Length, Expressions => New_List ( Make_Integer_Literal (Loc, Dim)))); Dim := Dim + 1; end loop; -- Generate: -- Counter := Expr - Counter; return Make_Assignment_Statement (Loc, Name => New_Reference_To (Counter_Id, Loc), Expression => Make_Op_Subtract (Loc, Left_Opnd => Expr, Right_Opnd => New_Reference_To (Counter_Id, Loc))); end Build_Counter_Assignment; ----------------------------- -- Build_Finalization_Call -- ----------------------------- function Build_Finalization_Call return Node_Id is Comp_Ref : constant Node_Id := Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Name_V), Expressions => New_References_To (Final_List, Loc)); begin Set_Etype (Comp_Ref, Comp_Typ); -- Generate: -- [Deep_]Finalize (V); return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); end Build_Finalization_Call; ------------------- -- Build_Indices -- ------------------- procedure Build_Indices is begin -- Generate the following identifiers: -- Jnn - for initialization -- Fnn - for finalization for Dim in 1 .. Num_Dims loop Append_To (Index_List, Make_Defining_Identifier (Loc, New_External_Name ('J', Dim))); Append_To (Final_List, Make_Defining_Identifier (Loc, New_External_Name ('F', Dim))); end loop; end Build_Indices; ------------------------------- -- Build_Initialization_Call -- ------------------------------- function Build_Initialization_Call return Node_Id is Comp_Ref : constant Node_Id := Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Name_V), Expressions => New_References_To (Index_List, Loc)); begin Set_Etype (Comp_Ref, Comp_Typ); -- Generate: -- [Deep_]Initialize (V (J1, ..., JN)); return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); end Build_Initialization_Call; -- Start of processing for Build_Initialize_Statements begin Counter_Id := Make_Temporary (Loc, 'C'); Finalizer_Decls := New_List; Build_Indices; Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); -- Generate the block which houses the finalization call, the index -- guard and the handler which triggers Program_Error later on. -- if Counter > 0 then -- Counter := Counter - 1; -- else -- [Deep_]Finalize (V (F1, ..., FN)); -- No_Except_Propagation -- begin -- Exceptions allowed -- [Deep_]Finalize (V (F1, ..., FN)); -- exception -- when others => -- if not Raised then -- Raised := True; -- Save_Occurrence (E, Get_Current_Excep.all.all); -- end if; -- end; -- end if; if Exceptions_OK then Fin_Stmt := Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Build_Finalization_Call), Exception_Handlers => New_List ( Build_Exception_Handler (Finalizer_Data)))); else Fin_Stmt := Build_Finalization_Call; end if; -- This is the core of the loop, the dimension iterators are added -- one by one in reverse. Final_Loop := Make_If_Statement (Loc, Condition => Make_Op_Gt (Loc, Left_Opnd => New_Reference_To (Counter_Id, Loc), Right_Opnd => Make_Integer_Literal (Loc, 0)), Then_Statements => New_List ( Make_Assignment_Statement (Loc, Name => New_Reference_To (Counter_Id, Loc), Expression => Make_Op_Subtract (Loc, Left_Opnd => New_Reference_To (Counter_Id, Loc), Right_Opnd => Make_Integer_Literal (Loc, 1)))), Else_Statements => New_List (Fin_Stmt)); -- Generate all finalization loops starting from the innermost -- dimension. -- for Fnn in reverse V'Range (Dim) loop -- -- end loop; F := Last (Final_List); Dim := Num_Dims; while Present (F) and then Dim > 0 loop Loop_Id := F; Prev (F); Remove (Loop_Id); Final_Loop := Make_Loop_Statement (Loc, Iteration_Scheme => Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, Defining_Identifier => Loop_Id, Discrete_Subtype_Definition => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_V), Attribute_Name => Name_Range, Expressions => New_List ( Make_Integer_Literal (Loc, Dim))), Reverse_Present => True)), Statements => New_List (Final_Loop), End_Label => Empty); Dim := Dim - 1; end loop; -- Generate the block which contains the finalization loops, the -- declarations of the abort flag, the exception occurrence, the -- raised flag and the conditional raise. -- declare -- Abort : constant Boolean := Triggered_By_Abort; -- -- Abort : constant Boolean := False; -- no abort -- E : Exception_Occurrence; -- Raised : Boolean := False; -- begin -- Counter := -- V'Length (1) * -- ... -- V'Length (N) - Counter; -- -- if Raised and then not Abort then -- Exception handlers OK -- Raise_From_Controlled_Operation (E); -- end if; -- raise; -- Exception handlers OK -- end; Stmts := New_List (Build_Counter_Assignment, Final_Loop); if Exceptions_OK then Append_To (Stmts, Build_Raise_Statement (Finalizer_Data)); Append_To (Stmts, Make_Raise_Statement (Loc)); end if; Final_Block := Make_Block_Statement (Loc, Declarations => Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); -- Generate the block which contains the initialization call and -- the partial finalization code. -- begin -- [Deep_]Initialize (V (J1, ..., JN)); -- Counter := Counter + 1; -- exception -- when others => -- -- end; Init_Loop := Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Build_Initialization_Call), Exception_Handlers => New_List ( Make_Exception_Handler (Loc, Exception_Choices => New_List (Make_Others_Choice (Loc)), Statements => New_List (Final_Block))))); Append_To (Statements (Handled_Statement_Sequence (Init_Loop)), Make_Assignment_Statement (Loc, Name => New_Reference_To (Counter_Id, Loc), Expression => Make_Op_Add (Loc, Left_Opnd => New_Reference_To (Counter_Id, Loc), Right_Opnd => Make_Integer_Literal (Loc, 1)))); -- Generate all initialization loops starting from the innermost -- dimension. -- for Jnn in V'Range (Dim) loop -- -- end loop; J := Last (Index_List); Dim := Num_Dims; while Present (J) and then Dim > 0 loop Loop_Id := J; Prev (J); Remove (Loop_Id); Init_Loop := Make_Loop_Statement (Loc, Iteration_Scheme => Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, Defining_Identifier => Loop_Id, Discrete_Subtype_Definition => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_V), Attribute_Name => Name_Range, Expressions => New_List ( Make_Integer_Literal (Loc, Dim))))), Statements => New_List (Init_Loop), End_Label => Empty); Dim := Dim - 1; end loop; -- Generate the block which contains the counter variable and the -- initialization loops. -- declare -- Counter : Integer := 0; -- begin -- -- end; return New_List ( Make_Block_Statement (Loc, Declarations => New_List ( Make_Object_Declaration (Loc, Defining_Identifier => Counter_Id, Object_Definition => New_Reference_To (Standard_Integer, Loc), Expression => Make_Integer_Literal (Loc, 0))), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Init_Loop)))); end Build_Initialize_Statements; ----------------------- -- New_References_To -- ----------------------- function New_References_To (L : List_Id; Loc : Source_Ptr) return List_Id is Refs : constant List_Id := New_List; Id : Node_Id; begin Id := First (L); while Present (Id) loop Append_To (Refs, New_Reference_To (Id, Loc)); Next (Id); end loop; return Refs; end New_References_To; -- Start of processing for Make_Deep_Array_Body begin case Prim is when Address_Case => return Make_Finalize_Address_Stmts (Typ); when Adjust_Case | Finalize_Case => return Build_Adjust_Or_Finalize_Statements (Typ); when Initialize_Case => return Build_Initialize_Statements (Typ); end case; end Make_Deep_Array_Body; -------------------- -- Make_Deep_Proc -- -------------------- function Make_Deep_Proc (Prim : Final_Primitives; Typ : Entity_Id; Stmts : List_Id) return Entity_Id is Loc : constant Source_Ptr := Sloc (Typ); Formals : List_Id; Proc_Id : Entity_Id; begin -- Create the object formal, generate: -- V : System.Address if Prim = Address_Case then Formals := New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), Parameter_Type => New_Reference_To (RTE (RE_Address), Loc))); -- Default case else -- V : in out Typ Formals := New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), In_Present => True, Out_Present => True, Parameter_Type => New_Reference_To (Typ, Loc))); -- F : Boolean := True if Prim = Adjust_Case or else Prim = Finalize_Case then Append_To (Formals, Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_F), Parameter_Type => New_Reference_To (Standard_Boolean, Loc), Expression => New_Reference_To (Standard_True, Loc))); end if; end if; Proc_Id := Make_Defining_Identifier (Loc, Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim))); -- Generate: -- procedure Deep_Initialize / Adjust / Finalize (V : in out ) is -- begin -- -- exception -- Finalize and Adjust cases only -- raise Program_Error; -- end Deep_Initialize / Adjust / Finalize; -- or -- procedure Finalize_Address (V : System.Address) is -- begin -- -- end Finalize_Address; Discard_Node ( Make_Subprogram_Body (Loc, Specification => Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc_Id, Parameter_Specifications => Formals), Declarations => Empty_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts))); return Proc_Id; end Make_Deep_Proc; --------------------------- -- Make_Deep_Record_Body -- --------------------------- function Make_Deep_Record_Body (Prim : Final_Primitives; Typ : Entity_Id; Is_Local : Boolean := False) return List_Id is function Build_Adjust_Statements (Typ : Entity_Id) return List_Id; -- Build the statements necessary to adjust a record type. The type may -- have discriminants and contain variant parts. Generate: -- -- begin -- begin -- [Deep_]Adjust (V.Comp_1); -- exception -- when Id : others => -- if not Raised then -- Raised := True; -- Save_Occurrence (E, Get_Current_Excep.all.all); -- end if; -- end; -- . . . -- begin -- [Deep_]Adjust (V.Comp_N); -- exception -- when Id : others => -- if not Raised then -- Raised := True; -- Save_Occurrence (E, Get_Current_Excep.all.all); -- end if; -- end; -- -- begin -- Deep_Adjust (V._parent, False); -- If applicable -- exception -- when Id : others => -- if not Raised then -- Raised := True; -- Save_Occurrence (E, Get_Current_Excep.all.all); -- end if; -- end; -- -- if F then -- begin -- Adjust (V); -- If applicable -- exception -- when others => -- if not Raised then -- Raised := True; -- Save_Occurence (E, Get_Current_Excep.all.all); -- end if; -- end; -- end if; -- -- if Raised and then not Abort then -- Raise_From_Controlled_Operation (E); -- end if; -- end; function Build_Finalize_Statements (Typ : Entity_Id) return List_Id; -- Build the statements necessary to finalize a record type. The type -- may have discriminants and contain variant parts. Generate: -- -- declare -- Abort : constant Boolean := Triggered_By_Abort; -- -- Abort : constant Boolean := False; -- no abort -- E : Exception_Occurence; -- Raised : Boolean := False; -- -- begin -- if F then -- begin -- Finalize (V); -- If applicable -- exception -- when others => -- if not Raised then -- Raised := True; -- Save_Occurence (E, Get_Current_Excep.all.all); -- end if; -- end; -- end if; -- -- case Variant_1 is -- when Value_1 => -- case State_Counter_N => -- If Is_Local is enabled -- when N => . -- goto LN; . -- ... . -- when 1 => . -- goto L1; . -- when others => . -- goto L0; . -- end case; . -- -- <> -- If Is_Local is enabled -- begin -- [Deep_]Finalize (V.Comp_N); -- exception -- when others => -- if not Raised then -- Raised := True; -- Save_Occurence (E, Get_Current_Excep.all.all); -- end if; -- end; -- . . . -- <> -- begin -- [Deep_]Finalize (V.Comp_1); -- exception -- when others => -- if not Raised then -- Raised := True; -- Save_Occurence (E, Get_Current_Excep.all.all); -- end if; -- end; -- <> -- end case; -- -- case State_Counter_1 => -- If Is_Local is enabled -- when M => . -- goto LM; . -- ... -- -- begin -- Deep_Finalize (V._parent, False); -- If applicable -- exception -- when Id : others => -- if not Raised then -- Raised := True; -- Save_Occurrence (E, Get_Current_Excep.all.all); -- end if; -- end; -- -- if Raised and then not Abort then -- Raise_From_Controlled_Operation (E); -- end if; -- end; function Parent_Field_Type (Typ : Entity_Id) return Entity_Id; -- Given a derived tagged type Typ, traverse all components, find field -- _parent and return its type. procedure Preprocess_Components (Comps : Node_Id; Num_Comps : out Int; Has_POC : out Boolean); -- Examine all components in component list Comps, count all controlled -- components and determine whether at least one of them is per-object -- constrained. Component _parent is always skipped. ----------------------------- -- Build_Adjust_Statements -- ----------------------------- function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Typ); Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); Bod_Stmts : List_Id; Finalizer_Data : Finalization_Exception_Data; Finalizer_Decls : List_Id := No_List; Rec_Def : Node_Id; Var_Case : Node_Id; Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); function Process_Component_List_For_Adjust (Comps : Node_Id) return List_Id; -- Build all necessary adjust statements for a single component list --------------------------------------- -- Process_Component_List_For_Adjust -- --------------------------------------- function Process_Component_List_For_Adjust (Comps : Node_Id) return List_Id is Stmts : constant List_Id := New_List; Decl : Node_Id; Decl_Id : Entity_Id; Decl_Typ : Entity_Id; Has_POC : Boolean; Num_Comps : Int; procedure Process_Component_For_Adjust (Decl : Node_Id); -- Process the declaration of a single controlled component ---------------------------------- -- Process_Component_For_Adjust -- ---------------------------------- procedure Process_Component_For_Adjust (Decl : Node_Id) is Id : constant Entity_Id := Defining_Identifier (Decl); Typ : constant Entity_Id := Etype (Id); Adj_Stmt : Node_Id; begin -- Generate: -- [Deep_]Adjust (V.Id); -- No_Exception_Propagation -- begin -- Exception handlers allowed -- [Deep_]Adjust (V.Id); -- exception -- when others => -- if not Raised then -- Raised := True; -- Save_Occurrence (E, Get_Current_Excep.all.all); -- end if; -- end; Adj_Stmt := Make_Adjust_Call ( Obj_Ref => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_V), Selector_Name => Make_Identifier (Loc, Chars (Id))), Typ => Typ); if Exceptions_OK then Adj_Stmt := Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Adj_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler (Finalizer_Data)))); end if; Append_To (Stmts, Adj_Stmt); end Process_Component_For_Adjust; -- Start of processing for Process_Component_List_For_Adjust begin -- Perform an initial check, determine the number of controlled -- components in the current list and whether at least one of them -- is per-object constrained. Preprocess_Components (Comps, Num_Comps, Has_POC); -- The processing in this routine is done in the following order: -- 1) Regular components -- 2) Per-object constrained components -- 3) Variant parts if Num_Comps > 0 then -- Process all regular components in order of declarations Decl := First_Non_Pragma (Component_Items (Comps)); while Present (Decl) loop Decl_Id := Defining_Identifier (Decl); Decl_Typ := Etype (Decl_Id); -- Skip _parent as well as per-object constrained components if Chars (Decl_Id) /= Name_uParent and then Needs_Finalization (Decl_Typ) then if Has_Access_Constraint (Decl_Id) and then No (Expression (Decl)) then null; else Process_Component_For_Adjust (Decl); end if; end if; Next_Non_Pragma (Decl); end loop; -- Process all per-object constrained components in order of -- declarations. if Has_POC then Decl := First_Non_Pragma (Component_Items (Comps)); while Present (Decl) loop Decl_Id := Defining_Identifier (Decl); Decl_Typ := Etype (Decl_Id); -- Skip _parent if Chars (Decl_Id) /= Name_uParent and then Needs_Finalization (Decl_Typ) and then Has_Access_Constraint (Decl_Id) and then No (Expression (Decl)) then Process_Component_For_Adjust (Decl); end if; Next_Non_Pragma (Decl); end loop; end if; end if; -- Process all variants, if any Var_Case := Empty; if Present (Variant_Part (Comps)) then declare Var_Alts : constant List_Id := New_List; Var : Node_Id; begin Var := First_Non_Pragma (Variants (Variant_Part (Comps))); while Present (Var) loop -- Generate: -- when => -- Append_To (Var_Alts, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_Copy_List (Discrete_Choices (Var)), Statements => Process_Component_List_For_Adjust ( Component_List (Var)))); Next_Non_Pragma (Var); end loop; -- Generate: -- case V. is -- when => -- -- ... -- when => -- -- end case; Var_Case := Make_Case_Statement (Loc, Expression => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_V), Selector_Name => Make_Identifier (Loc, Chars => Chars (Name (Variant_Part (Comps))))), Alternatives => Var_Alts); end; end if; -- Add the variant case statement to the list of statements if Present (Var_Case) then Append_To (Stmts, Var_Case); end if; -- If the component list did not have any controlled components -- nor variants, return null. if Is_Empty_List (Stmts) then Append_To (Stmts, Make_Null_Statement (Loc)); end if; return Stmts; end Process_Component_List_For_Adjust; -- Start of processing for Build_Adjust_Statements begin Finalizer_Decls := New_List; Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); if Nkind (Typ_Def) = N_Derived_Type_Definition then Rec_Def := Record_Extension_Part (Typ_Def); else Rec_Def := Typ_Def; end if; -- Create an adjust sequence for all record components if Present (Component_List (Rec_Def)) then Bod_Stmts := Process_Component_List_For_Adjust (Component_List (Rec_Def)); end if; -- A derived record type must adjust all inherited components. This -- action poses the following problem: -- procedure Deep_Adjust (Obj : in out Parent_Typ) is -- begin -- Adjust (Obj); -- ... -- procedure Deep_Adjust (Obj : in out Derived_Typ) is -- begin -- Deep_Adjust (Obj._parent); -- ... -- Adjust (Obj); -- ... -- Adjusting the derived type will invoke Adjust of the parent and -- then that of the derived type. This is undesirable because both -- routines may modify shared components. Only the Adjust of the -- derived type should be invoked. -- To prevent this double adjustment of shared components, -- Deep_Adjust uses a flag to control the invocation of Adjust: -- procedure Deep_Adjust -- (Obj : in out Some_Type; -- Flag : Boolean := True) -- is -- begin -- if Flag then -- Adjust (Obj); -- end if; -- ... -- When Deep_Adjust is invokes for field _parent, a value of False is -- provided for the flag: -- Deep_Adjust (Obj._parent, False); if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then declare Par_Typ : constant Entity_Id := Parent_Field_Type (Typ); Adj_Stmt : Node_Id; Call : Node_Id; begin if Needs_Finalization (Par_Typ) then Call := Make_Adjust_Call (Obj_Ref => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_V), Selector_Name => Make_Identifier (Loc, Name_uParent)), Typ => Par_Typ, For_Parent => True); -- Generate: -- Deep_Adjust (V._parent, False); -- No_Except_Propagat -- begin -- Exceptions OK -- Deep_Adjust (V._parent, False); -- exception -- when Id : others => -- if not Raised then -- Raised := True; -- Save_Occurrence (E, -- Get_Current_Excep.all.all); -- end if; -- end; if Present (Call) then Adj_Stmt := Call; if Exceptions_OK then Adj_Stmt := Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Adj_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler (Finalizer_Data)))); end if; Prepend_To (Bod_Stmts, Adj_Stmt); end if; end if; end; end if; -- Adjust the object. This action must be performed last after all -- components have been adjusted. if Is_Controlled (Typ) then declare Adj_Stmt : Node_Id; Proc : Entity_Id; begin Proc := Find_Prim_Op (Typ, Name_Adjust); -- Generate: -- if F then -- Adjust (V); -- No_Exception_Propagation -- begin -- Exception handlers allowed -- Adjust (V); -- exception -- when others => -- if not Raised then -- Raised := True; -- Save_Occurrence (E, -- Get_Current_Excep.all.all); -- end if; -- end; -- end if; if Present (Proc) then Adj_Stmt := Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (Proc, Loc), Parameter_Associations => New_List ( Make_Identifier (Loc, Name_V))); if Exceptions_OK then Adj_Stmt := Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Adj_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler (Finalizer_Data)))); end if; Append_To (Bod_Stmts, Make_If_Statement (Loc, Condition => Make_Identifier (Loc, Name_F), Then_Statements => New_List (Adj_Stmt))); end if; end; end if; -- At this point either all adjustment statements have been generated -- or the type is not controlled. if Is_Empty_List (Bod_Stmts) then Append_To (Bod_Stmts, Make_Null_Statement (Loc)); return Bod_Stmts; -- Generate: -- declare -- Abort : constant Boolean := Triggered_By_Abort; -- -- Abort : constant Boolean := False; -- no abort -- E : Exception_Occurence; -- Raised : Boolean := False; -- begin -- -- if Raised and then not Abort then -- Raise_From_Controlled_Operation (E); -- end if; -- end; else if Exceptions_OK then Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data)); end if; return New_List ( Make_Block_Statement (Loc, Declarations => Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts))); end if; end Build_Adjust_Statements; ------------------------------- -- Build_Finalize_Statements -- ------------------------------- function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Typ); Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); Bod_Stmts : List_Id; Counter : Int := 0; Finalizer_Data : Finalization_Exception_Data; Finalizer_Decls : List_Id := No_List; Rec_Def : Node_Id; Var_Case : Node_Id; Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); function Process_Component_List_For_Finalize (Comps : Node_Id) return List_Id; -- Build all necessary finalization statements for a single component -- list. The statements may include a jump circuitry if flag Is_Local -- is enabled. ----------------------------------------- -- Process_Component_List_For_Finalize -- ----------------------------------------- function Process_Component_List_For_Finalize (Comps : Node_Id) return List_Id is Alts : List_Id; Counter_Id : Entity_Id; Decl : Node_Id; Decl_Id : Entity_Id; Decl_Typ : Entity_Id; Decls : List_Id; Has_POC : Boolean; Jump_Block : Node_Id; Label : Node_Id; Label_Id : Entity_Id; Num_Comps : Int; Stmts : List_Id; procedure Process_Component_For_Finalize (Decl : Node_Id; Alts : List_Id; Decls : List_Id; Stmts : List_Id); -- Process the declaration of a single controlled component. If -- flag Is_Local is enabled, create the corresponding label and -- jump circuitry. Alts is the list of case alternatives, Decls -- is the top level declaration list where labels are declared -- and Stmts is the list of finalization actions. ------------------------------------ -- Process_Component_For_Finalize -- ------------------------------------ procedure Process_Component_For_Finalize (Decl : Node_Id; Alts : List_Id; Decls : List_Id; Stmts : List_Id) is Id : constant Entity_Id := Defining_Identifier (Decl); Typ : constant Entity_Id := Etype (Id); Fin_Stmt : Node_Id; begin if Is_Local then declare Label : Node_Id; Label_Id : Entity_Id; begin -- Generate: -- LN : label; Label_Id := Make_Identifier (Loc, Chars => New_External_Name ('L', Num_Comps)); Set_Entity (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id))); Label := Make_Label (Loc, Label_Id); Append_To (Decls, Make_Implicit_Label_Declaration (Loc, Defining_Identifier => Entity (Label_Id), Label_Construct => Label)); -- Generate: -- when N => -- goto LN; Append_To (Alts, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List ( Make_Integer_Literal (Loc, Num_Comps)), Statements => New_List ( Make_Goto_Statement (Loc, Name => New_Reference_To (Entity (Label_Id), Loc))))); -- Generate: -- <> Append_To (Stmts, Label); -- Decrease the number of components to be processed. -- This action yields a new Label_Id in future calls. Num_Comps := Num_Comps - 1; end; end if; -- Generate: -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation -- begin -- Exception handlers allowed -- [Deep_]Finalize (V.Id); -- exception -- when others => -- if not Raised then -- Raised := True; -- Save_Occurrence (E, -- Get_Current_Excep.all.all); -- end if; -- end; Fin_Stmt := Make_Final_Call (Obj_Ref => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_V), Selector_Name => Make_Identifier (Loc, Chars (Id))), Typ => Typ); if not Restriction_Active (No_Exception_Propagation) then Fin_Stmt := Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Fin_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler (Finalizer_Data)))); end if; Append_To (Stmts, Fin_Stmt); end Process_Component_For_Finalize; -- Start of processing for Process_Component_List_For_Finalize begin -- Perform an initial check, look for controlled and per-object -- constrained components. Preprocess_Components (Comps, Num_Comps, Has_POC); -- Create a state counter to service the current component list. -- This step is performed before the variants are inspected in -- order to generate the same state counter names as those from -- Build_Initialize_Statements. if Num_Comps > 0 and then Is_Local then Counter := Counter + 1; Counter_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name ('C', Counter)); end if; -- Process the component in the following order: -- 1) Variants -- 2) Per-object constrained components -- 3) Regular components -- Start with the variant parts Var_Case := Empty; if Present (Variant_Part (Comps)) then declare Var_Alts : constant List_Id := New_List; Var : Node_Id; begin Var := First_Non_Pragma (Variants (Variant_Part (Comps))); while Present (Var) loop -- Generate: -- when => -- Append_To (Var_Alts, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_Copy_List (Discrete_Choices (Var)), Statements => Process_Component_List_For_Finalize ( Component_List (Var)))); Next_Non_Pragma (Var); end loop; -- Generate: -- case V. is -- when => -- -- ... -- when => -- -- end case; Var_Case := Make_Case_Statement (Loc, Expression => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_V), Selector_Name => Make_Identifier (Loc, Chars => Chars (Name (Variant_Part (Comps))))), Alternatives => Var_Alts); end; end if; -- The current component list does not have a single controlled -- component, however it may contain variants. Return the case -- statement for the variants or nothing. if Num_Comps = 0 then if Present (Var_Case) then return New_List (Var_Case); else return New_List (Make_Null_Statement (Loc)); end if; end if; -- Prepare all lists Alts := New_List; Decls := New_List; Stmts := New_List; -- Process all per-object constrained components in reverse order if Has_POC then Decl := Last_Non_Pragma (Component_Items (Comps)); while Present (Decl) loop Decl_Id := Defining_Identifier (Decl); Decl_Typ := Etype (Decl_Id); -- Skip _parent if Chars (Decl_Id) /= Name_uParent and then Needs_Finalization (Decl_Typ) and then Has_Access_Constraint (Decl_Id) and then No (Expression (Decl)) then Process_Component_For_Finalize (Decl, Alts, Decls, Stmts); end if; Prev_Non_Pragma (Decl); end loop; end if; -- Process the rest of the components in reverse order Decl := Last_Non_Pragma (Component_Items (Comps)); while Present (Decl) loop Decl_Id := Defining_Identifier (Decl); Decl_Typ := Etype (Decl_Id); -- Skip _parent if Chars (Decl_Id) /= Name_uParent and then Needs_Finalization (Decl_Typ) then -- Skip per-object constrained components since they were -- handled in the above step. if Has_Access_Constraint (Decl_Id) and then No (Expression (Decl)) then null; else Process_Component_For_Finalize (Decl, Alts, Decls, Stmts); end if; end if; Prev_Non_Pragma (Decl); end loop; -- Generate: -- declare -- LN : label; -- If Is_Local is enabled -- ... . -- L0 : label; . -- begin . -- case CounterX is . -- when N => . -- goto LN; . -- ... . -- when 1 => . -- goto L1; . -- when others => . -- goto L0; . -- end case; . -- <> -- If Is_Local is enabled -- begin -- [Deep_]Finalize (V.CompY); -- exception -- when Id : others => -- if not Raised then -- Raised := True; -- Save_Occurrence (E, -- Get_Current_Excep.all.all); -- end if; -- end; -- ... -- <> -- If Is_Local is enabled -- end; if Is_Local then -- Add the declaration of default jump location L0, its -- corresponding alternative and its place in the statements. Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0)); Set_Entity (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id))); Label := Make_Label (Loc, Label_Id); Append_To (Decls, -- declaration Make_Implicit_Label_Declaration (Loc, Defining_Identifier => Entity (Label_Id), Label_Construct => Label)); Append_To (Alts, -- alternative Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List ( Make_Others_Choice (Loc)), Statements => New_List ( Make_Goto_Statement (Loc, Name => New_Reference_To (Entity (Label_Id), Loc))))); Append_To (Stmts, Label); -- statement -- Create the jump block Prepend_To (Stmts, Make_Case_Statement (Loc, Expression => Make_Identifier (Loc, Chars (Counter_Id)), Alternatives => Alts)); end if; Jump_Block := Make_Block_Statement (Loc, Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Stmts)); if Present (Var_Case) then return New_List (Var_Case, Jump_Block); else return New_List (Jump_Block); end if; end Process_Component_List_For_Finalize; -- Start of processing for Build_Finalize_Statements begin Finalizer_Decls := New_List; Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); if Nkind (Typ_Def) = N_Derived_Type_Definition then Rec_Def := Record_Extension_Part (Typ_Def); else Rec_Def := Typ_Def; end if; -- Create a finalization sequence for all record components if Present (Component_List (Rec_Def)) then Bod_Stmts := Process_Component_List_For_Finalize (Component_List (Rec_Def)); end if; -- A derived record type must finalize all inherited components. This -- action poses the following problem: -- procedure Deep_Finalize (Obj : in out Parent_Typ) is -- begin -- Finalize (Obj); -- ... -- procedure Deep_Finalize (Obj : in out Derived_Typ) is -- begin -- Deep_Finalize (Obj._parent); -- ... -- Finalize (Obj); -- ... -- Finalizing the derived type will invoke Finalize of the parent and -- then that of the derived type. This is undesirable because both -- routines may modify shared components. Only the Finalize of the -- derived type should be invoked. -- To prevent this double adjustment of shared components, -- Deep_Finalize uses a flag to control the invocation of Finalize: -- procedure Deep_Finalize -- (Obj : in out Some_Type; -- Flag : Boolean := True) -- is -- begin -- if Flag then -- Finalize (Obj); -- end if; -- ... -- When Deep_Finalize is invokes for field _parent, a value of False -- is provided for the flag: -- Deep_Finalize (Obj._parent, False); if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then declare Par_Typ : constant Entity_Id := Parent_Field_Type (Typ); Call : Node_Id; Fin_Stmt : Node_Id; begin if Needs_Finalization (Par_Typ) then Call := Make_Final_Call (Obj_Ref => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_V), Selector_Name => Make_Identifier (Loc, Name_uParent)), Typ => Par_Typ, For_Parent => True); -- Generate: -- Deep_Finalize (V._parent, False); -- No_Except_Propag -- begin -- Exceptions OK -- Deep_Finalize (V._parent, False); -- exception -- when Id : others => -- if not Raised then -- Raised := True; -- Save_Occurrence (E, -- Get_Current_Excep.all.all); -- end if; -- end; if Present (Call) then Fin_Stmt := Call; if Exceptions_OK then Fin_Stmt := Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Fin_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler (Finalizer_Data)))); end if; Append_To (Bod_Stmts, Fin_Stmt); end if; end if; end; end if; -- Finalize the object. This action must be performed first before -- all components have been finalized. if Is_Controlled (Typ) and then not Is_Local then declare Fin_Stmt : Node_Id; Proc : Entity_Id; begin Proc := Find_Prim_Op (Typ, Name_Finalize); -- Generate: -- if F then -- Finalize (V); -- No_Exception_Propagation -- begin -- Finalize (V); -- exception -- when others => -- if not Raised then -- Raised := True; -- Save_Occurrence (E, -- Get_Current_Excep.all.all); -- end if; -- end; -- end if; if Present (Proc) then Fin_Stmt := Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (Proc, Loc), Parameter_Associations => New_List ( Make_Identifier (Loc, Name_V))); if Exceptions_OK then Fin_Stmt := Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Fin_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler (Finalizer_Data)))); end if; Prepend_To (Bod_Stmts, Make_If_Statement (Loc, Condition => Make_Identifier (Loc, Name_F), Then_Statements => New_List (Fin_Stmt))); end if; end; end if; -- At this point either all finalization statements have been -- generated or the type is not controlled. if No (Bod_Stmts) then return New_List (Make_Null_Statement (Loc)); -- Generate: -- declare -- Abort : constant Boolean := Triggered_By_Abort; -- -- Abort : constant Boolean := False; -- no abort -- E : Exception_Occurence; -- Raised : Boolean := False; -- begin -- -- if Raised and then not Abort then -- Raise_From_Controlled_Operation (E); -- end if; -- end; else if Exceptions_OK then Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data)); end if; return New_List ( Make_Block_Statement (Loc, Declarations => Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts))); end if; end Build_Finalize_Statements; ----------------------- -- Parent_Field_Type -- ----------------------- function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is Field : Entity_Id; begin Field := First_Entity (Typ); while Present (Field) loop if Chars (Field) = Name_uParent then return Etype (Field); end if; Next_Entity (Field); end loop; -- A derived tagged type should always have a parent field raise Program_Error; end Parent_Field_Type; --------------------------- -- Preprocess_Components -- --------------------------- procedure Preprocess_Components (Comps : Node_Id; Num_Comps : out Int; Has_POC : out Boolean) is Decl : Node_Id; Id : Entity_Id; Typ : Entity_Id; begin Num_Comps := 0; Has_POC := False; Decl := First_Non_Pragma (Component_Items (Comps)); while Present (Decl) loop Id := Defining_Identifier (Decl); Typ := Etype (Id); -- Skip field _parent if Chars (Id) /= Name_uParent and then Needs_Finalization (Typ) then Num_Comps := Num_Comps + 1; if Has_Access_Constraint (Id) and then No (Expression (Decl)) then Has_POC := True; end if; end if; Next_Non_Pragma (Decl); end loop; end Preprocess_Components; -- Start of processing for Make_Deep_Record_Body begin case Prim is when Address_Case => return Make_Finalize_Address_Stmts (Typ); when Adjust_Case => return Build_Adjust_Statements (Typ); when Finalize_Case => return Build_Finalize_Statements (Typ); when Initialize_Case => declare Loc : constant Source_Ptr := Sloc (Typ); begin if Is_Controlled (Typ) then return New_List ( Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (Find_Prim_Op (Typ, Name_Of (Prim)), Loc), Parameter_Associations => New_List ( Make_Identifier (Loc, Name_V)))); else return Empty_List; end if; end; end case; end Make_Deep_Record_Body; ---------------------- -- Make_Final_Call -- ---------------------- function Make_Final_Call (Obj_Ref : Node_Id; Typ : Entity_Id; 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; begin -- Recover the proper type which contains [Deep_]Finalize 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 Present (Full_View (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; Utyp := Underlying_Type (Base_Type (Utyp)); Set_Assignment_OK (Ref); -- Deal with non-tagged derivation of private views. If the parent type -- is a protected type, Deep_Finalize is found on the corresponding -- record of the ancestor. if Is_Untagged_Derivation (Typ) then if Is_Protected_Type (Typ) then Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); else Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); if Is_Protected_Type (Utyp) then Utyp := Corresponding_Record_Type (Utyp); end if; end if; Ref := Unchecked_Convert_To (Utyp, Ref); Set_Assignment_OK (Ref); end if; -- Deal with derived private types which do not inherit primitives from -- their parents. In this case, [Deep_]Finalize can be found in the full -- view of the parent type. if Is_Tagged_Type (Utyp) and then Is_Derived_Type (Utyp) and then Is_Empty_Elmt_List (Primitive_Operations (Utyp)) and then Is_Private_Type (Etype (Utyp)) and then Present (Full_View (Etype (Utyp))) then Utyp := Full_View (Etype (Utyp)); Ref := Unchecked_Convert_To (Utyp, Ref); Set_Assignment_OK (Ref); end if; -- When dealing with the completion of a private type, use the base type -- instead. if Utyp /= Base_Type (Utyp) then pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp)); Utyp := Base_Type (Utyp); Ref := Unchecked_Convert_To (Utyp, Ref); Set_Assignment_OK (Ref); end if; -- Select the appropriate version of Finalize if For_Parent then if Has_Controlled_Component (Utyp) then Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize); end if; -- 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 Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize); else Fin_Id := TSS (Utyp, TSS_Deep_Finalize); end if; -- 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 raise Program_Error; end if; if Present (Fin_Id) then -- When finalizing a class-wide object, do not convert to the root -- type in order to produce a dispatching call. if Is_Class_Wide_Type (Typ) then null; -- Ensure that a finalization routine is at least decorated in order -- to inspect the object parameter. elsif Analyzed (Fin_Id) or else Ekind (Fin_Id) = E_Procedure then -- In certain cases, such as the creation of Stream_Read, the -- visible entity of the type is its full view. Since Stream_Read -- will have to create an object of type Typ, the local object -- will be finalzed by the scope finalizer generated later on. The -- object parameter of Deep_Finalize will always use the private -- view of the type. To avoid such a clash between a private and a -- full view, perform an unchecked conversion of the object -- reference to the private view. declare Formal_Typ : constant Entity_Id := Etype (First_Formal (Fin_Id)); begin if Is_Private_Type (Formal_Typ) and then Present (Full_View (Formal_Typ)) and then Full_View (Formal_Typ) = Utyp then Ref := Unchecked_Convert_To (Formal_Typ, Ref); end if; end; Ref := Convert_View (Fin_Id, Ref); end if; return Make_Call (Loc, Fin_Id, New_Copy_Tree (Ref), For_Parent); else return Empty; end if; end Make_Final_Call; -------------------------------- -- Make_Finalize_Address_Body -- -------------------------------- 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. 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) and then Ekind (Root_Type (Typ)) = E_Record_Subtype and then not Comes_From_Source (Root_Type (Typ))) then return; end if; Proc_Id := Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Finalize_Address)); -- Generate: -- procedure 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; 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, 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, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts))); Set_TSS (Typ, Proc_Id); end Make_Finalize_Address_Body; --------------------------------- -- Make_Finalize_Address_Stmts -- --------------------------------- function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Typ); Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'P'); Decls : List_Id; Desg_Typ : Entity_Id; Obj_Expr : Node_Id; begin if Is_Array_Type (Typ) then if Is_Constrained (First_Subtype (Typ)) then Desg_Typ := First_Subtype (Typ); else Desg_Typ := Base_Type (Typ); end if; -- Class-wide types of constrained root types elsif Is_Class_Wide_Type (Typ) and then Has_Discriminants (Root_Type (Typ)) and then not Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ))) then declare Parent_Typ : Entity_Id; begin -- Climb the parent type chain looking for a non-constrained type Parent_Typ := Root_Type (Typ); while Parent_Typ /= Etype (Parent_Typ) and then Has_Discriminants (Parent_Typ) and then not Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ)) loop Parent_Typ := Etype (Parent_Typ); end loop; -- Handle views created for tagged types with unknown -- discriminants. if Is_Underlying_Record_View (Parent_Typ) then Parent_Typ := Underlying_Record_View (Parent_Typ); end if; Desg_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ)); end; -- General case else Desg_Typ := Typ; end if; -- Generate: -- type Ptr_Typ is access all Typ; -- for Ptr_Typ'Storage_Size use 0; Decls := New_List ( Make_Full_Type_Declaration (Loc, Defining_Identifier => Ptr_Typ, Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, Subtype_Indication => New_Reference_To (Desg_Typ, Loc))), Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (Ptr_Typ, Loc), Chars => Name_Storage_Size, Expression => Make_Integer_Literal (Loc, 0))); Obj_Expr := Make_Identifier (Loc, Name_V); -- Unconstrained arrays require special processing in order to retrieve -- the elements. To achieve this, we have to skip the dope vector which -- lays in front of the elements and then use a thin pointer to perform -- the address-to-access conversion. if Is_Array_Type (Typ) and then not Is_Constrained (First_Subtype (Typ)) then declare Dope_Id : Entity_Id; begin -- Ensure that Ptr_Typ a thin pointer, generate: -- for Ptr_Typ'Size use System.Address'Size; Append_To (Decls, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (Ptr_Typ, Loc), Chars => Name_Size, Expression => Make_Integer_Literal (Loc, System_Address_Size))); -- Generate: -- Dnn : constant Storage_Offset := -- Desg_Typ'Descriptor_Size / Storage_Unit; Dope_Id := Make_Temporary (Loc, 'D'); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Dope_Id, Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_Storage_Offset), Loc), Expression => Make_Op_Divide (Loc, Left_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Desg_Typ, Loc), Attribute_Name => Name_Descriptor_Size), Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit)))); -- Shift the address from the start of the dope vector to the -- start of the elements: -- -- V + Dnn -- -- Note that this is done through a wrapper routine since RTSfind -- cannot retrieve operations with string names of the form "+". Obj_Expr := Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Add_Offset_To_Address), Loc), Parameter_Associations => New_List ( Obj_Expr, New_Reference_To (Dope_Id, Loc))); end; end if; -- Create the block and the finalization call return New_List ( Make_Block_Statement (Loc, Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Final_Call ( Obj_Ref => Make_Explicit_Dereference (Loc, Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)), Typ => Desg_Typ))))); end Make_Finalize_Address_Stmts; ------------------------------------- -- Make_Handler_For_Ctrl_Operation -- ------------------------------------- -- Generate: -- when E : others => -- Raise_From_Controlled_Operation (E); -- or: -- when others => -- raise Program_Error [finalize raised exception]; -- depending on whether Raise_From_Controlled_Operation is available function Make_Handler_For_Ctrl_Operation (Loc : Source_Ptr) return Node_Id is E_Occ : Entity_Id; -- Choice parameter (for the first case above) Raise_Node : Node_Id; -- Procedure call or raise statement begin -- Standard run-time, .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 RTE_Available (RE_Raise_From_Controlled_Operation) then E_Occ := Make_Defining_Identifier (Loc, Name_E); Raise_Node := Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Raise_From_Controlled_Operation), Loc), Parameter_Associations => New_List ( New_Reference_To (E_Occ, Loc))); -- Restricted run-time: exception messages are not supported else E_Occ := Empty; Raise_Node := Make_Raise_Program_Error (Loc, Reason => PE_Finalize_Raised_Exception); end if; return Make_Implicit_Exception_Handler (Loc, Exception_Choices => New_List (Make_Others_Choice (Loc)), Choice_Parameter => E_Occ, Statements => New_List (Raise_Node)); end Make_Handler_For_Ctrl_Operation; -------------------- -- Make_Init_Call -- -------------------- function Make_Init_Call (Obj_Ref : Node_Id; Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Obj_Ref); Is_Conc : Boolean; Proc : Entity_Id; Ref : Node_Id; Utyp : Entity_Id; begin -- Deal with the type and object reference. Depending on the context, an -- object reference may need several conversions. if Is_Concurrent_Type (Typ) then Is_Conc := True; Utyp := Corresponding_Record_Type (Typ); Ref := Convert_Concurrent (Obj_Ref, Typ); elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) and then Is_Concurrent_Type (Underlying_Type (Typ)) then Is_Conc := True; Utyp := Corresponding_Record_Type (Underlying_Type (Typ)); Ref := Convert_Concurrent (Obj_Ref, Underlying_Type (Typ)); else Is_Conc := False; Utyp := Typ; Ref := Obj_Ref; end if; Set_Assignment_OK (Ref); Utyp := Underlying_Type (Base_Type (Utyp)); -- Deal with non-tagged derivation of private views if Is_Untagged_Derivation (Typ) and then not Is_Conc then Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); Ref := Unchecked_Convert_To (Utyp, Ref); -- The following is to prevent problems with UC see 1.156 RH ??? Set_Assignment_OK (Ref); end if; -- If the underlying_type is a subtype, then we are dealing with the -- completion of a private type. We need to access the base type and -- generate a conversion to it. if Utyp /= Base_Type (Utyp) then pragma Assert (Is_Private_Type (Typ)); Utyp := Base_Type (Utyp); Ref := Unchecked_Convert_To (Utyp, Ref); end if; -- Select the appropriate version of initialize if Has_Controlled_Component (Utyp) then Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case)); else Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case)); Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref); end if; -- The object reference may need another conversion depending on the -- type of the formal and that of the actual. Ref := Convert_View (Proc, Ref); -- Generate: -- [Deep_]Initialize (Ref); return Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (Proc, Loc), Parameter_Associations => New_List (Ref)); end Make_Init_Call; ------------------------------ -- Make_Local_Deep_Finalize -- ------------------------------ function Make_Local_Deep_Finalize (Typ : Entity_Id; Nam : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); Formals : List_Id; begin Formals := New_List ( -- V : in out Typ Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), In_Present => True, Out_Present => True, Parameter_Type => New_Reference_To (Typ, Loc)), -- F : Boolean := True Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_F), Parameter_Type => New_Reference_To (Standard_Boolean, Loc), Expression => New_Reference_To (Standard_True, Loc))); -- Add the necessary number of counters to represent the initialization -- state of an object. return Make_Subprogram_Body (Loc, Specification => Make_Procedure_Specification (Loc, Defining_Unit_Name => Nam, Parameter_Specifications => Formals), Declarations => No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True))); end Make_Local_Deep_Finalize; ------------------------------------ -- Make_Set_Finalize_Address_Call -- ------------------------------------ function Make_Set_Finalize_Address_Call (Loc : Source_Ptr; Typ : Entity_Id; Ptr_Typ : Entity_Id) return Node_Id is Desig_Typ : constant Entity_Id := Available_View (Designated_Type (Ptr_Typ)); Fin_Mas_Id : constant Entity_Id := Finalization_Master (Ptr_Typ); Fin_Mas_Ref : Node_Id; Utyp : Entity_Id; begin -- If the context is a class-wide allocator, we use the class-wide type -- to obtain the proper Finalize_Address routine. if Is_Class_Wide_Type (Desig_Typ) then Utyp := Desig_Typ; else Utyp := Typ; if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then Utyp := Full_View (Utyp); end if; if Is_Concurrent_Type (Utyp) then Utyp := Corresponding_Record_Type (Utyp); end if; end if; Utyp := Underlying_Type (Base_Type (Utyp)); -- Deal with non-tagged derivation of private views. If the parent is -- now known to be protected, the finalization routine is the one -- defined on the corresponding record of the ancestor (corresponding -- records do not automatically inherit operations, but maybe they -- should???) if Is_Untagged_Derivation (Typ) then if Is_Protected_Type (Typ) then Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); else Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); if Is_Protected_Type (Utyp) then Utyp := Corresponding_Record_Type (Utyp); end if; end if; end if; -- If the underlying_type is a subtype, we are dealing with the -- completion of a private type. We need to access the base type and -- generate a conversion to it. if Utyp /= Base_Type (Utyp) then pragma Assert (Is_Private_Type (Typ)); Utyp := Base_Type (Utyp); end if; Fin_Mas_Ref := New_Occurrence_Of (Fin_Mas_Id, Loc); -- If the call is from a build-in-place function, the Master parameter -- is actually a pointer. Dereference it for the call. if Is_Access_Type (Etype (Fin_Mas_Id)) then Fin_Mas_Ref := Make_Explicit_Dereference (Loc, Fin_Mas_Ref); end if; -- Generate: -- Set_Finalize_Address (FM, FD'Unrestricted_Access); return Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Set_Finalize_Address), Loc), Parameter_Associations => New_List ( Fin_Mas_Ref, Make_Attribute_Reference (Loc, Prefix => New_Reference_To (TSS (Utyp, TSS_Finalize_Address), Loc), Attribute_Name => Name_Unrestricted_Access))); end Make_Set_Finalize_Address_Call; -------------------------- -- Make_Transient_Block -- -------------------------- function Make_Transient_Block (Loc : Source_Ptr; Action : Node_Id; Par : Node_Id) return Node_Id is Decls : constant List_Id := New_List; Instrs : constant List_Id := New_List (Action); Block : Node_Id; Insert : Node_Id; begin -- Case where only secondary stack use is involved if VM_Target = No_VM and then Uses_Sec_Stack (Current_Scope) and then Nkind (Action) /= N_Simple_Return_Statement and then Nkind (Par) /= N_Exception_Handler then declare S : Entity_Id; begin S := Scope (Current_Scope); loop -- At the outer level, no need to release the sec stack if S = Standard_Standard then Set_Uses_Sec_Stack (Current_Scope, False); exit; -- In a function, only release the sec stack if the function -- does not return on the sec stack otherwise the result may -- be lost. The caller is responsible for releasing. elsif Ekind (S) = E_Function then Set_Uses_Sec_Stack (Current_Scope, False); if not Requires_Transient_Scope (Etype (S)) then Set_Uses_Sec_Stack (S, True); Check_Restriction (No_Secondary_Stack, Action); end if; exit; -- In a loop or entry we should install a block encompassing -- all the construct. For now just release right away. elsif Ekind_In (S, E_Entry, E_Loop) then exit; -- In a procedure or a block, we release on exit of the -- procedure or block. ??? memory leak can be created by -- recursive calls. elsif Ekind_In (S, E_Block, E_Procedure) then Set_Uses_Sec_Stack (S, True); Check_Restriction (No_Secondary_Stack, Action); Set_Uses_Sec_Stack (Current_Scope, False); exit; else S := Scope (S); end if; end loop; end; end if; -- Create the transient block. Set the parent now since the block itself -- is not part of the tree. Block := Make_Block_Statement (Loc, Identifier => New_Reference_To (Current_Scope, Loc), Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs), Has_Created_Identifier => True); Set_Parent (Block, Par); -- Insert actions stuck in the transient scopes as well as all freezing -- nodes needed by those actions. Insert_Actions_In_Scope_Around (Action); Insert := Prev (Action); if Present (Insert) then Freeze_All (First_Entity (Current_Scope), Insert); end if; -- When the transient scope was established, we pushed the entry for the -- transient scope onto the scope stack, so that the scope was active -- for the installation of finalizable entities etc. Now we must remove -- this entry, since we have constructed a proper block. Pop_Scope; return Block; end Make_Transient_Block; ------------------------ -- Node_To_Be_Wrapped -- ------------------------ function Node_To_Be_Wrapped return Node_Id is begin return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped; end Node_To_Be_Wrapped; ---------------------------- -- Set_Node_To_Be_Wrapped -- ---------------------------- procedure Set_Node_To_Be_Wrapped (N : Node_Id) is begin Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N; end Set_Node_To_Be_Wrapped; ---------------------------------- -- Store_After_Actions_In_Scope -- ---------------------------------- procedure Store_After_Actions_In_Scope (L : List_Id) is SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); begin if Present (SE.Actions_To_Be_Wrapped_After) then Insert_List_Before_And_Analyze ( First (SE.Actions_To_Be_Wrapped_After), L); else SE.Actions_To_Be_Wrapped_After := L; if Is_List_Member (SE.Node_To_Be_Wrapped) then Set_Parent (L, Parent (SE.Node_To_Be_Wrapped)); else Set_Parent (L, SE.Node_To_Be_Wrapped); end if; Analyze_List (L); end if; end Store_After_Actions_In_Scope; ----------------------------------- -- Store_Before_Actions_In_Scope -- ----------------------------------- procedure Store_Before_Actions_In_Scope (L : List_Id) is SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); begin if Present (SE.Actions_To_Be_Wrapped_Before) then Insert_List_After_And_Analyze ( Last (SE.Actions_To_Be_Wrapped_Before), L); else SE.Actions_To_Be_Wrapped_Before := L; if Is_List_Member (SE.Node_To_Be_Wrapped) then Set_Parent (L, Parent (SE.Node_To_Be_Wrapped)); else Set_Parent (L, SE.Node_To_Be_Wrapped); end if; Analyze_List (L); end if; end Store_Before_Actions_In_Scope; -------------------------------- -- Wrap_Transient_Declaration -- -------------------------------- -- If a transient scope has been established during the processing of the -- Expression of an Object_Declaration, it is not possible to wrap the -- declaration into a transient block as usual case, otherwise the object -- would be itself declared in the wrong scope. Therefore, all entities (if -- any) defined in the transient block are moved to the proper enclosing -- scope, furthermore, if they are controlled variables they are finalized -- right after the declaration. The finalization list of the transient -- scope is defined as a renaming of the enclosing one so during their -- initialization they will be attached to the proper finalization list. -- For instance, the following declaration : -- X : Typ := F (G (A), G (B)); -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2) -- is expanded into : -- X : Typ := [ complex Expression-Action ]; -- [Deep_]Finalize (_v1); -- [Deep_]Finalize (_v2); procedure Wrap_Transient_Declaration (N : Node_Id) is Encl_S : Entity_Id; S : Entity_Id; Uses_SS : Boolean; begin S := Current_Scope; Encl_S := Scope (S); -- Insert Actions kept in the Scope stack Insert_Actions_In_Scope_Around (N); -- If the declaration is consuming some secondary stack, mark the -- enclosing scope appropriately. Uses_SS := Uses_Sec_Stack (S); Pop_Scope; -- Put the local entities back in the enclosing scope, and set the -- Is_Public flag appropriately. Transfer_Entities (S, Encl_S); -- Mark the enclosing dynamic scope so that the sec stack will be -- released upon its exit unless this is a function that returns on -- the sec stack in which case this will be done by the caller. if VM_Target = No_VM and then Uses_SS then S := Enclosing_Dynamic_Scope (S); if Ekind (S) = E_Function and then Requires_Transient_Scope (Etype (S)) then null; else Set_Uses_Sec_Stack (S); Check_Restriction (No_Secondary_Stack, N); end if; end if; end Wrap_Transient_Declaration; ------------------------------- -- Wrap_Transient_Expression -- ------------------------------- procedure Wrap_Transient_Expression (N : Node_Id) is Expr : constant Node_Id := Relocate_Node (N); Loc : constant Source_Ptr := Sloc (N); Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N); Typ : constant Entity_Id := Etype (N); begin -- Generate: -- Temp : Typ; -- declare -- M : constant Mark_Id := SS_Mark; -- procedure Finalizer is ... (See Build_Finalizer) -- begin -- Temp := ; -- -- at end -- Finalizer; -- end; Insert_Actions (N, New_List ( Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => New_Reference_To (Typ, Loc)), Make_Transient_Block (Loc, Action => Make_Assignment_Statement (Loc, Name => New_Reference_To (Temp, Loc), Expression => Expr), Par => Parent (N)))); Rewrite (N, New_Reference_To (Temp, Loc)); Analyze_And_Resolve (N, Typ); end Wrap_Transient_Expression; ------------------------------ -- Wrap_Transient_Statement -- ------------------------------ procedure Wrap_Transient_Statement (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); New_Stmt : constant Node_Id := Relocate_Node (N); begin -- Generate: -- declare -- M : constant Mark_Id := SS_Mark; -- procedure Finalizer is ... (See Build_Finalizer) -- -- begin -- ; -- -- at end -- Finalizer; -- end; Rewrite (N, Make_Transient_Block (Loc, Action => New_Stmt, Par => Parent (N))); -- With the scope stack back to normal, we can call analyze on the -- resulting block. At this point, the transient scope is being -- treated like a perfectly normal scope, so there is nothing -- special about it. -- Note: Wrap_Transient_Statement is called with the node already -- analyzed (i.e. Analyzed (N) is True). This is important, since -- otherwise we would get a recursive processing of the node when -- we do this Analyze call. Analyze (N); end Wrap_Transient_Statement; end Exp_Ch7;