diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/exp_ch7.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/exp_ch7.adb | 7917 |
1 files changed, 0 insertions, 7917 deletions
diff --git a/gcc-4.8/gcc/ada/exp_ch7.adb b/gcc-4.8/gcc/ada/exp_ch7.adb deleted file mode 100644 index 72892828b..000000000 --- a/gcc-4.8/gcc/ada/exp_ch7.adb +++ /dev/null @@ -1,7917 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 - -- ??? which entire comment? - - ----------------------------- - -- 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); - -- <save W's final pointers> - -- W := Z; - -- <restore W's final pointers> - -- 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<counter value> : 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 - -- <call to Prev_At_End> -- Added if exists - -- <cleanup statements> -- Added if Acts_As_Clean - -- <jump block> -- Added if Has_Ctrl_Objs - -- <finalization statements> -- Added if Has_Ctrl_Objs - -- <stack release> -- 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 <counter value> => - -- goto L<counter value>; - - 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 "__<name-of-Id>" 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 - -- <controlled objects> - -- 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: - -- <<L0>> - - 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; - -- <or> - -- 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 - -- <call to Prev_At_End> -- Added if exists - -- <cleanup statements> -- Added if Acts_As_Clean - -- <jump block> -- Added if Has_Ctrl_Objs - -- <finalization statements> -- Added if Has_Ctrl_Objs - -- <stack release> -- Added if Mark_Id exists - -- Abort_Undefer; -- Added if abort is allowed - -- <exception propagation> -- 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 - -- <objects and possibly statements> - -- procedure Fin_Id is ... -- Body - -- <statements> - -- 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 - -- <Decls> - -- 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 <Cond> then - -- <Free_Blk> - -- 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 := <value>; - - 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<counter> : 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 <counter> => - -- goto L<counter>; - - 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: - -- - -- <<L<counter>>> - - 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; - -- <Counter> := ...; - - -- do - -- Ctrl_Trans : [access [all]] Obj_Typ := ...; - -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer - -- <or> - -- 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 - -- <object finalization statements> - -- 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 - -- <object finalization statements> - -- 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 (<Typ>P); - - Append_To (Tagged_Type_Stmts, - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Unregister_Tag), Loc), - Parameter_Associations => New_List ( - New_Reference_To (DT_Ptr, Loc)))); - end Process_Tagged_Type_Declaration; - - -- Start of processing for Build_Finalizer - - begin - Fin_Id := Empty; - - -- 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 := <A_Expr>; - - 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 - -- <or> - -- 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); - -- <or> - -- 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 (" <Transient>"); - 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] <Desig_Typ>; - - 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); - -- <or> - -- 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; - -- <or> - -- 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; - -- <or> - -- 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: - - -- <adjust or finalize call>; -- No_Exception_Propagation - - -- begin -- Exception handlers allowed - -- <adjust or finalize call> - - -- 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 - -- <core 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; - -- <or> - -- Abort : constant Boolean := False; -- no abort - - -- E : Exception_Occurrence; - -- Raised : Boolean := False; - - -- begin - -- <core loop> - - -- 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 - -- <final 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; - -- <or> - -- Abort : constant Boolean := False; -- no abort - - -- E : Exception_Occurrence; - -- Raised : Boolean := False; - - -- begin - -- Counter := - -- V'Length (1) * - -- ... - -- V'Length (N) - Counter; - - -- <final loop> - - -- 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 => - -- <finalization code> - -- 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 - -- <init 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 - -- <init loop> - -- 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 <typ>) is - -- begin - -- <stmts> - -- exception -- Finalize and Adjust cases only - -- raise Program_Error; - -- end Deep_Initialize / Adjust / Finalize; - - -- or - - -- procedure Finalize_Address (V : System.Address) is - -- begin - -- <stmts> - -- 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; - -- <or> - -- 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; . - -- - -- <<LN>> -- 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; - -- . . . - -- <<L1>> - -- 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; - -- <<L0>> - -- 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 <discrete choices> => - -- <adjust statements> - - 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.<discriminant> is - -- when <discrete choices 1> => - -- <adjust statements 1> - -- ... - -- when <discrete choices N> => - -- <adjust statements N> - -- 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; - -- <or> - -- Abort : constant Boolean := False; -- no abort - - -- E : Exception_Occurence; - -- Raised : Boolean := False; - - -- begin - -- <adjust statements> - - -- 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: - -- <<LN>> - - 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 <discrete choices> => - -- <finalize statements> - - 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.<discriminant> is - -- when <discrete choices 1> => - -- <finalize statements 1> - -- ... - -- when <discrete choices N> => - -- <finalize statements N> - -- 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; . - - -- <<LN>> -- 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; - -- ... - -- <<L0>> -- 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; - -- <or> - -- Abort : constant Boolean := False; -- no abort - - -- E : Exception_Occurence; - -- Raised : Boolean := False; - - -- begin - -- <finalize statements> - - -- 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 <Typ>FD (V : System.Address) is - -- begin - -- null; -- for tasks - - -- declare -- for all other types - -- type Pnn is access all Typ; - -- for Pnn'Storage_Size use 0; - -- begin - -- [Deep_]Finalize (Pnn (V).all); - -- end; - -- end TypFD; - - 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 (<Ptr_Typ>FM, <Utyp>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 := <Expr>; - -- - -- 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 - -- <New_Stmt>; - -- - -- 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; |