| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P _ C H 7 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, 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 Contracts; use Contracts; |
| with Debug; use Debug; |
| with Einfo; use Einfo; |
| with Einfo.Entities; use Einfo.Entities; |
| with Einfo.Utils; use Einfo.Utils; |
| 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_Prag; use Exp_Prag; |
| with Exp_Tss; use Exp_Tss; |
| with Exp_Util; use Exp_Util; |
| with Freeze; use Freeze; |
| with GNAT_CUDA; use GNAT_CUDA; |
| 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 Sinfo.Nodes; use Sinfo.Nodes; |
| with Sinfo.Utils; use Sinfo.Utils; |
| 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 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 -- |
| -------------------------------------------------- |
| |
| procedure Insert_Actions_In_Scope_Around |
| (N : Node_Id; |
| Clean : Boolean; |
| Manage_SS : Boolean); |
| -- 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. If flag Clean |
| -- is set, insert any cleanup actions. If flag Manage_SS is set, insert |
| -- calls to mark and release the secondary stack. |
| |
| 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 Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id); |
| -- Shared processing for Store_xxx_Actions_In_Scope |
| |
| ----------------------------- |
| -- 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 computation of 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); |
| |
| function Allows_Finalization_Master (Typ : Entity_Id) return Boolean; |
| -- Determine whether access type Typ may have a finalization master |
| |
| 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; |
| Additional_Cleanup : List_Id) return List_Id; |
| -- Create the cleanup calls for an asynchronous call block, task master, |
| -- protected subprogram body, task allocation block or task body, or |
| -- additional cleanup actions parked on a transient block. 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, or 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 task 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_Helper |
| (N : Node_Id; |
| Clean_Stmts : List_Id; |
| Mark_Id : Entity_Id; |
| Top_Decls : List_Id; |
| Defer_Abort : Boolean; |
| Fin_Id : out Entity_Id; |
| Finalize_Old_Only : Boolean); |
| -- An internal routine which does all of the heavy lifting on behalf of |
| -- Build_Finalizer. |
| |
| 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. |
| |
| ------------------------------------------- |
| -- Unnesting procedures for CCG and LLVM -- |
| ------------------------------------------- |
| |
| -- Expansion generates subprograms for controlled types management that |
| -- may appear in declarative lists in package declarations and bodies. |
| -- These subprograms appear within generated blocks that contain local |
| -- declarations and a call to finalization procedures. To ensure that |
| -- such subprograms get activation records when needed, we transform the |
| -- block into a procedure body, followed by a call to it in the same |
| -- declarative list. |
| |
| procedure Check_Unnesting_Elaboration_Code (N : Node_Id); |
| -- The statement part of a package body that is a compilation unit may |
| -- contain blocks that declare local subprograms. In Subprogram_Unnesting_ |
| -- Mode such subprograms must be handled as nested inside the (implicit) |
| -- elaboration procedure that executes that statement part. To handle |
| -- properly uplevel references we construct that subprogram explicitly, |
| -- to contain blocks and inner subprograms, the statement part becomes |
| -- a call to this subprogram. This is only done if blocks are present |
| -- in the statement list of the body. (It would be nice to unify this |
| -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since |
| -- they're doing very similar work, but are structured differently. ???) |
| |
| procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id); |
| -- Similarly, the declarations or statements in library-level packages may |
| -- have created blocks with nested subprograms. Such a block must be |
| -- transformed into a procedure followed by a call to it, so that unnesting |
| -- can handle uplevel references within these nested subprograms (typically |
| -- subprograms that handle finalization actions). This also applies to |
| -- nested packages, including instantiations, in which case it must |
| -- recursively process inner bodies. |
| |
| procedure Check_Unnesting_In_Handlers (N : Node_Id); |
| -- Similarly, check for blocks with nested subprograms occurring within |
| -- a set of exception handlers associated with a package body N. |
| |
| procedure Unnest_Block (Decl : Node_Id); |
| -- Blocks that contain nested subprograms with up-level references need to |
| -- create activation records for them. We do this by rewriting the block as |
| -- a procedure, followed by a call to it in the same declarative list, to |
| -- replicate the semantics of the original block. |
| -- |
| -- A common source for such block is a transient block created for a |
| -- construct (declaration, assignment, etc.) that involves controlled |
| -- actions or secondary-stack management, in which case the nested |
| -- subprogram is a finalizer. |
| |
| procedure Unnest_If_Statement (If_Stmt : Node_Id); |
| -- The separate statement lists associated with an if-statement (then part, |
| -- elsif parts, else part) may require unnesting if they directly contain |
| -- a subprogram body that references up-level objects. Each statement list |
| -- is traversed to locate such subprogram bodies, and if a part's statement |
| -- list contains a body, then the list is replaced with a new procedure |
| -- containing the part's statements followed by a call to the procedure. |
| -- Furthermore, any nested blocks, loops, or if statements will also be |
| -- traversed to determine the need for further unnesting transformations. |
| |
| procedure Unnest_Statement_List (Stmts : in out List_Id); |
| -- A list of statements that directly contains a subprogram at its outer |
| -- level, that may reference objects declared in that same statement list, |
| -- is rewritten as a procedure containing the statement list Stmts (which |
| -- includes any such objects as well as the nested subprogram), followed by |
| -- a call to the new procedure, and Stmts becomes the list containing the |
| -- procedure and the call. This ensures that Unnest_Subprogram will later |
| -- properly handle up-level references from the nested subprogram to |
| -- objects declared earlier in statement list, by creating an activation |
| -- record and passing it to the nested subprogram. This procedure also |
| -- resets the Scope of objects declared in the statement list, as well as |
| -- the Scope of the nested subprogram, to refer to the new procedure. |
| -- Also, the new procedure is marked Has_Nested_Subprogram, so this should |
| -- only be called when known that the statement list contains a subprogram. |
| |
| procedure Unnest_Loop (Loop_Stmt : Node_Id); |
| -- Top-level Loops that contain nested subprograms with up-level references |
| -- need to have activation records. We do this by rewriting the loop as a |
| -- procedure containing the loop, followed by a call to the procedure in |
| -- the same library-level declarative list, to replicate the semantics of |
| -- the original loop. Such loops can occur due to aggregate expansions and |
| -- other constructs. |
| |
| 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 Contains_Subprogram (Blk : Entity_Id) return Boolean; |
| -- Check recursively whether a loop or block contains a subprogram that |
| -- may need an activation record. |
| |
| 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; |
| Skip_Self : Boolean := False) return Node_Id; |
| -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of |
| -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create |
| -- an adjust or finalization call. When flag Skip_Self is set, the related |
| -- action has an effect on the components only (if any). |
| |
| function Make_Deep_Proc |
| (Prim : Final_Primitives; |
| Typ : Entity_Id; |
| Stmts : List_Id) return Entity_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; |
| |
| -------------------------------- |
| -- Allows_Finalization_Master -- |
| -------------------------------- |
| |
| function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is |
| 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; |
| |
| -- Local variables |
| |
| Desig_Typ : constant Entity_Id := Designated_Type (Typ); |
| Ptr_Typ : constant Entity_Id := |
| Root_Type_Of_Full_View (Base_Type (Typ)); |
| |
| -- Start of processing for Allows_Finalization_Master |
| |
| begin |
| -- Certain run-time configurations and targets do not provide support |
| -- for controlled types and therefore do not need masters. |
| |
| if Restriction_Active (No_Finalization) then |
| return False; |
| |
| -- Do not consider C and C++ types since it is assumed that the non-Ada |
| -- side will handle their cleanup. |
| |
| elsif Convention (Desig_Typ) = Convention_C |
| or else Convention (Desig_Typ) = Convention_CPP |
| then |
| return False; |
| |
| -- Do not consider an access type that returns 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 False; |
| |
| -- Do not consider an access type that can never allocate an object |
| |
| elsif No_Pool_Assigned (Ptr_Typ) then |
| return False; |
| |
| -- Do not consider an access type coming from an Unchecked_Deallocation |
| -- instance. Even though the designated type may be controlled, the |
| -- access type will never participate in any allocations. |
| |
| elsif In_Deallocation_Instance (Ptr_Typ) then |
| return False; |
| |
| -- Do not consider a non-library access type when No_Nested_Finalization |
| -- is in effect since finalization masters are controlled objects and if |
| -- created will violate the restriction. |
| |
| elsif Restriction_Active (No_Nested_Finalization) |
| and then not Is_Library_Level_Entity (Ptr_Typ) |
| then |
| return False; |
| |
| -- Do not consider an access type subject to pragma No_Heap_Finalization |
| -- because objects allocated through such a type are not to be finalized |
| -- when the access type goes out of scope. |
| |
| elsif No_Heap_Finalization (Ptr_Typ) then |
| return False; |
| |
| -- Do not create finalization masters in GNATprove mode because this |
| -- causes unwanted extra expansion. A compilation in this mode must |
| -- keep the tree as close as possible to the original sources. |
| |
| elsif GNATprove_Mode then |
| return False; |
| |
| -- Otherwise the access type may use a finalization master |
| |
| else |
| return True; |
| end if; |
| end Allows_Finalization_Master; |
| |
| ---------------------------- |
| -- Build_Anonymous_Master -- |
| ---------------------------- |
| |
| procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is |
| function Create_Anonymous_Master |
| (Desig_Typ : Entity_Id; |
| Unit_Id : Entity_Id; |
| Unit_Decl : Node_Id) return Entity_Id; |
| -- Create a new anonymous master for access type Ptr_Typ with designated |
| -- type Desig_Typ. The declaration of the master and its initialization |
| -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is |
| -- the entity of Unit_Decl. |
| |
| function Current_Anonymous_Master |
| (Desig_Typ : Entity_Id; |
| Unit_Id : Entity_Id) return Entity_Id; |
| -- Find an anonymous master declared within unit Unit_Id which services |
| -- designated type Desig_Typ. If there is no such master, return Empty. |
| |
| ----------------------------- |
| -- Create_Anonymous_Master -- |
| ----------------------------- |
| |
| function Create_Anonymous_Master |
| (Desig_Typ : Entity_Id; |
| Unit_Id : Entity_Id; |
| Unit_Decl : Node_Id) return Entity_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Unit_Id); |
| |
| All_FMs : Elist_Id; |
| Decls : List_Id; |
| FM_Decl : Node_Id; |
| FM_Id : Entity_Id; |
| FM_Init : Node_Id; |
| Unit_Spec : Node_Id; |
| |
| begin |
| -- Generate: |
| -- <FM_Id> : Finalization_Master; |
| |
| FM_Id := Make_Temporary (Loc, 'A'); |
| |
| FM_Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => FM_Id, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)); |
| |
| -- Generate: |
| -- Set_Base_Pool |
| -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access); |
| |
| FM_Init := |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (FM_Id, Loc), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc), |
| Attribute_Name => Name_Unrestricted_Access))); |
| |
| -- Find the declarative list of the unit |
| |
| if Nkind (Unit_Decl) = N_Package_Declaration then |
| Unit_Spec := Specification (Unit_Decl); |
| Decls := Visible_Declarations (Unit_Spec); |
| |
| if No (Decls) then |
| Decls := New_List; |
| Set_Visible_Declarations (Unit_Spec, Decls); |
| end if; |
| |
| -- Package body or subprogram case |
| |
| -- ??? A subprogram spec or body that acts as a compilation unit may |
| -- contain a formal parameter of an anonymous access-to-controlled |
| -- type initialized by an allocator. |
| |
| -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl); |
| |
| -- There is no suitable place to create the master as the subprogram |
| -- is not in a declarative list. |
| |
| else |
| Decls := Declarations (Unit_Decl); |
| |
| if No (Decls) then |
| Decls := New_List; |
| Set_Declarations (Unit_Decl, Decls); |
| end if; |
| end if; |
| |
| Prepend_To (Decls, FM_Init); |
| Prepend_To (Decls, FM_Decl); |
| |
| -- Use the scope of the unit when analyzing the declaration of the |
| -- master and its initialization actions. |
| |
| Push_Scope (Unit_Id); |
| Analyze (FM_Decl); |
| Analyze (FM_Init); |
| Pop_Scope; |
| |
| -- Mark the master as servicing this specific designated type |
| |
| Set_Anonymous_Designated_Type (FM_Id, Desig_Typ); |
| |
| -- Include the anonymous master in the list of existing masters which |
| -- appear in this unit. This effectively creates a mapping between a |
| -- master and a designated type which in turn allows for the reuse of |
| -- masters on a per-unit basis. |
| |
| All_FMs := Anonymous_Masters (Unit_Id); |
| |
| if No (All_FMs) then |
| All_FMs := New_Elmt_List; |
| Set_Anonymous_Masters (Unit_Id, All_FMs); |
| end if; |
| |
| Prepend_Elmt (FM_Id, All_FMs); |
| |
| return FM_Id; |
| end Create_Anonymous_Master; |
| |
| ------------------------------ |
| -- Current_Anonymous_Master -- |
| ------------------------------ |
| |
| function Current_Anonymous_Master |
| (Desig_Typ : Entity_Id; |
| Unit_Id : Entity_Id) return Entity_Id |
| is |
| All_FMs : constant Elist_Id := Anonymous_Masters (Unit_Id); |
| FM_Elmt : Elmt_Id; |
| FM_Id : Entity_Id; |
| |
| begin |
| -- Inspect the list of anonymous masters declared within the unit |
| -- looking for an existing master which services the same designated |
| -- type. |
| |
| if Present (All_FMs) then |
| FM_Elmt := First_Elmt (All_FMs); |
| while Present (FM_Elmt) loop |
| FM_Id := Node (FM_Elmt); |
| |
| -- The currect master services the same designated type. As a |
| -- result the master can be reused and associated with another |
| -- anonymous access-to-controlled type. |
| |
| if Anonymous_Designated_Type (FM_Id) = Desig_Typ then |
| return FM_Id; |
| end if; |
| |
| Next_Elmt (FM_Elmt); |
| end loop; |
| end if; |
| |
| return Empty; |
| end Current_Anonymous_Master; |
| |
| -- Local variables |
| |
| Desig_Typ : Entity_Id; |
| FM_Id : Entity_Id; |
| Priv_View : Entity_Id; |
| Unit_Decl : Node_Id; |
| Unit_Id : Entity_Id; |
| |
| -- Start of processing for Build_Anonymous_Master |
| |
| begin |
| -- Nothing to do if the circumstances do not allow for a finalization |
| -- master. |
| |
| if not Allows_Finalization_Master (Ptr_Typ) then |
| return; |
| end if; |
| |
| Unit_Decl := Unit (Cunit (Current_Sem_Unit)); |
| Unit_Id := Unique_Defining_Entity (Unit_Decl); |
| |
| -- The compilation unit is a package instantiation. In this case the |
| -- anonymous master is associated with the package spec as both the |
| -- spec and body appear at the same level. |
| |
| if Nkind (Unit_Decl) = N_Package_Body |
| and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation |
| then |
| Unit_Id := Corresponding_Spec (Unit_Decl); |
| Unit_Decl := Unit_Declaration_Node (Unit_Id); |
| end if; |
| |
| -- Use the initial declaration of the designated type when it denotes |
| -- the full view of an incomplete or private type. This ensures that |
| -- types with one and two views are treated the same. |
| |
| Desig_Typ := Directly_Designated_Type (Ptr_Typ); |
| Priv_View := Incomplete_Or_Partial_View (Desig_Typ); |
| |
| if Present (Priv_View) then |
| Desig_Typ := Priv_View; |
| end if; |
| |
| -- Determine whether the current semantic unit already has an anonymous |
| -- master which services the designated type. |
| |
| FM_Id := Current_Anonymous_Master (Desig_Typ, Unit_Id); |
| |
| -- If this is not the case, create a new master |
| |
| if No (FM_Id) then |
| FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl); |
| end if; |
| |
| Set_Finalization_Master (Ptr_Typ, FM_Id); |
| end Build_Anonymous_Master; |
| |
| ---------------------------- |
| -- 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_Limited_View (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 (unless CodePeer_Mode) |
| |
| if not CodePeer_Mode 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; |
| Additional_Cleanup : List_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 := Empty; |
| 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)); |
| pragma Assert (Present (Conc_Typ)); |
| |
| -- Historical note: In earlier versions of GNAT, there was code |
| -- at this point to generate stuff to service entry queues. It is |
| -- now abstracted in Build_Protected_Subprogram_Call_Cleanup. |
| |
| Build_Protected_Subprogram_Call_Cleanup |
| (Specification (N), Conc_Typ, Loc, Stmts); |
| 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_Occurrence_Of |
| (RTE (RE_Expunge_Unactivated_Tasks), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (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_Occurrence_Of (RTE (RE_Enqueued), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Cancel_Param, Loc))), |
| |
| Then_Statements => New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Cancel_Protected_Entry_Call), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (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_Occurrence_Of (RTE (RE_Cancel_Async_Delay), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (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_Occurrence_Of (RTE (RE_Cancel_Task_Entry_Call), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Cancel_Param, Loc)))); |
| end if; |
| end; |
| end if; |
| |
| Append_List_To (Stmts, Additional_Cleanup); |
| 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_Occurrence_Of |
| (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_Occurrence_Of (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_Occurrence_Of (Data.Raised_Id, Data.Loc)), |
| |
| Then_Statements => New_List ( |
| Make_Assignment_Statement (Data.Loc, |
| Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc), |
| Expression => New_Occurrence_Of (Standard_True, Data.Loc)), |
| |
| Make_Procedure_Call_Statement (Data.Loc, |
| Name => |
| New_Occurrence_Of (Proc_To_Call, Data.Loc), |
| Parameter_Associations => Actuals)))); |
| |
| else |
| -- Generate: |
| |
| -- Raised_Id := True; |
| |
| Stmts := New_List ( |
| Make_Assignment_Statement (Data.Loc, |
| Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc), |
| Expression => New_Occurrence_Of (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; |
| For_Lib_Level : Boolean := False; |
| For_Private : Boolean := False; |
| Context_Scope : Entity_Id := Empty; |
| Insertion_Node : Node_Id := Empty) |
| is |
| procedure Add_Pending_Access_Type |
| (Typ : Entity_Id; |
| Ptr_Typ : Entity_Id); |
| -- Add access type Ptr_Typ to the pending access type list for type Typ |
| |
| ----------------------------- |
| -- Add_Pending_Access_Type -- |
| ----------------------------- |
| |
| procedure Add_Pending_Access_Type |
| (Typ : Entity_Id; |
| Ptr_Typ : Entity_Id) |
| is |
| List : Elist_Id; |
| |
| begin |
| if Present (Pending_Access_Types (Typ)) then |
| List := Pending_Access_Types (Typ); |
| else |
| List := New_Elmt_List; |
| Set_Pending_Access_Types (Typ, List); |
| end if; |
| |
| Prepend_Elmt (Ptr_Typ, List); |
| end Add_Pending_Access_Type; |
| |
| -- Local variables |
| |
| Desig_Typ : constant Entity_Id := Designated_Type (Typ); |
| |
| Ptr_Typ : constant Entity_Id := Root_Type_Of_Full_View (Base_Type (Typ)); |
| -- A finalization master created for a named access type is associated |
| -- with the full view (if applicable) as a consequence of freezing. The |
| -- full view criteria does not apply to anonymous access types because |
| -- those cannot have a private and a full view. |
| |
| -- Start of processing for Build_Finalization_Master |
| |
| begin |
| -- Nothing to do if the circumstances do not allow for a finalization |
| -- master. |
| |
| if not Allows_Finalization_Master (Typ) then |
| return; |
| |
| -- Various machinery such as freezing may have already created a |
| -- finalization master. |
| |
| elsif Present (Finalization_Master (Ptr_Typ)) then |
| return; |
| end if; |
| |
| declare |
| Actions : constant List_Id := New_List; |
| Loc : constant Source_Ptr := Sloc (Ptr_Typ); |
| Fin_Mas_Id : Entity_Id; |
| Pool_Id : Entity_Id; |
| |
| begin |
| -- 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; |
| |
| Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); |
| |
| -- Generate: |
| -- <Ptr_Typ>FM : aliased Finalization_Master; |
| |
| Append_To (Actions, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Fin_Mas_Id, |
| Aliased_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Finalization_Master), Loc))); |
| |
| if Debug_Generated_Code then |
| Set_Debug_Info_Needed (Fin_Mas_Id); |
| end if; |
| |
| -- Set the associated pool and primitive Finalize_Address of the new |
| -- finalization master. |
| |
| -- The access type has a user-defined storage pool, use it |
| |
| if Present (Associated_Storage_Pool (Ptr_Typ)) then |
| Pool_Id := Associated_Storage_Pool (Ptr_Typ); |
| |
| -- Otherwise the default choice is the global storage pool |
| |
| else |
| Pool_Id := RTE (RE_Global_Pool_Object); |
| Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); |
| end if; |
| |
| -- Generate: |
| -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access); |
| |
| Append_To (Actions, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Fin_Mas_Id, Loc), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Pool_Id, Loc), |
| Attribute_Name => Name_Unrestricted_Access)))); |
| |
| -- Finalize_Address is not generated in CodePeer mode because the |
| -- body contains address arithmetic. Skip this step. |
| |
| if CodePeer_Mode then |
| null; |
| |
| -- Associate the Finalize_Address primitive of the designated type |
| -- with the finalization master of the access type. The designated |
| -- type must be forzen as Finalize_Address is generated when the |
| -- freeze node is expanded. |
| |
| elsif Is_Frozen (Desig_Typ) |
| and then Present (Finalize_Address (Desig_Typ)) |
| |
| -- The finalization master of an anonymous access type may need |
| -- to be inserted in a specific place in the tree. For instance: |
| |
| -- type Comp_Typ; |
| |
| -- <finalization master of "access Comp_Typ"> |
| |
| -- type Rec_Typ is record |
| -- Comp : access Comp_Typ; |
| -- end record; |
| |
| -- <freeze node for Comp_Typ> |
| -- <freeze node for Rec_Typ> |
| |
| -- Due to this oddity, the anonymous access type is stored for |
| -- later processing (see below). |
| |
| and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type |
| then |
| -- Generate: |
| -- Set_Finalize_Address |
| -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access); |
| |
| Append_To (Actions, |
| Make_Set_Finalize_Address_Call |
| (Loc => Loc, |
| Ptr_Typ => Ptr_Typ)); |
| |
| -- Otherwise the designated type is either anonymous access or a |
| -- Taft-amendment type and has not been frozen. Store the access |
| -- type for later processing (see Freeze_Type). |
| |
| else |
| Add_Pending_Access_Type (Desig_Typ, Ptr_Typ); |
| end if; |
| |
| -- A finalization master created for an access designating a type |
| -- with private components is inserted before a context-dependent |
| -- node. |
| |
| if For_Private then |
| |
| -- At this point both the scope of the context and the insertion |
| -- mode must be known. |
| |
| pragma Assert (Present (Context_Scope)); |
| pragma Assert (Present (Insertion_Node)); |
| |
| Push_Scope (Context_Scope); |
| |
| -- Treat use clauses as declarations and insert directly in front |
| -- of them. |
| |
| if Nkind (Insertion_Node) in |
| N_Use_Package_Clause | N_Use_Type_Clause |
| then |
| Insert_List_Before_And_Analyze (Insertion_Node, Actions); |
| else |
| Insert_Actions (Insertion_Node, Actions); |
| end if; |
| |
| Pop_Scope; |
| |
| -- The finalization master belongs to an access result type related |
| -- to a build-in-place function call used to initialize a library |
| -- level object. The master must be inserted in front of the access |
| -- result type declaration denoted by Insertion_Node. |
| |
| elsif For_Lib_Level then |
| pragma Assert (Present (Insertion_Node)); |
| Insert_Actions (Insertion_Node, Actions); |
| |
| -- Otherwise the finalization master and its initialization become a |
| -- part of the freeze node. |
| |
| else |
| Append_Freeze_Actions (Ptr_Typ, Actions); |
| end if; |
| |
| Analyze_List (Actions); |
| |
| -- When the type the finalization master is being generated for was |
| -- created to store a 'Old object, then mark it as such so its |
| -- finalization can be delayed until after postconditions have been |
| -- checked. |
| |
| if Stores_Attribute_Old_Prefix (Ptr_Typ) then |
| Set_Stores_Attribute_Old_Prefix (Fin_Mas_Id); |
| end if; |
| end; |
| end Build_Finalization_Master; |
| |
| ---------------------------- |
| -- Build_Finalizer_Helper -- |
| ---------------------------- |
| |
| procedure Build_Finalizer_Helper |
| (N : Node_Id; |
| Clean_Stmts : List_Id; |
| Mark_Id : Entity_Id; |
| Top_Decls : List_Id; |
| Defer_Abort : Boolean; |
| Fin_Id : out Entity_Id; |
| Finalize_Old_Only : Boolean) |
| is |
| Acts_As_Clean : constant Boolean := |
| Present (Mark_Id) |
| or else |
| (Present (Clean_Stmts) |
| and then Is_Non_Empty_List (Clean_Stmts)); |
| |
| 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 : Nat := 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 occurrence 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. |
| |
| function New_Finalizer_Name |
| (Spec_Id : Node_Id; For_Spec : Boolean) 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]. |
| |
| 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 and set Counter_Val accordingly. Top_Level is only relevant |
| -- when Preprocess is set and if True, the processing is performed 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_Occurrence_Of (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_Occurrence_Of (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); |
| |
| if Debug_Generated_Code then |
| Set_Debug_Info_Needed (Counter_Id); |
| end if; |
| |
| -- 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 analyzed |
| -- 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 cleanup, the finalization |
| -- machinery is added after the cleanup 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; |
| |
| 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 (Spec_Id, For_Package_Spec)); |
| Set_Has_Qualified_Name (Fin_Id); |
| Set_Has_Fully_Qualified_Name (Fin_Id); |
| |
| -- The default name is _finalizer |
| |
| else |
| -- Generation of a finalization procedure exclusively for 'Old |
| -- interally generated constants requires different name since |
| -- there will need to be multiple finalization routines in the |
| -- same scope. See Build_Finalizer for details. |
| |
| if Finalize_Old_Only then |
| Fin_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Name_uFinalizer_Old)); |
| else |
| Fin_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Name_uFinalizer)); |
| end if; |
| |
| -- 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); |
| |
| -- Inlining the finalizer produces a substantial speedup at -O2. |
| -- It is inlined by default at -O3. Either way, it is called |
| -- exactly twice (once on the normal path, and once for |
| -- exceptions/abort), so this won't bloat the code too much. |
| |
| Set_Is_Inlined (Fin_Id); |
| end if; |
| |
| if Debug_Generated_Code then |
| Set_Debug_Info_Needed (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)); |
| |
| if For_Package then |
| Set_Is_Exported (Fin_Id); |
| Set_Interface_Name (Fin_Id, |
| Make_String_Literal (Loc, |
| Strval => Get_Name_String (Chars (Fin_Id)))); |
| end if; |
| |
| -- Step 3: Creation of the finalizer body |
| |
| -- Has_Ctrl_Objs might be set because of a generic package body having |
| -- controlled objects. In this case, Jump_Alts may be empty and no |
| -- case nor goto statements are needed. |
| |
| if Has_Ctrl_Objs |
| and then not Is_Empty_List (Jump_Alts) |
| 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_Occurrence_Of (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 |
| |
| if Present (Mark_Id) then |
| declare |
| Release : Node_Id := Build_SS_Release_Call (Loc, Mark_Id); |
| |
| begin |
| -- If the context is a build-in-place function, the secondary |
| -- stack must be released, unless the build-in-place function |
| -- itself is returning on the secondary stack. Generate: |
| -- |
| -- if BIP_Alloc_Form /= Secondary_Stack then |
| -- SS_Release (Mark_Id); |
| -- end if; |
| -- |
| -- Note that if the function returns on the secondary stack, |
| -- then the responsibility of reclaiming the space is always |
| -- left to the caller (recursively if needed). |
| |
| if Nkind (N) = N_Subprogram_Body then |
| declare |
| Spec_Id : constant Entity_Id := |
| Unique_Defining_Entity (N); |
| BIP_SS : constant Boolean := |
| Is_Build_In_Place_Function (Spec_Id) |
| and then Needs_BIP_Alloc_Form (Spec_Id); |
| begin |
| if BIP_SS then |
| Release := |
| Make_If_Statement (Loc, |
| Condition => |
| Make_Op_Ne (Loc, |
| Left_Opnd => |
| New_Occurrence_Of |
| (Build_In_Place_Formal |
| (Spec_Id, BIP_Alloc_Form), Loc), |
| Right_Opnd => |
| Make_Integer_Literal (Loc, |
| UI_From_Int |
| (BIP_Allocation_Form'Pos |
| (Secondary_Stack)))), |
| |
| Then_Statements => New_List (Release)); |
| end if; |
| end; |
| end if; |
| |
| Append_To (Finalizer_Stmts, Release); |
| end; |
| end if; |
| |
| -- Protect the statements with abort defer/undefer. This is only when |
| -- aborts are allowed and the cleanup statements require deferral or |
| -- there are controlled objects to be finalized. Note that the abort |
| -- defer/undefer pair does not require an extra block because each |
| -- finalization exception is caught in its corresponding finalization |
| -- block. As a result, the call to Abort_Defer always takes place. |
| |
| if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then |
| Prepend_To (Finalizer_Stmts, |
| Build_Runtime_Call (Loc, RE_Abort_Defer)); |
| |
| Append_To (Finalizer_Stmts, |
| Build_Runtime_Call (Loc, RE_Abort_Undefer)); |
| 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 |
| -- cleanup, 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 Exceptions_OK and 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 Debug_Generated_Code then |
| Set_Debug_Info_Needed (Body_Id); |
| end if; |
| |
| 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, |
| Statements => 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)); |
| |
| -- It maybe possible that we are finalizing 'Old objects which |
| -- exist in the spec declarations. When this is the case the |
| -- Finalizer_Insert_Node will come before the end of the |
| -- Spec_Decls. So, to mitigate this, we insert the finalizer spec |
| -- earlier at the Finalizer_Insert_Nod instead of appending to the |
| -- end of Spec_Decls to prevent its body appearing before its |
| -- corresponding spec. |
| |
| if Present (Finalizer_Insert_Nod) |
| and then List_Containing (Finalizer_Insert_Nod) = Spec_Decls |
| then |
| Insert_After_And_Analyze (Finalizer_Insert_Nod, Fin_Spec); |
| Finalizer_Insert_Nod := Fin_Spec; |
| |
| -- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls |
| |
| else |
| Append_To (Spec_Decls, Fin_Spec); |
| Analyze (Fin_Spec); |
| end if; |
| |
| -- When the finalizer acts solely as a cleanup routine, the body |
| -- is inserted right after the spec. |
| |
| if Acts_As_Clean and 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 (Last_Top_Level_Ctrl_Construct) in |
| 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, Suppress => All_Checks); |
| end if; |
| |
| -- Never consider that the finalizer procedure is enabled Ghost, even |
| -- when the corresponding unit is Ghost, as this would lead to an |
| -- an external name with a ___ghost_ prefix that the binder cannot |
| -- generate, as it has no knowledge of the Ghost status of units. |
| |
| Set_Is_Checked_Ghost_Entity (Fin_Id, False); |
| end Create_Finalizer; |
| |
| ------------------------ |
| -- New_Finalizer_Name -- |
| ------------------------ |
| |
| function New_Finalizer_Name |
| (Spec_Id : Node_Id; For_Spec : Boolean) 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 ("__"); |
| Get_Name_String_And_Append (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_Spec then |
| Add_Str_To_Name_Buffer ("spec"); |
| else |
| Add_Str_To_Name_Buffer ("body"); |
| end if; |
| |
| return Name_Find; |
| end New_Finalizer_Name; |
| |
| -------------------------- |
| -- 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 : Nat; |
| -- 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; |
| |
| -- Unregister tagged type, unless No_Tagged_Type_Registration |
| -- is active. |
| |
| elsif not Restriction_Active (No_Tagged_Type_Registration) then |
| 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 Is_Empty_List (Decls) then |
| return; |
| end if; |
| |
| -- Process all declarations in reverse order |
| |
| Decl := Last_Non_Pragma (Decls); |
| while Present (Decl) loop |
| -- Depending on the value of flag Finalize_Old_Only we determine |
| -- which objects get finalized as part of the current finalizer |
| -- being built. |
| |
| -- When True, only temporaries capturing the value of attribute |
| -- 'Old are finalized and all other cases are ignored. |
| |
| -- When False, temporary objects used to capture the value of 'Old |
| -- are ignored and all others are considered. |
| |
| if Finalize_Old_Only |
| xor (Nkind (Decl) = N_Object_Declaration |
| and then Stores_Attribute_Old_Prefix |
| (Defining_Identifier (Decl))) |
| then |
| null; |
| |
| -- Library-level tagged types |
| |
| elsif Nkind (Decl) = N_Full_Type_Declaration then |
| Typ := Defining_Identifier (Decl); |
| |
| -- Ignored Ghost types do not need any cleanup actions because |
| -- they will not appear in the final tree. |
| |
| if Is_Ignored_Ghost_Entity (Typ) then |
| null; |
| |
| elsif 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 not Is_Abstract_Type (Typ) |
| and then not No_Run_Time_Mode |
| and then not Restriction_Active (No_Tagged_Type_Registration) |
| and then RTE_Available (RE_Register_Tag) |
| 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; |
| |
| -- Finalization of transient objects are treated separately in |
| -- order to handle sensitive cases. These include: |
| |
| -- * Aggregate expansion |
| -- * If, case, and expression with actions expansion |
| -- * Transient scopes |
| |
| -- If one of those contexts has marked the transient object as |
| -- ignored, do not generate finalization actions for it. |
| |
| elsif Is_Finalized_Transient (Obj_Id) |
| or else Is_Ignored_Transient (Obj_Id) |
| then |
| null; |
| |
| -- Ignored Ghost objects do not need any cleanup actions |
| -- because they will not appear in the final tree. |
| |
| elsif Is_Ignored_Ghost_Entity (Obj_Id) then |
| null; |
| |
| -- The object is of the form: |
| -- Obj : [constant] Typ [:= Expr]; |
| |
| -- Do not process tag-to-class-wide conversions because they do |
| -- not yield an object. Do not process the incomplete view of a |
| -- deferred constant. Note that an object initialized by means |
| -- of a build-in-place function call may appear as a deferred |
| -- constant after expansion activities. These kinds of objects |
| -- must be finalized. |
| |
| elsif not Is_Imported (Obj_Id) |
| and then Needs_Finalization (Obj_Typ) |
| and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id) |
| and then not (Ekind (Obj_Id) = E_Constant |
| and then not Has_Completion (Obj_Id) |
| and then No (BIP_Initialization_Call (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 transient |
| -- objects 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 |
| 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; |
| |
| -- Ignored Ghost object renamings do not need any cleanup |
| -- actions because they will not appear in the final tree. |
| |
| elsif Is_Ignored_Ghost_Entity (Obj_Id) 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); |
| |
| -- Freeze nodes for ignored Ghost types do not need cleanup |
| -- actions because they will never appear in the final tree. |
| |
| if Is_Ignored_Ghost_Entity (Typ) then |
| null; |
| |
| elsif (Is_Access_Object_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 |
| Pack_Id := Defining_Entity (Decl); |
| Spec := Specification (Decl); |
| |
| -- Do not inspect an ignored Ghost package because all code |
| -- found within will not appear in the final tree. |
| |
| if Is_Ignored_Ghost_Entity (Pack_Id) then |
| null; |
| |
| elsif 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; |
| |
| -- Call the xxx__finalize_body procedure of a library level |
| -- package instantiation if the body contains finalization |
| -- statements. |
| |
| if Present (Generic_Parent (Spec)) |
| and then Is_Library_Level_Entity (Pack_Id) |
| and then Present (Body_Entity (Generic_Parent (Spec))) |
| then |
| if Preprocess then |
| declare |
| P : Node_Id; |
| begin |
| P := Parent (Body_Entity (Generic_Parent (Spec))); |
| while Present (P) |
| and then Nkind (P) /= N_Package_Body |
| loop |
| P := Parent (P); |
| end loop; |
| |
| if Present (P) then |
| Old_Counter_Val := Counter_Val; |
| Process_Declarations (Declarations (P), Preprocess); |
| |
| -- Note that we are processing the generic body |
| -- template and not the actually instantiation |
| -- (which is generated too late for us to process |
| -- it), so there is no need to update in particular |
| -- to update Last_Top_Level_Ctrl_Construct here. |
| |
| if Counter_Val > Old_Counter_Val then |
| Counter_Val := Old_Counter_Val; |
| Set_Has_Controlled_Component (Pack_Id); |
| end if; |
| end if; |
| end; |
| |
| elsif Has_Controlled_Component (Pack_Id) then |
| |
| -- We import the xxx__finalize_body routine since the |
| -- generic body will be instantiated later. |
| |
| declare |
| Id : constant Node_Id := |
| Make_Defining_Identifier (Loc, |
| New_Finalizer_Name (Defining_Unit_Name (Spec), |
| For_Spec => False)); |
| |
| begin |
| Set_Has_Qualified_Name (Id); |
| Set_Has_Fully_Qualified_Name (Id); |
| Set_Is_Imported (Id); |
| Set_Has_Completion (Id); |
| Set_Interface_Name (Id, |
| Make_String_Literal (Loc, |
| Strval => Get_Name_String (Chars (Id)))); |
| |
| Append_New_To (Finalizer_Stmts, |
| Make_Subprogram_Declaration (Loc, |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Id))); |
| Append_To (Finalizer_Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Id, Loc))); |
| end; |
| end if; |
| end if; |
| |
| -- Nested package bodies, avoid generics |
| |
| elsif Nkind (Decl) = N_Package_Body then |
| |
| -- Do not inspect an ignored Ghost package body because all |
| -- code found within will not appear in the final tree. |
| |
| if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then |
| null; |
| |
| elsif Ekind (Corresponding_Spec (Decl)) /= 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 object |
| -- 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 |
| Loc : constant Source_Ptr := Sloc (Decl); |
| Obj_Id : constant Entity_Id := Defining_Identifier (Decl); |
| |
| Init_Typ : Entity_Id; |
| -- The initialization type of the related object declaration. Note |
| -- that this is not necessarily the same type as Obj_Typ because of |
| -- possible type derivations. |
| |
| Obj_Typ : Entity_Id; |
| -- The type of the related object declaration |
| |
| function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id; |
| -- Func_Id denotes a build-in-place function. 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 |
| (Last_Init : out Node_Id; |
| Body_Insert : out Node_Id); |
| -- Find the last initialization call related to object declaration |
| -- Decl. Last_Init denotes the last initialization call which follows |
| -- Decl. Body_Insert denotes a node where the finalizer body could be |
| -- potentially inserted after (if blocks are involved). |
| |
| ----------------------------- |
| -- 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); |
| Func_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_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc), |
| Name => |
| Make_Explicit_Dereference (Loc, |
| Prefix => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Base_Pool), Loc), |
| Parameter_Associations => New_List ( |
| Make_Explicit_Dereference (Loc, |
| Prefix => |
| New_Occurrence_Of (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 Func_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_Occurrence_Of (Func_Typ, Loc)))); |
| |
| -- Perform minor decoration in order to set the master and the |
| -- storage pool attributes. |
| |
| Mutate_Ekind (Ptr_Typ, E_Access_Type); |
| Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); |
| Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); |
| |
| if Debug_Generated_Code then |
| Set_Debug_Info_Needed (Pool_Id); |
| end if; |
| |
| -- 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_Occurrence_Of (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_Occurrence_Of (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 (Func_Typ) |
| or else Is_Tagged_Type (Func_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_Occurrence_Of (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 |
| (Last_Init : out Node_Id; |
| Body_Insert : out Node_Id) |
| is |
| function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id; |
| -- Find the last initialization call within the statements of |
| -- block Blk. |
| |
| function Is_Init_Call (N : Node_Id) return Boolean; |
| -- Determine whether node N denotes one of the initialization |
| -- procedures of types Init_Typ or Obj_Typ. |
| |
| function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id; |
| -- Obtain the next statement which follows list member Stmt while |
| -- ignoring artifacts related to access-before-elaboration checks. |
| |
| ----------------------------- |
| -- Find_Last_Init_In_Block -- |
| ----------------------------- |
| |
| function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is |
| HSS : constant Node_Id := Handled_Statement_Sequence (Blk); |
| Stmt : Node_Id; |
| |
| begin |
| -- Examine the individual statements of the block in reverse to |
| -- locate the last initialization call. |
| |
| if Present (HSS) and then Present (Statements (HSS)) then |
| Stmt := Last (Statements (HSS)); |
| while Present (Stmt) loop |
| |
| -- Peek inside nested blocks in case aborts are allowed |
| |
| if Nkind (Stmt) = N_Block_Statement then |
| return Find_Last_Init_In_Block (Stmt); |
| |
| elsif Is_Init_Call (Stmt) then |
| return Stmt; |
| end if; |
| |
| Prev (Stmt); |
| end loop; |
| end if; |
| |
| return Empty; |
| end Find_Last_Init_In_Block; |
| |
| ------------------ |
| -- Is_Init_Call -- |
| ------------------ |
| |
| function Is_Init_Call (N : Node_Id) return Boolean is |
| function Is_Init_Proc_Of |
| (Subp_Id : Entity_Id; |
| Typ : Entity_Id) return Boolean; |
| -- Determine whether subprogram Subp_Id is a valid init proc of |
| -- type Typ. |
| |
| --------------------- |
| -- Is_Init_Proc_Of -- |
| --------------------- |
| |
| function Is_Init_Proc_Of |
| (Subp_Id : Entity_Id; |
| Typ : Entity_Id) return Boolean |
| is |
| Deep_Init : Entity_Id := Empty; |
| Prim_Init : Entity_Id := Empty; |
| Type_Init : Entity_Id := Empty; |
| |
| begin |
| -- Obtain all possible initialization routines of the |
| -- related type and try to match the subprogram entity |
| -- against one of them. |
| |
| -- Deep_Initialize |
| |
| Deep_Init := TSS (Typ, TSS_Deep_Initialize); |
| |
| -- Primitive Initialize |
| |
| if Is_Controlled (Typ) then |
| Prim_Init := Find_Optional_Prim_Op (Typ, Name_Initialize); |
| |
| if Present (Prim_Init) then |
| Prim_Init := Ultimate_Alias (Prim_Init); |
| end if; |
| end if; |
| |
| -- Type initialization routine |
| |
| if Has_Non_Null_Base_Init_Proc (Typ) then |
| Type_Init := Base_Init_Proc (Typ); |
| end if; |
| |
| return |
| (Present (Deep_Init) and then Subp_Id = Deep_Init) |
| or else |
| (Present (Prim_Init) and then Subp_Id = Prim_Init) |
| or else |
| (Present (Type_Init) and then Subp_Id = Type_Init); |
| end Is_Init_Proc_Of; |
| |
| -- Local variables |
| |
| Call_Id : Entity_Id; |
| |
| -- Start of processing for Is_Init_Call |
| |
| begin |
| if Nkind (N) = N_Procedure_Call_Statement |
| and then Nkind (Name (N)) = N_Identifier |
| then |
| Call_Id := Entity (Name (N)); |
| |
| -- Consider both the type of the object declaration and its |
| -- related initialization type. |
| |
| return |
| Is_Init_Proc_Of (Call_Id, Init_Typ) |
| or else |
| Is_Init_Proc_Of (Call_Id, Obj_Typ); |
| 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; |
| |
| begin |
| -- Skip call markers and Program_Error raises installed by the |
| -- ABE mechanism. |
| |
| Result := Next (Stmt); |
| while Present (Result) loop |
| exit when Nkind (Result) not in |
| N_Call_Marker | N_Raise_Program_Error; |
| |
| Next (Result); |
| end loop; |
| |
| return Result; |
| end Next_Suitable_Statement; |
| |
| -- Local variables |
| |
| Call : Node_Id; |
| Stmt : Node_Id; |
| Stmt_2 : Node_Id; |
| |
| Deep_Init_Found : Boolean := False; |
| -- A flag set when a call to [Deep_]Initialize has been found |
| |
| -- 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 require initialization. |
| |
| if Has_No_Init then |
| return; |
| end if; |
| |
| Stmt := Next_Suitable_Statement (Decl); |
| |
| -- For an object with suppressed initialization, we check whether |
| -- there is in fact no initialization expression. If there is not, |
| -- then this is an object declaration that has been turned into a |
| -- different object declaration that calls the build-in-place |
| -- function in a 'Reference attribute, as in "F(...)'Reference". |
| -- We search for that later object declaration, so that the |
| -- Inc_Decl will be inserted after the call. Otherwise, if the |
| -- call raises an exception, we will finalize the (uninitialized) |
| -- object, which is wrong. |
| |
| if No_Initialization (Decl) then |
| if No (Expression (Last_Init)) then |
| loop |
| Next (Last_Init); |
| exit when No (Last_Init); |
| exit when Nkind (Last_Init) = N_Object_Declaration |
| and then Nkind (Expression (Last_Init)) = N_Reference |
| and then Nkind (Prefix (Expression (Last_Init))) = |
| N_Function_Call |
| and then Is_Expanded_Build_In_Place_Call |
| (Prefix (Expression (Last_Init))); |
| end loop; |
| end if; |
| |
| return; |
| |
| -- In all other cases the initialization calls follow the related |
| -- object. The general structure of object initialization built by |
| -- routine Default_Initialize_Object is as follows: |
| |
| -- [begin -- aborts allowed |
| -- Abort_Defer;] |
| -- Type_Init_Proc (Obj); |
| -- [begin] -- exceptions allowed |
| -- Deep_Initialize (Obj); |
| -- [exception -- exceptions allowed |
| -- when others => |
| -- Deep_Finalize (Obj, Self => False); |
| -- raise; |
| -- end;] |
| -- [at end -- aborts allowed |
| -- Abort_Undefer; |
| -- end;] |
| |
| -- When aborts are allowed, the initialization calls are housed |
| -- within a block. |
| |
| elsif Nkind (Stmt) = N_Block_Statement then |
| Last_Init := Find_Last_Init_In_Block (Stmt); |
| Body_Insert := Stmt; |
| |
| -- Otherwise the initialization calls follow the related object |
| |
| else |
| pragma Assert (Present (Stmt)); |
| |
| Stmt_2 := Next_Suitable_Statement (Stmt); |
| |
| -- Check for an optional call to Deep_Initialize which may |
| -- appear within a block depending on whether the object has |
| -- controlled components. |
| |
| if Present (Stmt_2) then |
| if Nkind (Stmt_2) = N_Block_Statement then |
| Call := Find_Last_Init_In_Block (Stmt_2); |
| |
| if Present (Call) then |
| Deep_Init_Found := True; |
| Last_Init := Call; |
| Body_Insert := Stmt_2; |
| end if; |
| |
| elsif Is_Init_Call (Stmt_2) then |
| Deep_Init_Found := True; |
| Last_Init := Stmt_2; |
| Body_Insert := Last_Init; |
| end if; |
| end if; |
| |
| -- If the object lacks a call to Deep_Initialize, then it must |
| -- have a call to its related type init proc. |
| |
| if not Deep_Init_Found and then Is_Init_Call (Stmt) then |
| Last_Init := Stmt; |
| Body_Insert := Last_Init; |
| end if; |
| end if; |
| end Find_Last_Init; |
| |
| -- Local variables |
| |
| Body_Ins : Node_Id; |
| Count_Ins : Node_Id; |
| Fin_Call : Node_Id; |
| Fin_Stmts : List_Id := No_List; |
| Inc_Decl : Node_Id; |
| Label : Node_Id; |
| Label_Id : Entity_Id; |
| Obj_Ref : Node_Id; |
| |
| -- Start of processing for Process_Object_Declaration |
| |
| begin |
| -- Handle the object type and the reference to the object |
| |
| Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); |
| Obj_Typ := Base_Type (Etype (Obj_Id)); |
| |
| loop |
| if Is_Access_Type (Obj_Typ) then |
| Obj_Typ := Directly_Designated_Type (Obj_Typ); |
| Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); |
| |
| elsif Is_Concurrent_Type (Obj_Typ) |
| and then Present (Corresponding_Record_Type (Obj_Typ)) |
| then |
| Obj_Typ := Corresponding_Record_Type (Obj_Typ); |
| Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); |
| |
| elsif Is_Private_Type (Obj_Typ) |
| and then Present (Full_View (Obj_Typ)) |
| then |
| Obj_Typ := Full_View (Obj_Typ); |
| Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); |
| |
| elsif Obj_Typ /= Base_Type (Obj_Typ) then |
| Obj_Typ := Base_Type (Obj_Typ); |
| Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); |
| |
| else |
| exit; |
| end if; |
| end loop; |
| |
| Set_Etype (Obj_Ref, Obj_Typ); |
| |
| -- Handle the initialization type of the object declaration |
| |
| Init_Typ := Obj_Typ; |
| loop |
| if Is_Private_Type (Init_Typ) |
| and then Present (Full_View (Init_Typ)) |
| then |
| Init_Typ := Full_View (Init_Typ); |
| |
| elsif Is_Untagged_Derivation (Init_Typ) then |
| Init_Typ := Root_Type (Init_Typ); |
| |
| else |
| exit; |
| end if; |
| end loop; |
| |
| -- 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_Occurrence_Of (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. |
| |
| if Ekind (Obj_Id) in E_Constant | E_Variable then |
| |
| -- The object is initialized by a build-in-place function call. |
| -- The counter insertion point is after the function call. |
| |
| if Present (BIP_Initialization_Call (Obj_Id)) then |
| Count_Ins := BIP_Initialization_Call (Obj_Id); |
| Body_Ins := Empty; |
| |
| -- The object is initialized by an aggregate. Insert the counter |
| -- after the last aggregate assignment. |
| |
| elsif Present (Last_Aggregate_Assignment (Obj_Id)) then |
| Count_Ins := Last_Aggregate_Assignment (Obj_Id); |
| Body_Ins := Empty; |
| |
| -- In all other cases the counter is inserted after the last call |
| -- to either [Deep_]Initialize or the type-specific init proc. |
| |
| else |
| Find_Last_Init (Count_Ins, Body_Ins); |
| end if; |
| |
| -- In all other cases the counter is inserted after the last call to |
| -- either [Deep_]Initialize or the type-specific init proc. |
| |
| else |
| Find_Last_Init (Count_Ins, Body_Ins); |
| end if; |
| |
| -- If the Initialize function is null or trivial, the call will have |
| -- been replaced with a null statement, in which case place counter |
| -- declaration after object declaration itself. |
| |
| if No (Count_Ins) then |
| Count_Ins := Decl; |
| end if; |
| |
| 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 deferred 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_Occurrence_Of (Entity (Label_Id), Loc))))); |
| |
| -- Insert the jump destination, generate: |
| |
| -- <<L<counter>>> |
| |
| Append_To (Finalizer_Stmts, Label); |
| |
| -- Disable warnings on Obj_Id. This works around an issue where GCC |
| -- is not able to detect that Obj_Id is protected by a counter and |
| -- emits spurious warnings. |
| |
| if not Comes_From_Source (Obj_Id) then |
| Set_Warnings_Off (Obj_Id); |
| end if; |
| |
| -- Processing for simple protected objects. Such objects require |
| -- manual finalization of their lock managers. |
| |
| if Is_Protected then |
| 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) and then Exceptions_OK then |
| Fin_Stmts := New_List ( |
| 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: |
| -- begin |
| -- [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); |
| |
| -- Guard against a missing [Deep_]Finalize when the object type |
| -- was not properly frozen. |
| |
| if No (Fin_Call) then |
| Fin_Call := Make_Null_Statement (Loc); |
| end if; |
| |
| -- 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. |
| |
| if 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 (Obj_Id) in E_Constant | E_Variable |
| and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) |
| then |
| -- Temporaries created for the purpose of "exporting" a |
| -- transient object 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_Occurrence_Of (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_Occurrence_Of |
| (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_Occurrence_Of (RTE (RE_Unregister_Tag), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (DT_Ptr, Loc)))); |
| end Process_Tagged_Type_Declaration; |
| |
| -- Start of processing for Build_Finalizer_Helper |
| |
| begin |
| Fin_Id := Empty; |
| |
| -- Do not perform this expansion in SPARK mode because it is not |
| -- necessary. |
| |
| if GNATprove_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 library level entities, but do not need to |
| -- be processed separately. |
| |
| or else Scope_Depth (Spec_Id) /= Uint_1 |
| or else (Is_Generic_Instance (Spec_Id) |
| and then Package_Instantiation (Spec_Id) /= N)) |
| |
| -- Still need to process package body instantiations which may |
| -- contain objects requiring finalization. |
| |
| and then not |
| (For_Package_Body |
| and then Is_Library_Level_Entity (Spec_Id) |
| and then Is_Generic_Instance (Spec_Id)) |
| 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_Helper; |
| |
| -------------------------- |
| -- 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 SPARK mode because we do not create |
| -- finalizers in the first place. |
| |
| if GNATprove_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_Occurrence_Of (Fin_Id, Loc)); |
| |
| -- Attach reference to finalizer to tree, for LLVM use |
| |
| Set_Parent (At_End_Proc (HSS), HSS); |
| |
| Analyze (At_End_Proc (HSS)); |
| Expand_At_End_Handler (HSS, Empty); |
| end Build_Finalizer_Call; |
| |
| --------------------- |
| -- 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 |
| Def_Ent : constant Entity_Id := Unique_Defining_Entity (N); |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| -- Declarations used for the creation of _finalization_controller |
| |
| Fin_Old_Id : Entity_Id := Empty; |
| Fin_Controller_Id : Entity_Id := Empty; |
| Fin_Controller_Decls : List_Id; |
| Fin_Controller_Stmts : List_Id; |
| Fin_Controller_Body : Node_Id := Empty; |
| Fin_Controller_Spec : Node_Id := Empty; |
| Postconditions_Call : Node_Id := Empty; |
| |
| -- Defining identifiers for local objects used to store exception info |
| |
| Raised_Post_Exception_Id : Entity_Id := Empty; |
| Raised_Finalization_Exception_Id : Entity_Id := Empty; |
| Saved_Exception_Id : Entity_Id := Empty; |
| |
| -- Start of processing for Build_Finalizer |
| |
| begin |
| -- Create the general finalization routine |
| |
| Build_Finalizer_Helper |
| (N => N, |
| Clean_Stmts => Clean_Stmts, |
| Mark_Id => Mark_Id, |
| Top_Decls => Top_Decls, |
| Defer_Abort => Defer_Abort, |
| Fin_Id => Fin_Id, |
| Finalize_Old_Only => False); |
| |
| -- When postconditions are present, expansion gets much more complicated |
| -- due to both the fact that they must be called after finalization and |
| -- that finalization of 'Old objects must occur after the postconditions |
| -- get checked. |
| |
| -- Additionally, exceptions between general finalization and 'Old |
| -- finalization must be propagated correctly and exceptions which happen |
| -- during _postconditions need to be saved and reraised after |
| -- finalization of 'Old objects. |
| |
| -- Generate: |
| -- |
| -- Postcond_Enabled := False; |
| -- |
| -- procedure _finalization_controller is |
| -- |
| -- -- Exception capturing and tracking |
| -- |
| -- Saved_Exception : Exception_Occurrence; |
| -- Raised_Post_Exception : Boolean := False; |
| -- Raised_Finalization_Exception : Boolean := False; |
| -- |
| -- -- Start of processing for _finalization_controller |
| -- |
| -- begin |
| -- -- Perform general finalization |
| -- |
| -- begin |
| -- _finalizer; |
| -- exception |
| -- when others => |
| -- -- Save the exception |
| -- |
| -- Raised_Finalization_Exception := True; |
| -- Save_Occurrence |
| -- (Saved_Exception, Get_Current_Excep.all); |
| -- end; |
| -- |
| -- -- Perform postcondition checks after general finalization, but |
| -- -- before finalization of 'Old related objects. |
| -- |
| -- if not Raised_Finalization_Exception |
| -- and then Return_Success_For_Postcond |
| -- then |
| -- begin |
| -- -- Re-enable postconditions and check them |
| -- |
| -- Postcond_Enabled := True; |
| -- _postconditions [(Result_Obj_For_Postcond[.all])]; |
| -- exception |
| -- when others => |
| -- -- Save the exception |
| -- |
| -- Raised_Post_Exception := True; |
| -- Save_Occurrence |
| -- (Saved_Exception, Get_Current_Excep.all); |
| -- end; |
| -- end if; |
| -- |
| -- -- Finally finalize 'Old related objects |
| -- |
| -- begin |
| -- _finalizer_old; |
| -- exception |
| -- when others => |
| -- -- Reraise the previous finalization error if there is |
| -- -- one. |
| -- |
| -- if Raised_Finalization_Exception then |
| -- Reraise_Occurrence (Saved_Exception); |
| -- end if; |
| -- |
| -- -- Otherwise, reraise the current one |
| -- |
| -- raise; |
| -- end; |
| -- |
| -- -- Reraise any saved exception |
| -- |
| -- if Raised_Finalization_Exception |
| -- or else Raised_Post_Exception |
| -- then |
| -- Reraise_Occurrence (Saved_Exception); |
| -- end if; |
| -- end _finalization_controller; |
| |
| if Nkind (N) = N_Subprogram_Body |
| and then Present (Postconditions_Proc (Def_Ent)) |
| then |
| Fin_Controller_Stmts := New_List; |
| Fin_Controller_Decls := New_List; |
| |
| -- Build the 'Old finalizer |
| |
| Build_Finalizer_Helper |
| (N => N, |
| Clean_Stmts => Empty_List, |
| Mark_Id => Mark_Id, |
| Top_Decls => Top_Decls, |
| Defer_Abort => Defer_Abort, |
| Fin_Id => Fin_Old_Id, |
| Finalize_Old_Only => True); |
| |
| -- Create local declarations for _finalization_controller needed for |
| -- saving exceptions. |
| -- |
| -- Generate: |
| -- |
| -- Saved_Exception : Exception_Occurrence; |
| -- Raised_Post_Exception : Boolean := False; |
| -- Raised_Finalization_Exception : Boolean := False; |
| |
| Saved_Exception_Id := Make_Temporary (Loc, 'S'); |
| Raised_Post_Exception_Id := Make_Temporary (Loc, 'P'); |
| Raised_Finalization_Exception_Id := Make_Temporary (Loc, 'F'); |
| |
| Append_List_To (Fin_Controller_Decls, New_List ( |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Saved_Exception_Id, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)), |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Raised_Post_Exception_Id, |
| Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), |
| Expression => New_Occurrence_Of (Standard_False, Loc)), |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Raised_Finalization_Exception_Id, |
| Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), |
| Expression => New_Occurrence_Of (Standard_False, Loc)))); |
| |
| -- Call _finalizer and save any exceptions which occur |
| |
| -- Generate: |
| -- |
| -- begin |
| -- _finalizer; |
| -- exception |
| -- when others => |
| -- Raised_Finalization_Exception := True; |
| -- Save_Occurrence |
| -- (Saved_Exception, Get_Current_Excep.all); |
| -- end; |
| |
| if Present (Fin_Id) then |
| Append_To (Fin_Controller_Stmts, |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Fin_Id, Loc))), |
| Exception_Handlers => New_List ( |
| Make_Exception_Handler (Loc, |
| Exception_Choices => New_List ( |
| Make_Others_Choice (Loc)), |
| Statements => New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (Raised_Finalization_Exception_Id, Loc), |
| Expression => |
| New_Occurrence_Of (Standard_True, Loc)), |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Save_Occurrence), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of |
| (Saved_Exception_Id, Loc), |
| Make_Explicit_Dereference (Loc, |
| Prefix => |
| Make_Function_Call (Loc, |
| Name => |
| Make_Explicit_Dereference (Loc, |
| Prefix => |
| New_Occurrence_Of |
| (RTE (RE_Get_Current_Excep), |
| Loc)))))))))))); |
| end if; |
| |
| -- Create the call to postconditions based on the kind of the current |
| -- subprogram, and the type of the Result_Obj_For_Postcond. |
| |
| -- Generate: |
| -- |
| -- _postconditions (Result_Obj_For_Postcond[.all]); |
| -- |
| -- or |
| -- |
| -- _postconditions; |
| |
| if Ekind (Def_Ent) = E_Procedure then |
| Postconditions_Call := |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (Postconditions_Proc (Def_Ent), Loc)); |
| else |
| Postconditions_Call := |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (Postconditions_Proc (Def_Ent), Loc), |
| Parameter_Associations => New_List ( |
| (if Is_Elementary_Type (Etype (Def_Ent)) then |
| New_Occurrence_Of |
| (Get_Result_Object_For_Postcond |
| (Def_Ent), Loc) |
| else |
| Make_Explicit_Dereference (Loc, |
| New_Occurrence_Of |
| (Get_Result_Object_For_Postcond |
| (Def_Ent), Loc))))); |
| end if; |
| |
| -- Call _postconditions when no general finalization exceptions have |
| -- occurred taking care to enable the postconditions and save any |
| -- exception occurrences. |
| |
| -- Generate: |
| -- |
| -- if not Raised_Finalization_Exception |
| -- and then Return_Success_For_Postcond |
| -- then |
| -- begin |
| -- Postcond_Enabled := True; |
| -- _postconditions [(Result_Obj_For_Postcond[.all])]; |
| -- exception |
| -- when others => |
| -- Raised_Post_Exception := True; |
| -- Save_Occurrence |
| -- (Saved_Exception, Get_Current_Excep.all); |
| -- end; |
| -- end if; |
| |
| Append_To (Fin_Controller_Stmts, |
| Make_If_Statement (Loc, |
| Condition => |
| Make_And_Then (Loc, |
| Left_Opnd => |
| Make_Op_Not (Loc, |
| Right_Opnd => |
| New_Occurrence_Of |
| (Raised_Finalization_Exception_Id, Loc)), |
| Right_Opnd => |
| New_Occurrence_Of |
| (Get_Return_Success_For_Postcond (Def_Ent), Loc)), |
| Then_Statements => New_List ( |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (Get_Postcond_Enabled (Def_Ent), Loc), |
| Expression => |
| New_Occurrence_Of |
| (Standard_True, Loc)), |
| Postconditions_Call), |
| Exception_Handlers => New_List ( |
| Make_Exception_Handler (Loc, |
| Exception_Choices => New_List ( |
| Make_Others_Choice (Loc)), |
| Statements => New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (Raised_Post_Exception_Id, Loc), |
| Expression => |
| New_Occurrence_Of (Standard_True, Loc)), |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Save_Occurrence), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of |
| (Saved_Exception_Id, Loc), |
| Make_Explicit_Dereference (Loc, |
| Prefix => |
| Make_Function_Call (Loc, |
| Name => |
| Make_Explicit_Dereference (Loc, |
| Prefix => |
| New_Occurrence_Of |
| (RTE (RE_Get_Current_Excep), |
| Loc)))))))))))))); |
| |
| -- Call _finalizer_old and reraise any exception that occurred during |
| -- initial finalization within the exception handler. Otherwise, |
| -- propagate the current exception. |
| |
| -- Generate: |
| -- |
| -- begin |
| -- _finalizer_old; |
| -- exception |
| -- when others => |
| -- if Raised_Finalization_Exception then |
| -- Reraise_Occurrence (Saved_Exception); |
| -- end if; |
| -- raise; |
| -- end; |
| |
| if Present (Fin_Old_Id) then |
| Append_To (Fin_Controller_Stmts, |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Fin_Old_Id, Loc))), |
| Exception_Handlers => New_List ( |
| Make_Exception_Handler (Loc, |
| Exception_Choices => New_List ( |
| Make_Others_Choice (Loc)), |
| Statements => New_List ( |
| Make_If_Statement (Loc, |
| Condition => |
| New_Occurrence_Of |
| (Raised_Finalization_Exception_Id, Loc), |
| Then_Statements => New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Reraise_Occurrence), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of |
| (Saved_Exception_Id, Loc))))), |
| Make_Raise_Statement (Loc))))))); |
| end if; |
| |
| -- Once finalization is complete reraise any pending exceptions |
| |
| -- Generate: |
| -- |
| -- if Raised_Post_Exception |
| -- or else Raised_Finalization_Exception |
| -- then |
| -- Reraise_Occurrence (Saved_Exception); |
| -- end if; |
| |
| Append_To (Fin_Controller_Stmts, |
| Make_If_Statement (Loc, |
| Condition => |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| New_Occurrence_Of |
| (Raised_Post_Exception_Id, Loc), |
| Right_Opnd => |
| New_Occurrence_Of |
| (Raised_Finalization_Exception_Id, Loc)), |
| Then_Statements => New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of |
| (Saved_Exception_Id, Loc)))))); |
| |
| -- Make the finalization controller subprogram body and declaration. |
| |
| -- Generate: |
| -- procedure _finalization_controller; |
| -- |
| -- procedure _finalization_controller is |
| -- begin |
| -- [Fin_Controller_Stmts]; |
| -- end; |
| |
| Fin_Controller_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Name_uFinalization_Controller)); |
| |
| Fin_Controller_Spec := |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Fin_Controller_Id)); |
| |
| Fin_Controller_Body := |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => |
| Make_Defining_Identifier (Loc, Chars (Fin_Controller_Id))), |
| Declarations => Fin_Controller_Decls, |
| Handled_Statement_Sequence => |
| |