| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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 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_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 needed when certain temporary objects are created |
| -- by the compiler. These temporary objects are allocated on the secondary |
| -- stack and/or need finalization, and the transient scope is responsible |
| -- for finalizing the objects and reclaiming the memory of the secondary |
| -- stack at the appropriate time. They are generally objects allocated to |
| -- store the result of a function returning an unconstrained or controlled |
| -- value. Expressions needing to be wrapped in a transient scope may appear |
| -- in three different contexts which lead to 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. |
| |
| -------------------------------------------------- |
| -- 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 describes 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_Call (N : Node_Id; Fin_Id : Entity_Id); |
| -- N is a construct that contains a handled sequence of statements, Fin_Id |
| -- is the entity of a finalizer. Create an At_End handler that 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 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_Subp_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_Subp_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)); |
| |
| 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 -- |
| --------------------- |
| |
| procedure Build_Finalizer |
| (N : Node_Id; |
| Clean_Stmts : List_Id; |
| Mark_Id : Entity_Id; |
| Top_Decls : List_Id; |
| Defer_Abort : Boolean; |
| Fin_Id : out Entity_Id) |
| is |
| Acts_As_Clean : constant Boolean := |
| Present (Mark_Id) |
| or else |
| (Present (Clean_Stmts) |
| and then Is_Non_Empty_List (Clean_Stmts)); |
| |
| 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. |
| |
| Fin_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Name_uFinalizer)); |
| |
| -- The visibility semantics of AT_END handlers force a strange |
| -- separation of spec and body for stack-related finalizers: |
| |
| -- declare : Enclosing_Scope |
| -- procedure _finalizer; |
| -- begin |
| -- <controlled objects> |
| -- procedure _finalizer is |
| -- ... |
| -- at end |
| -- _finalizer; |
| -- end; |
| |
| -- Both spec and body are within the same construct and scope, but |
| -- the body is part of the handled sequence of statements. This |
| -- placement confuses the elaboration mechanism on targets where |
| -- AT_END handlers are expanded into "when all others" handlers: |
| |
| -- exception |
| -- when all others => |
| -- _finalizer; -- appears to require elab checks |
| -- at end |
| -- _finalizer; |
| -- end; |
| |
| -- Since the compiler guarantees that the body of a _finalizer is |
| -- always inserted in the same construct where the AT_END handler |
| -- resides, there is no need for elaboration checks. |
| |
| Set_Kill_Elaboration_Checks (Fin_Id); |
| |
| -- 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, except if the insertion point is already placed |
| -- after the construct, typically in the statement list. |
| |
| if Nkind (Last_Top_Level_Ctrl_Construct) in |
| N_Freeze_Entity | N_Package_Declaration | N_Package_Body |
| and then not |
| (List_Containing (Last_Top_Level_Ctrl_Construct) = Spec_Decls |
| and then Present (Stmts) |
| and then List_Containing (Finalizer_Insert_Nod) = Stmts) |
| 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 |
| -- Library-level tagged types |
| |
| if 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 |
| -- 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 unconstrained or tagged results, escalate the condition to |
| -- include the allocation format. Generate: |
| |
| -- if BIPallocform > Secondary_Stack'Pos |
| -- and then BIPfinalizationmaster /= null |
| -- then |
| |
| if Needs_BIP_Alloc_Form (Func_Id) 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; |
| |
| -- If the initialization is in the declaration, we're done, so |
| -- early return if we have no more statements or they have been |
| -- rewritten, which means that they were in the source code. |
| |
| elsif No (Stmt) or else Original_Node (Stmt) /= Stmt then |
| 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 |
| 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 := |
| Return_Applies_To (Scope (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 |
| |
| 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; |
| |
| -------------------------- |
| -- Build_Finalizer_Call -- |
| -------------------------- |
| |
| procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is |
| 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; |
| |
| -- If the construct to be cleaned up is a protected subprogram body, the |
| -- finalizer call needs to be associated with the block that 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; |
| |
| declare |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| Is_Protected_Subp_Body : constant Boolean := |
| Nkind (N) = N_Subprogram_Body |
| and then Is_Protected_Subprogram_Body (N); |
| -- True if N is the protected version of a subprogram that belongs to |
| -- a protected type. |
| |
| HSS : constant Node_Id := |
| (if Is_Protected_Subp_Body |
| then Handled_Statement_Sequence |
| (Last (Statements (Handled_Statement_Sequence (N)))) |
| else Handled_Statement_Sequence (N)); |
| |
| -- We attach the At_End_Proc to the HSS if this is an accept |
| -- statement or extended return statement. Also in the case of |
| -- a protected subprogram, because if Service_Entries raises an |
| -- exception, we do not lock the PO, so we also do not want to |
| -- unlock it. |
| |
| Use_HSS : constant Boolean := |
| Nkind (N) in N_Accept_Statement | N_Extended_Return_Statement |
| or else Is_Protected_Subp_Body; |
| |
| At_End_Proc_Bearer : constant Node_Id := (if Use_HSS then HSS else N); |
| begin |
| pragma Assert (No (At_End_Proc (At_End_Proc_Bearer))); |
| Set_At_End_Proc (At_End_Proc_Bearer, New_Occurrence_Of (Fin_Id, Loc)); |
| -- Attach reference to finalizer to tree, for LLVM use |
| Set_Parent (At_End_Proc (At_End_Proc_Bearer), At_End_Proc_Bearer); |
| Analyze (At_End_Proc (At_End_Proc_Bearer)); |
| Expand_At_End_Handler (At_End_Proc_Bearer, Empty); |
| end; |
| end Build_Finalizer_Call; |
| |
| --------------------- |
| -- Build_Late_Proc -- |
| --------------------- |
| |
| procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is |
| begin |
| for Final_Prim in Name_Of'Range loop |
| if Name_Of (Final_Prim) = Nam then |
| Set_TSS (Typ, |
| Make_Deep_Proc |
| (Prim => Final_Prim, |
| Typ => Typ, |
| Stmts => Make_Deep_Record_Body (Final_Prim, Typ))); |
| end if; |
| end loop; |
| end Build_Late_Proc; |
| |
| ------------------------------- |
| -- Build_Object_Declarations -- |
| ------------------------------- |
| |
| procedure Build_Object_Declarations |
| (Data : out Finalization_Exception_Data; |
| Decls : List_Id; |
| Loc : Source_Ptr; |
| For_Package : Boolean := False) |
| is |
| Decl : Node_Id; |
| |
| Dummy : Entity_Id; |
| -- This variable captures an unused dummy internal entity, see the |
| -- comment associated with its use. |
| |
| begin |
| pragma Assert (Decls /= No_List); |
| |
| -- Always set the proper location as it may be needed even when |
| -- exception propagation is forbidden. |
| |
| Data.Loc := Loc; |
| |
| if Restriction_Active (No_Exception_Propagation) then |
| Data.Abort_Id := Empty; |
| Data.E_Id := Empty; |
| Data.Raised_Id := Empty; |
| return; |
| end if; |
| |
| Data.Raised_Id := Make_Temporary (Loc, 'R'); |
| |
| -- In certain scenarios, finalization can be triggered by an abort. If |
| -- the finalization itself fails and raises an exception, the resulting |
| -- Program_Error must be supressed and replaced by an abort signal. In |
| -- order to detect this scenario, save the state of entry into the |
| -- finalization code. |
| |
| -- This is not needed for library-level finalizers as they are called by |
| -- the environment task and cannot be aborted. |
| |
| if not For_Package then |
| if Abort_Allowed then |
| Data.Abort_Id := Make_Temporary (Loc, 'A'); |
| |
| -- Generate: |
| -- Abort_Id : constant Boolean := <A_Expr>; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Data.Abort_Id, |
| Constant_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Boolean, Loc), |
| Expression => |
| New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc))); |
| |
| -- Abort is not required |
| |
| else |
| -- Generate a dummy entity to ensure that the internal symbols are |
| -- in sync when a unit is compiled with and without aborts. |
| |
| Dummy := Make_Temporary (Loc, 'A'); |
| Data.Abort_Id := Empty; |
| end if; |
| |
| -- Library-level finalizers |
| |
| else |
| Data.Abort_Id := Empty; |
| end if; |
| |
| if Exception_Extra_Info then |
| Data.E_Id := Make_Temporary (Loc, 'E'); |
| |
| -- Generate: |
| -- E_Id : Exception_Occurrence; |
| |
| Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Data.E_Id, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)); |
| Set_No_Initialization (Decl); |
| |
| Append_To (Decls, Decl); |
| |
| else |
| Data.E_Id := Empty; |
| end if; |
| |
| -- Generate: |
| -- Raised_Id : Boolean := False; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Data.Raised_Id, |
| Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), |
| Expression => New_Occurrence_Of (Standard_False, Loc))); |
| |
| if Debug_Generated_Code then |
| Set_Debug_Info_Needed (Data.Raised_Id); |
| end if; |
| end Build_Object_Declarations; |
| |
| --------------------------- |
| -- Build_Raise_Statement -- |
| --------------------------- |
| |
| function Build_Raise_Statement |
| (Data : Finalization_Exception_Data) return Node_Id |
| is |
| Stmt : Node_Id; |
| Expr : Node_Id; |
| |
| begin |
| -- Standard run-time use the specialized routine |
| -- Raise_From_Controlled_Operation. |
| |
| if Exception_Extra_Info |
| and then RTE_Available (RE_Raise_From_Controlled_Operation) |
| then |
| Stmt := |
| Make_Procedure_Call_Statement (Data.Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Raise_From_Controlled_Operation), Data.Loc), |
| Parameter_Associations => |
| New_List (New_Occurrence_Of (Data.E_Id, Data.Loc))); |
| |
| -- Restricted run-time: exception messages are not supported and hence |
| -- Raise_From_Controlled_Operation is not supported. Raise Program_Error |
| -- instead. |
| |
| else |
| Stmt := |
| Make_Raise_Program_Error (Data.Loc, |
| Reason => PE_Finalize_Raised_Exception); |
| end if; |
| |
| -- Generate: |
| |
| -- Raised_Id and then not Abort_Id |
| -- <or> |
| -- Raised_Id |
| |
| Expr := New_Occurrence_Of (Data.Raised_Id, Data.Loc); |
| |
| if Present (Data.Abort_Id) then |
| Expr := Make_And_Then (Data.Loc, |
| Left_Opnd => Expr, |
| Right_Opnd => |
| Make_Op_Not (Data.Loc, |
| Right_Opnd => New_Occurrence_Of (Data.Abort_Id, Data.Loc))); |
| end if; |
| |
| -- Generate: |
| |
| -- if Raised_Id and then not Abort_Id then |
| -- Raise_From_Controlled_Operation (E_Id); |
| -- <or> |
| -- raise Program_Error; -- restricted runtime |
| -- end if; |
| |
| return |
| Make_If_Statement (Data.Loc, |
| Condition => Expr, |
| Then_Statements => New_List (Stmt)); |
| end Build_Raise_Statement; |
| |
| ----------------------------- |
| -- Build_Record_Deep_Procs -- |
| ----------------------------- |
| |
| procedure Build_Record_Deep_Procs (Typ : Entity_Id) is |
| begin |
| Set_TSS (Typ, |
| Make_Deep_Proc |
| (Prim => Initialize_Case, |
| Typ => Typ, |
| Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); |
| |
| if not Is_Limited_View (Typ) then |
| Set_TSS (Typ, |
| Make_Deep_Proc |
| (Prim => Adjust_Case, |
| Typ => Typ, |
| Stmts => Make_Deep_Record_Body (Adjust_Case, Typ))); |
| end if; |
| |
| -- Do not generate Deep_Finalize and Finalize_Address if finalization is |
| -- suppressed since these routine will not be used. |
| |
| if not Restriction_Active (No_Finalization) then |
| Set_TSS (Typ, |
| Make_Deep_Proc |
| (Prim => Finalize_Case, |
| Typ => Typ, |
| Stmts => Make_Deep_Record_Body (Finalize_Case, Typ))); |
| |
| -- Create TSS primitive Finalize_Address (unless CodePeer_Mode) |
| |
| if not CodePeer_Mode then |
| Set_TSS (Typ, |
| Make_Deep_Proc |
| (Prim => Address_Case, |
| Typ => Typ, |
| Stmts => Make_Deep_Record_Body (Address_Case, Typ))); |
| end if; |
| end if; |
| end Build_Record_Deep_Procs; |
| |
| ------------------- |
| -- Cleanup_Array -- |
| ------------------- |
| |
| function Cleanup_Array |
| (N : Node_Id; |
| Obj : Node_Id; |
| Typ : Entity_Id) return List_Id |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| Index_List : constant List_Id := New_List; |
| |
| function Free_Component return List_Id; |
| -- Generate the code to finalize the task or protected subcomponents |
| -- of a single component of the array. |
| |
| function Free_One_Dimension (Dim : Int) return List_Id; |
| -- Generate a loop over one dimension of the array |
| |
| -------------------- |
| -- Free_Component -- |
| -------------------- |
| |
| function Free_Component return List_Id is |
| Stmts : List_Id := New_List; |
| Tsk : Node_Id; |
| C_Typ : constant Entity_Id := Component_Type (Typ); |
| |
| begin |
| -- Component type is known to contain tasks or protected objects |
| |
| Tsk := |
| Make_Indexed_Component (Loc, |
| Prefix => Duplicate_Subexpr_No_Checks (Obj), |
| Expressions => Index_List); |
| |
| Set_Etype (Tsk, C_Typ); |
| |
| if Is_Task_Type (C_Typ) then |
| Append_To (Stmts, Cleanup_Task (N, Tsk)); |
| |
| elsif Is_Simple_Protected_Type (C_Typ) then |
| Append_To (Stmts, Cleanup_Protected_Object (N, Tsk)); |
| |
| elsif Is_Record_Type (C_Typ) then |
| Stmts := Cleanup_Record (N, Tsk, C_Typ); |
| |
| elsif Is_Array_Type (C_Typ) then |
| Stmts := Cleanup_Array (N, Tsk, C_Typ); |
| end if; |
| |
| return Stmts; |
| end Free_Component; |
| |
| ------------------------ |
| -- Free_One_Dimension -- |
| ------------------------ |
| |
| function Free_One_Dimension (Dim : Int) return List_Id is |
| Index : Entity_Id; |
| |
| begin |
| if Dim > Number_Dimensions (Typ) then |
| return Free_Component; |
| |
| -- Here we generate the required loop |
| |
| else |
| Index := Make_Temporary (Loc, 'J'); |
| Append (New_Occurrence_Of (Index, Loc), Index_List); |
| |
| return New_List ( |
| Make_Implicit_Loop_Statement (N, |
| Identifier => Empty, |
| Iteration_Scheme => |
| Make_Iteration_Scheme (Loc, |
| Loop_Parameter_Specification => |
| Make_Loop_Parameter_Specification (Loc, |
| Defining_Identifier => Index, |
| Discrete_Subtype_Definition => |
| Make_Attribute_Reference (Loc, |
| Prefix => Duplicate_Subexpr (Obj), |
| Attribute_Name => Name_Range, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, Dim))))), |
| Statements => Free_One_Dimension (Dim + 1))); |
| end if; |
| end Free_One_Dimension; |
| |
| -- Start of processing for Cleanup_Array |
| |
| begin |
| return Free_One_Dimension (1); |
| end Cleanup_Array; |
| |
| -------------------- |
| -- Cleanup_Record -- |
| -------------------- |
| |
| function Cleanup_Record |
| (N : Node_Id; |
| Obj : Node_Id; |
| Typ : Entity_Id) return List_Id |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| Stmts : constant List_Id := New_List; |
| U_Typ : constant Entity_Id := Underlying_Type (Typ); |
| |
| Comp : Entity_Id; |
| Tsk : Node_Id; |
| |
| begin |
| if Has_Discriminants (U_Typ) |
| and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration |
| and then Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition |
| and then |
| Present |
| (Variant_Part (Component_List (Type_Definition (Parent (U_Typ))))) |
| then |
| -- For now, do not attempt to free a component that may appear in a |
| -- variant, and instead issue a warning. Doing this "properly" would |
| -- require building a case statement and would be quite a mess. Note |
| -- that the RM only requires that free "work" for the case of a task |
| -- access value, so already we go way beyond this in that we deal |
| -- with the array case and non-discriminated record cases. |
| |
| Error_Msg_N |
| ("task/protected object in variant record will not be freed??", N); |
| return New_List (Make_Null_Statement (Loc)); |
| end if; |
| |
| Comp := First_Component (U_Typ); |
| while Present (Comp) loop |
| if Chars (Comp) /= Name_uParent |
| and then (Has_Task (Etype (Comp)) |
| or else Has_Simple_Protected_Object (Etype (Comp))) |
| then |
| Tsk := |
| Make_Selected_Component (Loc, |
| Prefix => Duplicate_Subexpr_No_Checks (Obj), |
| Selector_Name => New_Occurrence_Of (Comp, Loc)); |
| Set_Etype (Tsk, Etype (Comp)); |
| |
| if Is_Task_Type (Etype (Comp)) then |
| Append_To (Stmts, Cleanup_Task (N, Tsk)); |
| |
| elsif Is_Simple_Protected_Type (Etype (Comp)) then |
| Append_To (Stmts, Cleanup_Protected_Object (N, Tsk)); |
| |
| elsif Is_Record_Type (Etype (Comp)) then |
| |
| -- Recurse, by generating the prefix of the argument to the |
| -- eventual cleanup call. |
| |
| Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp))); |
| |
| elsif Is_Array_Type (Etype (Comp)) then |
| Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp))); |
| end if; |
| end if; |
| |
| Next_Component (Comp); |
| end loop; |
| |
| return Stmts; |
| end Cleanup_Record; |
| |
| ------------------------------ |
| -- Cleanup_Protected_Object -- |
| ------------------------------ |
| |
| function Cleanup_Protected_Object |
| (N : Node_Id; |
| Ref : Node_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| begin |
| -- For restricted run-time libraries (Ravenscar), tasks are |
| -- non-terminating, and protected objects can only appear at library |
| -- level, so we do not want finalization of protected objects. |
| |
| if Restricted_Profile then |
| return Empty; |
| |
| else |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Finalize_Protection), Loc), |
| Parameter_Associations => New_List (Concurrent_Ref (Ref))); |
| end if; |
| end Cleanup_Protected_Object; |
| |
| ------------------ |
| -- Cleanup_Task -- |
| ------------------ |
| |
| function Cleanup_Task |
| (N : Node_Id; |
| Ref : Node_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| begin |
| -- For restricted run-time libraries (Ravenscar), tasks are |
| -- non-terminating and they can only appear at library level, |
| -- so we do not want finalization of task objects. |
| |
| if Restricted_Profile then |
| return Empty; |
| |
| else |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Free_Task), Loc), |
| Parameter_Associations => New_List (Concurrent_Ref (Ref))); |
| end if; |
| end Cleanup_Task; |
| |
| -------------------------------------- |
| -- Check_Unnesting_Elaboration_Code -- |
| -------------------------------------- |
| |
| procedure Check_Unnesting_Elaboration_Code (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Block_Elab_Proc : Entity_Id := Empty; |
| |
| procedure Set_Block_Elab_Proc; |
| -- Create a defining identifier for a procedure that will replace |
| -- a block with nested subprograms (unless it has already been created, |
| -- in which case this is a no-op). |
| |
| procedure Set_Block_Elab_Proc is |
| begin |
| if No (Block_Elab_Proc) then |
| Block_Elab_Proc := Make_Temporary (Loc, 'I'); |
| end if; |
| end Set_Block_Elab_Proc; |
| |
| procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id); |
| -- Find entities in the elaboration code of a library package body that |
| -- contain or represent a subprogram body. A body can appear within a |
| -- block or a loop or can appear by itself if generated for an object |
| -- declaration that involves controlled actions. The first such entity |
| -- forces creation of a new procedure entity (via Set_Block_Elab_Proc) |
| -- that will be used to reset the scopes of all entities that become |
| -- local to the new elaboration procedure. This is needed for subsequent |
| -- unnesting actions, which depend on proper setting of the Scope links |
| -- to determine the nesting level of each subprogram. |
| |
| ----------------------- |
| -- Find_Local_Scope -- |
| ----------------------- |
| |
| procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id) is |
| Id : Entity_Id; |
| Stat : Node_Id; |
| Node : Node_Id; |
| |
| begin |
| Stat := First (L); |
| while Present (Stat) loop |
| case Nkind (Stat) is |
| when N_Block_Statement => |
| if Present (Identifier (Stat)) then |
| Id := Entity (Identifier (Stat)); |
| |
| -- The Scope of this block needs to be reset to the new |
| -- procedure if the block contains nested subprograms. |
| |
| if Present (Id) and then Contains_Subprogram (Id) then |
| Set_Block_Elab_Proc; |
| Set_Scope (Id, Block_Elab_Proc); |
| end if; |
| end if; |
| |
| when N_Loop_Statement => |
| Id := Entity (Identifier (Stat)); |
| |
| if Present (Id) and then Contains_Subprogram (Id) then |
| if Scope (Id) = Current_Scope then |
| Set_Block_Elab_Proc; |
| Set_Scope (Id, Block_Elab_Proc); |
| end if; |
| end if; |
| |
| -- We traverse the loop's statements as well, which may |
| -- include other block (etc.) statements that need to have |
| -- their Scope set to Block_Elab_Proc. (Is this really the |
| -- case, or do such nested blocks refer to the loop scope |
| -- rather than the loop's enclosing scope???.) |
| |
| Reset_Scopes_To_Block_Elab_Proc (Statements (Stat)); |
| |
| when N_If_Statement => |
| Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Stat)); |
| Reset_Scopes_To_Block_Elab_Proc (Else_Statements (Stat)); |
| |
| Node := First (Elsif_Parts (Stat)); |
| while Present (Node) loop |
| Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Node)); |
| Next (Node); |
| end loop; |
| |
| when N_Case_Statement => |
| Node := First (Alternatives (Stat)); |
| while Present (Node) loop |
| Reset_Scopes_To_Block_Elab_Proc (Statements (Node)); |
| Next (Node); |
| end loop; |
| |
| -- Reset the Scope of a subprogram occurring at the top level |
| |
| when N_Subprogram_Body => |
| Id := Defining_Entity (Stat); |
| |
| Set_Block_Elab_Proc; |
| Set_Scope (Id, Block_Elab_Proc); |
| |
| when others => |
| null; |
| end case; |
| |
| Next (Stat); |
| end loop; |
| end Reset_Scopes_To_Block_Elab_Proc; |
| |
| -- Local variables |
| |
| H_Seq : constant Node_Id := Handled_Statement_Sequence (N); |
| Elab_Body : Node_Id; |
| Elab_Call : Node_Id; |
| |
| -- Start of processing for Check_Unnesting_Elaboration_Code |
| |
| begin |
| if Present (H_Seq) then |
| Reset_Scopes_To_Block_Elab_Proc (Statements (H_Seq)); |
| |
| -- There may be subprograms declared in the exception handlers |
| -- of the current body. |
| |
| if Present (Exception_Handlers (H_Seq)) then |
| declare |
| Handler : Node_Id := First (Exception_Handlers (H_Seq)); |
| begin |
| while Present (Handler) loop |
| Reset_Scopes_To_Block_Elab_Proc (Statements (Handler)); |
| |
| Next (Handler); |
| end loop; |
| end; |
| end if; |
| |
| if Present (Block_Elab_Proc) then |
| Elab_Body := |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Block_Elab_Proc), |
| Declarations => New_List, |
| Handled_Statement_Sequence => |
| Relocate_Node (Handled_Statement_Sequence (N))); |
| |
| Elab_Call := |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Block_Elab_Proc, Loc)); |
| |
| Append_To (Declarations (N), Elab_Body); |
| Analyze (Elab_Body); |
| Set_Has_Nested_Subprogram (Block_Elab_Proc); |
| |
| Set_Handled_Statement_Sequence (N, |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Elab_Call))); |
| |
| Analyze (Elab_Call); |
| |
| -- Could we reset the scopes of entities associated with the new |
| -- procedure here via a loop over entities rather than doing it in |
| -- the recursive Reset_Scopes_To_Elab_Proc procedure??? |
| end if; |
| end if; |
| end Check_Unnesting_Elaboration_Code; |
| |
| --------------------------------------- |
| -- Check_Unnesting_In_Decls_Or_Stmts -- |
| --------------------------------------- |
| |
| procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id) is |
| Decl_Or_Stmt : Node_Id; |
| |
| begin |
| if Unnest_Subprogram_Mode |
| and then Present (Decls_Or_Stmts) |
| then |
| Decl_Or_Stmt := First (Decls_Or_Stmts); |
| while Present (Decl_Or_Stmt) loop |
| if Nkind (Decl_Or_Stmt) = N_Block_Statement |
| and then Contains_Subprogram (Entity (Identifier (Decl_Or_Stmt))) |
| then |
| Unnest_Block (Decl_Or_Stmt); |
| |
| -- If-statements may contain subprogram bodies at the outer level |
| -- of their statement lists, and the subprograms may make up-level |
| -- references (such as to objects declared in the same statement |
| -- list). Unlike block and loop cases, however, we don't have an |
| -- entity on which to test the Contains_Subprogram flag, so |
| -- Unnest_If_Statement must traverse the statement lists to |
| -- determine whether there are nested subprograms present. |
| |
| elsif Nkind (Decl_Or_Stmt) = N_If_Statement then |
| Unnest_If_Statement (Decl_Or_Stmt); |
| |
| elsif Nkind (Decl_Or_Stmt) = N_Loop_Statement then |
| declare |
| Id : constant Entity_Id := |
| Entity (Identifier (Decl_Or_Stmt)); |
| |
| begin |
| -- When a top-level loop within declarations of a library |
| -- package spec or body contains nested subprograms, we wrap |
| -- it in a procedure to handle possible up-level references |
| -- to entities associated with the loop (such as loop |
| -- parameters). |
| |
| if Present (Id) and then Contains_Subprogram (Id) then |
| Unnest_Loop (Decl_Or_Stmt); |
| end if; |
| end; |
| |
| elsif Nkind (Decl_Or_Stmt) = N_Package_Declaration |
| and then not Modify_Tree_For_C |
| then |
| Check_Unnesting_In_Decls_Or_Stmts |
| (Visible_Declarations (Specification (Decl_Or_Stmt))); |
| Check_Unnesting_In_Decls_Or_Stmts |
| (Private_Declarations (Specification (Decl_Or_Stmt))); |
| |
| elsif Nkind (Decl_Or_Stmt) = N_Package_Body |
| and then not Modify_Tree_For_C |
| then |
| Check_Unnesting_In_Decls_Or_Stmts (Declarations (Decl_Or_Stmt)); |
| if Present (Statements |
| (Handled_Statement_Sequence (Decl_Or_Stmt))) |
| then |
| Check_Unnesting_In_Decls_Or_Stmts (Statements |
| (Handled_Statement_Sequence (Decl_Or_Stmt))); |
| Check_Unnesting_In_Handlers (Decl_Or_Stmt); |
| end if; |
| end if; |
| |
| Next (Decl_Or_Stmt); |
| end loop; |
| end if; |
| end Check_Unnesting_In_Decls_Or_Stmts; |
| |
| --------------------------------- |
| -- Check_Unnesting_In_Handlers -- |
| --------------------------------- |
| |
| procedure Check_Unnesting_In_Handlers (N : Node_Id) is |
| Stmt_Seq : constant Node_Id := Handled_Statement_Sequence (N); |
| |
| begin |
| if Present (Stmt_Seq) |
| and then Present (Exception_Handlers (Stmt_Seq)) |
| then |
| declare |
| Handler : Node_Id := First (Exception_Handlers (Stmt_Seq)); |
| begin |
| while Present (Handler) loop |
| if Present (Statements (Handler)) then |
| Check_Unnesting_In_Decls_Or_Stmts (Statements (Handler)); |
| end if; |
| |
| Next (Handler); |
| end loop; |
| end; |
| end if; |
| end Check_Unnesting_In_Handlers; |
| |
| ------------------------------ |
| -- Check_Visibly_Controlled -- |
| ------------------------------ |
| |
| procedure Check_Visibly_Controlled |
| (Prim : Final_Primitives; |
| Typ : Entity_Id; |
| E : in out Entity_Id; |
| Cref : in out Node_Id) |
| is |
| Parent_Type : Entity_Id; |
| Op : Entity_Id; |
| |
| begin |
| if Is_Derived_Type (Typ) |
| and then Comes_From_Source (E) |
| and then No (Overridden_Operation (E)) |
| then |
| -- We know that the explicit operation on the type does not override |
| -- the inherited operation of the parent, and that the derivation |
| -- is from a private type that is not visibly controlled. |
| |
| Parent_Type := Etype (Typ); |
| Op := Find_Optional_Prim_Op (Parent_Type, Name_Of (Prim)); |
| |
| if Present (Op) then |
| E := Op; |
| |
| -- Wrap the object to be initialized into the proper |
| -- unchecked conversion, to be compatible with the operation |
| -- to be called. |
| |
| if Nkind (Cref) = N_Unchecked_Type_Conversion then |
| Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref)); |
| else |
| Cref := Unchecked_Convert_To (Parent_Type, Cref); |
| end if; |
| end if; |
| end if; |
| end Check_Visibly_Controlled; |
| |
| -------------------------- |
| -- Contains_Subprogram -- |
| -------------------------- |
| |
| function Contains_Subprogram (Blk : Entity_Id) return Boolean is |
| E : Entity_Id; |
| |
| begin |
| E := First_Entity (Blk); |
| |
| while Present (E) loop |
| if Is_Subprogram (E) then |
| return True; |
| |
| elsif Ekind (E) in E_Block | E_Loop |
| and then Contains_Subprogram (E) |
| then |
| return True; |
| end if; |
| |
| Next_Entity (E); |
| end loop; |
| |
| return False; |
| end Contains_Subprogram; |
| |
| ------------------ |
| -- Convert_View -- |
| ------------------ |
| |
| function Convert_View |
| (Proc : Entity_Id; |
| Arg : Node_Id; |
| Ind : Pos := 1) return Node_Id |
| is |
| Fent : Entity_Id := First_Entity (Proc); |
| Ftyp : Entity_Id; |
| Atyp : Entity_Id; |
| |
| begin |
| for J in 2 .. Ind loop |
| Next_Entity (Fent); |
| end loop; |
| |
| Ftyp := Etype (Fent); |
| |
| if Nkind (Arg) in N_Type_Conversion | N_Unchecked_Type_Conversion then |
| Atyp := Entity (Subtype_Mark (Arg)); |
| else |
| Atyp := Etype (Arg); |
| end if; |
| |
| if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then |
| return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg); |
| |
| elsif Ftyp /= Atyp |
| and then Present (Atyp) |
| and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp)) |
| and then Base_Type (Underlying_Type (Atyp)) = |
| Base_Type (Underlying_Type (Ftyp)) |
| then |
| return Unchecked_Convert_To (Ftyp, Arg); |
| |
| -- If the argument is already a conversion, as generated by |
| -- Make_Init_Call, set the target type to the type of the formal |
| -- directly, to avoid spurious typing problems. |
| |
| elsif Nkind (Arg) in N_Unchecked_Type_Conversion | N_Type_Conversion |
| and then not Is_Class_Wide_Type (Atyp) |
| then |
| Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg))); |
| Set_Etype (Arg, Ftyp); |
| return Arg; |
| |
| -- Otherwise, introduce a conversion when the designated object |
| -- has a type derived from the formal of the controlled routine. |
| |
| elsif Is_Private_Type (Ftyp) |
| and then Present (Atyp) |
| and then Is_Derived_Type (Underlying_Type (Base_Type (Atyp))) |
| then |
| return Unchecked_Convert_To (Ftyp, Arg); |
| |
| else |
| return Arg; |
| end if; |
| end Convert_View; |
| |
| ------------------------------- |
| -- Establish_Transient_Scope -- |
| ------------------------------- |
| |
| -- This procedure is called each time a transient block has to be inserted |
| -- that is to say for each call to a function with unconstrained or tagged |
| -- result. It creates a new scope on the scope stack in order to enclose |
| -- all transient variables generated. |
| |
| procedure Establish_Transient_Scope |
| (N : Node_Id; |
| Manage_Sec_Stack : Boolean) |
| is |
| function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean; |
| -- Determine whether arbitrary Id denotes a package or subprogram [body] |
| |
| function Find_Enclosing_Transient_Scope return Entity_Id; |
| -- Examine the scope stack looking for the nearest enclosing transient |
| -- scope within the innermost enclosing package or subprogram. Return |
| -- Empty if no such scope exists. |
| |
| function Find_Transient_Context (N : Node_Id) return Node_Id; |
| -- Locate a suitable context for arbitrary node N which may need to be |
| -- serviced by a transient scope. Return Empty if no suitable context |
| -- is available. |
| |
| procedure Delegate_Sec_Stack_Management; |
| -- Move the management of the secondary stack to the nearest enclosing |
| -- suitable scope. |
| |
| procedure Create_Transient_Scope (Context : Node_Id); |
| -- Place a new scope on the scope stack in order to service construct |
| -- Context. Context is the node found by Find_Transient_Context. The |
| -- new scope may also manage the secondary stack. |
| |
| ---------------------------- |
| -- Create_Transient_Scope -- |
| ---------------------------- |
| |
| procedure Create_Transient_Scope (Context : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| Iter_Loop : Entity_Id; |
| Trans_Scop : constant Entity_Id := |
| New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); |
| |
| begin |
| Set_Etype (Trans_Scop, Standard_Void_Type); |
| |
| -- Push a new scope, and set its Node_To_Be_Wrapped and Is_Transient |
| -- fields. |
| |
| Push_Scope (Trans_Scop); |
| Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := Context; |
| Set_Scope_Is_Transient; |
| |
| -- The transient scope must also manage the secondary stack |
| |
| if Manage_Sec_Stack then |
| Set_Uses_Sec_Stack (Trans_Scop); |
| Check_Restriction (No_Secondary_Stack, N); |
| |
| -- The expansion of iterator loops generates references to objects |
| -- in order to extract elements from a container: |
| |
| -- Ref : Reference_Type_Ptr := Reference (Container, Cursor); |
| -- Obj : <object type> renames Ref.all.Element.all; |
| |
| -- These references are controlled and returned on the secondary |
| -- stack. A new reference is created at each iteration of the loop |
| -- and as a result it must be finalized and the space occupied by |
| -- it on the secondary stack reclaimed at the end of the current |
| -- iteration. |
| |
| -- When the context that requires a transient scope is a call to |
| -- routine Reference, the node to be wrapped is the source object: |
| |
| -- for Obj of Container loop |
| |
| -- Routine Wrap_Transient_Declaration however does not generate |
| -- a physical block as wrapping a declaration will kill it too |
| -- early. To handle this peculiar case, mark the related iterator |
| -- loop as requiring the secondary stack. This signals the |
| -- finalization machinery to manage the secondary stack (see |
| -- routine Process_Statements_For_Controlled_Objects). |
| |
| Iter_Loop := Find_Enclosing_Iterator_Loop (Trans_Scop); |
| |
| if Present (Iter_Loop) then |
| Set_Uses_Sec_Stack (Iter_Loop); |
| end if; |
| end if; |
| |
| if Debug_Flag_W then |
| Write_Str (" <Transient>"); |
| Write_Eol; |
| end if; |
| end Create_Transient_Scope; |
| |
| ----------------------------------- |
| -- Delegate_Sec_Stack_Management -- |
| ----------------------------------- |
| |
| procedure Delegate_Sec_Stack_Management is |
| begin |
| for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop |
| declare |
| Scope : Scope_Stack_Entry renames Scope_Stack.Table (Index); |
| begin |
| -- Prevent the search from going too far or within the scope |
| -- space of another unit. |
| |
| if Scope.Entity = Standard_Standard then |
| return; |
| |
| -- No transient scope should be encountered during the |
| -- traversal because Establish_Transient_Scope should have |
| -- already handled this case. |
| |
| elsif Scope.Is_Transient then |
| raise Program_Error; |
| |
| -- The construct that requires secondary stack management is |
| -- always enclosed by a package or subprogram scope. |
| |
| elsif Is_Package_Or_Subprogram (Scope.Entity) then |
| Set_Uses_Sec_Stack (Scope.Entity); |
| Check_Restriction (No_Secondary_Stack, N); |
| |
| return; |
| end if; |
| end; |
| end loop; |
| |
| -- At this point no suitable scope was found. This should never occur |
| -- because a construct is always enclosed by a compilation unit which |
| -- has a scope. |
| |
| pragma Assert (False); |
| end Delegate_Sec_Stack_Management; |
| |
| ------------------------------------ |
| -- Find_Enclosing_Transient_Scope -- |
| ------------------------------------ |
| |
| function Find_Enclosing_Transient_Scope return Entity_Id is |
| begin |
| for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop |
| declare |
| Scope : Scope_Stack_Entry renames Scope_Stack.Table (Index); |
| begin |
| -- Prevent the search from going too far or within the scope |
| -- space of another unit. |
| |
| if Scope.Entity = Standard_Standard |
| or else Is_Package_Or_Subprogram (Scope.Entity) |
| then |
| exit; |
| |
| elsif Scope.Is_Transient then |
| return Scope.Entity; |
| end if; |
| end; |
| end loop; |
| |
| return Empty; |
| end Find_Enclosing_Transient_Scope; |
| |
| ---------------------------- |
| -- Find_Transient_Context -- |
| ---------------------------- |
| |
| function Find_Transient_Context (N : Node_Id) return Node_Id is |
| Curr : Node_Id := N; |
| Prev : Node_Id := Empty; |
| |
| begin |
| while Present (Curr) loop |
| case Nkind (Curr) is |
| |
| -- Declarations |
| |
| -- Declarations act as a boundary for a transient scope even if |
| -- they are not wrapped, see Wrap_Transient_Declaration. |
| |
| when N_Object_Declaration |
| | N_Object_Renaming_Declaration |
| | N_Subtype_Declaration |
| => |
| return Curr; |
| |
| -- Statements |
| |
| -- Statements and statement-like constructs act as a boundary |
| -- for a transient scope. |
| |
| when N_Accept_Alternative |
| | N_Attribute_Definition_Clause |
| | N_Case_Statement |
| | N_Case_Statement_Alternative |
| | N_Code_Statement |
| | N_Delay_Alternative |
| | N_Delay_Until_Statement |
| | N_Delay_Relative_Statement |
| | N_Discriminant_Association |
| | N_Elsif_Part |
| | N_Entry_Body_Formal_Part |
| | N_Exit_Statement |
| | N_If_Statement |
| | N_Iteration_Scheme |
| | N_Terminate_Alternative |
| => |
| pragma Assert (Present (Prev)); |
| return Prev; |
| |
| when N_Assignment_Statement => |
| return Curr; |
| |
| when N_Entry_Call_Statement |
| | N_Procedure_Call_Statement |
| => |
| -- When an entry or procedure call acts as the alternative |
| -- of a conditional or timed entry call, the proper context |
| -- is that of the alternative. |
| |
| if Nkind (Parent (Curr)) = N_Entry_Call_Alternative |
| and then Nkind (Parent (Parent (Curr))) in |
| N_Conditional_Entry_Call | N_Timed_Entry_Call |
| then |
| return Parent (Parent (Curr)); |
| |
| -- General case for entry or procedure calls |
| |
| else |
| return Curr; |
| end if; |
| |
| when N_Pragma => |
| |
| -- Pragma Check is not a valid transient context in |
| -- GNATprove mode because the pragma must remain unchanged. |
| |
| if GNATprove_Mode |
| and then Get_Pragma_Id (Curr) = Pragma_Check |
| then |
| return Empty; |
| |
| -- General case for pragmas |
| |
| else |
| return Curr; |
| end if; |
| |
| when N_Raise_Statement => |
| return Curr; |
| |
| when N_Simple_Return_Statement => |
| |
| -- A return statement is not a valid transient context when |
| -- the function itself requires transient scope management |
| -- because the result will be reclaimed too early. |
| |
| if Requires_Transient_Scope (Etype |
| (Return_Applies_To (Return_Statement_Entity (Curr)))) |
| then |
| return Empty; |
| |
| -- General case for return statements |
| |
| else |
| return Curr; |
| end if; |
| |
| -- Special |
| |
| when N_Attribute_Reference => |
| if Is_Procedure_Attribute_Name (Attribute_Name (Curr)) then |
| return Curr; |
| end if; |
| |
| -- An Ada 2012 iterator specification is not a valid context |
| -- because Analyze_Iterator_Specification already employs |
| -- special processing for it. |
| |
| when N_Iterator_Specification => |
| return Empty; |
| |
| when N_Loop_Parameter_Specification => |
| |
| -- An iteration scheme is not a valid context because |
| -- routine Analyze_Iteration_Scheme already employs |
| -- special processing. |
| |
| if Nkind (Parent (Curr)) = N_Iteration_Scheme then |
| return Empty; |
| else |
| return Parent (Curr); |
| end if; |
| |
| -- Termination |
| |
| -- The following nodes represent "dummy contexts" which do not |
| -- need to be wrapped. |
| |
| when N_Component_Declaration |
| | N_Discriminant_Specification |
| | N_Parameter_Specification |
| => |
| return Empty; |
| |
| -- If the traversal leaves a scope without having been able to |
| -- find a construct to wrap, something is going wrong, but this |
| -- can happen in error situations that are not detected yet |
| -- (such as a dynamic string in a pragma Export). |
| |
| when N_Block_Statement |
| | N_Entry_Body |
| | N_Package_Body |
| | N_Package_Declaration |
| | N_Protected_Body |
| | N_Subprogram_Body |
| | N_Task_Body |
| => |
| return Empty; |
| |
| -- Default |
| |
| when others => |
| null; |
| end case; |
| |
| Prev := Curr; |
| Curr := Parent (Curr); |
| end loop; |
| |
| return Empty; |
| end Find_Transient_Context; |
| |
| ------------------------------ |
| -- Is_Package_Or_Subprogram -- |
| ------------------------------ |
| |
| function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean is |
| begin |
| return Ekind (Id) in E_Entry |
| | E_Entry_Family |
| | E_Function |
| | E_Package |
| | E_Procedure |
| | E_Subprogram_Body; |
| end Is_Package_Or_Subprogram; |
| |
| -- Local variables |
| |
| Trans_Id : constant Entity_Id := Find_Enclosing_Transient_Scope; |
| Context : Node_Id; |
| |
| -- Start of processing for Establish_Transient_Scope |
| |
| begin |
| -- Do not create a new transient scope if there is already an enclosing |
| -- transient scope within the innermost enclosing package or subprogram. |
| |
| if Present (Trans_Id) then |
| |
| -- If the transient scope was requested for purposes of managing the |
| -- secondary stack, then the existing scope must perform this task. |
| |
| if Manage_Sec_Stack then |
| Set_Uses_Sec_Stack (Trans_Id); |
| end if; |
| |
| return; |
| end if; |
| |
| -- Find the construct that must be serviced by a new transient scope, if |
| -- it exists. |
| |
| Context := Find_Transient_Context (N); |
| |
| if Present (Context) then |
| if Nkind (Context) = N_Assignment_Statement then |
| |
| -- An assignment statement with suppressed controlled semantics |
| -- does not need a transient scope because finalization is not |
| -- desirable at this point. Note that No_Ctrl_Actions is also |
| -- set for non-controlled assignments to suppress dispatching |
| -- _assign. |
| |
| if No_Ctrl_Actions (Context) |
| and then Needs_Finalization (Etype (Name (Context))) |
| then |
| -- When a controlled component is initialized by a function |
| -- call, the result on the secondary stack is always assigned |
| -- to the component. Signal the nearest suitable scope that it |
| -- is safe to manage the secondary stack. |
| |
| if Manage_Sec_Stack and then Within_Init_Proc then |
| Delegate_Sec_Stack_Management; |
| end if; |
| |
| -- Otherwise the assignment is a normal transient context and thus |
| -- requires a transient scope. |
| |
| else |
| Create_Transient_Scope (Context); |
| end if; |
| |
| -- General case |
| |
| else |
| Create_Transient_Scope (Context); |
| end if; |
| end if; |
| end Establish_Transient_Scope; |
| |
| ---------------------------- |
| -- Expand_Cleanup_Actions -- |
| ---------------------------- |
| |
| procedure Expand_Cleanup_Actions (N : Node_Id) is |
| pragma Assert |
| (Nkind (N) in N_Block_Statement |
| | N_Subprogram_Body |
| | N_Task_Body |
| | N_Entry_Body |
| | N_Extended_Return_Statement); |
| |
| Scop : constant Entity_Id := Current_Scope; |
| |
| Is_Asynchronous_Call : constant Boolean := |
| Nkind (N) = N_Block_Statement |
| and then Is_Asynchronous_Call_Block (N); |
| Is_Master : constant Boolean := |
| Nkind (N) /= N_Extended_Return_Statement |
| and then Nkind (N) /= N_Entry_Body |
| and then Is_Task_Master (N); |
| Is_Protected_Subp_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; |
| |
| -- We mark the secondary stack if it is used in this construct, and |
| -- we're not returning a function result on the secondary stack, except |
| -- that a build-in-place function that might or might not return on the |
| -- secondary stack always needs a mark. A run-time test is required in |
| -- the case where the build-in-place function has a BIP_Alloc extra |
| -- parameter (see Create_Finalizer). |
| |
| Needs_Sec_Stack_Mark : constant Boolean := |
| (Uses_Sec_Stack (Scop) |
| and then |
| not Sec_Stack_Needed_For_Return (Scop)) |
| or else |
| (Is_Build_In_Place_Function (Scop) |
| and then Needs_BIP_Alloc_Form (Scop)); |
| |
| Needs_Custom_Cleanup : constant Boolean := |
| Nkind (N) = N_Block_Statement |
| and then Present (Cleanup_Actions (N)); |
| |
| Actions_Required : constant Boolean := |
| Requires_Cleanup_Actions (N, True) |
| or else Is_Asynchronous_Call |
| or else Is_Master |
| or else Is_Protected_Subp_Body |
| or else Is_Task_Allocation |
| or else Is_Task_Body |
| or else Needs_Sec_Stack_Mark |
| or else Needs_Custom_Cleanup; |
| |
| Loc : Source_Ptr; |
| Cln : List_Id; |
| |
| -- Start of processing for Expand_Cleanup_Actions |
| |
| begin |
| -- The current construct does not need any form of servicing |
| |
| if not Actions_Required then |
| return; |
| |
| -- If the current node is a rewritten task body and the descriptors have |
| -- not been delayed (due to some nested instantiations), do not generate |
| -- redundant cleanup actions. |
| |
| elsif Is_Task_Body |
| and then Nkind (N) = N_Subprogram_Body |
| and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N)) |
| then |
| return; |
| end if; |
| |
| -- If an extended return statement contains something like |
| -- |
| -- X := F (...); |
| -- |
| -- where F is a build-in-place function call returning a controlled |
| -- type, then a temporary object will be implicitly declared as part |
| -- of the statement list, and this will need cleanup. In such cases, |
| -- we transform: |
| -- |
| -- return Result : T := ... do |
| -- <statements> -- possibly with handlers |
| -- end return; |
| -- |
| -- into: |
| -- |
| -- return Result : T := ... do |
| -- declare -- no declarations |
| -- begin |
| -- <statements> -- possibly with handlers |
| -- end; -- no handlers |
| -- end return; |
| -- |
| -- So Expand_Cleanup_Actions will end up being called recursively on the |
| -- block statement. |
| |
| if Nkind (N) = N_Extended_Return_Statement then |
| declare |
| Block : constant Node_Id := |
| Make_Block_Statement (Sloc (N), |
| Declarations => Empty_List, |
| Handled_Statement_Sequence => |
| Handled_Statement_Sequence (N)); |
| begin |
| Set_Handled_Statement_Sequence (N, |
| Make_Handled_Sequence_Of_Statements (Sloc (N), |
| Statements => New_List (Block))); |
| |
| Analyze (Block); |
| end; |
| |
| -- Analysis of the block did all the work |
| |
| return; |
| end if; |
| |
| if Needs_Custom_Cleanup then |
| Cln := Cleanup_Actions (N); |
| else |
| Cln := No_List; |
| end if; |
| |
| if No (Declarations (N)) then |
| Set_Declarations (N, New_List); |
| end if; |
| |
| declare |
| Decls : constant List_Id := Declarations (N); |
| Fin_Id : Entity_Id; |
| Mark : Entity_Id := Empty; |
| begin |
| -- If we are generating expanded code for debugging purposes, use the |
| -- Sloc of the point of insertion for the cleanup code. The Sloc will |
| -- be updated subsequently to reference the proper line in .dg files. |
| -- If we are not debugging generated code, use No_Location instead, |
| -- so that no debug information is generated for the cleanup code. |
| -- This makes the behavior of the NEXT command in GDB monotonic, and |
| -- makes the placement of breakpoints more accurate. |
| |
| if Debug_Generated_Code then |
| Loc := Sloc (Scop); |
| else |
| Loc := No_Location; |
| end if; |
| |
| -- A task activation call has already been built for a task |
| -- allocation block. |
| |
| if not Is_Task_Allocation then |
| Build_Task_Activation_Call (N); |
| end if; |
| |
| if Is_Master then |
| Establish_Task_Master (N); |
| end if; |
| |
| -- If secondary stack is in use, generate: |
| -- |
| -- Mnn : constant Mark_Id := SS_Mark; |
| |
| if Needs_Sec_Stack_Mark then |
| Set_Uses_Sec_Stack (Scop, False); -- avoid duplicate SS marks |
| Mark := Make_Temporary (Loc, 'M'); |
| |
| declare |
| Mark_Call : constant Node_Id := Build_SS_Mark_Call (Loc, Mark); |
| begin |
| Prepend_To (Decls, Mark_Call); |
| Analyze (Mark_Call); |
| end; |
| end if; |
| |
| -- Generate finalization calls for all controlled objects appearing |
| -- in the statements of N. Add context specific cleanup for various |
| -- constructs. |
| |
| Build_Finalizer |
| (N => N, |
| Clean_Stmts => Build_Cleanup_Statements (N, Cln), |
| Mark_Id => Mark, |
| Top_Decls => Decls, |
| Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body |
| or else Is_Master, |
| Fin_Id => Fin_Id); |
| |
| if Present (Fin_Id) then |
| Build_Finalizer_Call (N, Fin_Id); |
| end if; |
| end; |
| end Expand_Cleanup_Actions; |
| |
| --------------------------- |
| -- Expand_N_Package_Body -- |
| --------------------------- |
| |
| -- Add call to Activate_Tasks if body is an activator (actual processing |
| -- is in chapter 9). |
| |
| -- Generate subprogram descriptor for elaboration routine |
| |
| -- Encode entity names in package body |
| |
| procedure Expand_N_Package_Body (N : Node_Id) is |
| Spec_Id : constant Entity_Id := Corresponding_Spec (N); |
| Fin_Id : Entity_Id; |
| |
| begin |
| -- This is done only for non-generic packages |
| |
| if Ekind (Spec_Id) = E_Package then |
| -- Build dispatch tables of library-level tagged types for bodies |
| -- that are not compilation units (see Analyze_Compilation_Unit), |
| -- except for instances because they have no N_Compilation_Unit. |
| |
| if Tagged_Type_Expansion |
| and then Is_Library_Level_Entity (Spec_Id) |
| and then (not Is_Compilation_Unit (Spec_Id) |
| or else Is_Generic_Instance (Spec_Id)) |
| then |
| Build_Static_Dispatch_Tables (N); |
| end if; |
| |
| Push_Scope (Spec_Id); |
| |
| Expand_CUDA_Package (N); |
| |
| Build_Task_Activation_Call (N); |
| |
| -- Verify the run-time semantics of pragma Initial_Condition at the |
| -- end of the body statements. |
| |
| Expand_Pragma_Initial_Condition (Spec_Id, N); |
| |
| -- If this is a library-level package and unnesting is enabled, |
| -- check for the presence of blocks with nested subprograms occurring |
| -- in elaboration code, and generate procedures to encapsulate the |
| -- blocks in case the nested subprograms make up-level references. |
| |
| if Unnest_Subprogram_Mode |
| and then |
| Is_Library_Level_Entity (Current_Scope) |
| then |
| Check_Unnesting_Elaboration_Code (N); |
| Check_Unnesting_In_Decls_Or_Stmts (Declarations (N)); |
| Check_Unnesting_In_Handlers (N); |
| end if; |
| |
| Pop_Scope; |
| end if; |
| |
| Set_Elaboration_Flag (N, Spec_Id); |
| Set_In_Package_Body (Spec_Id, False); |
| |
| -- Set to encode entity names in package body before gigi is called |
| |
| Qualify_Entity_Names (N); |
| |
| if Ekind (Spec_Id) /= E_Generic_Package then |
| Build_Finalizer |
| (N => N, |
| Clean_Stmts => No_List, |
| Mark_Id => Empty, |
| Top_Decls => No_List, |
| Defer_Abort => False, |
| Fin_Id => Fin_Id); |
| |
| if Present (Fin_Id) then |
| declare |
| Body_Ent : Node_Id := Defining_Unit_Name (N); |
| |
| begin |
| if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then |
| Body_Ent := Defining_Identifier (Body_Ent); |
| end if; |
| |
| Set_Finalizer (Body_Ent, Fin_Id); |
| end; |
| end if; |
| end if; |
| end Expand_N_Package_Body; |
| |
| ---------------------------------- |
| -- Expand_N_Package_Declaration -- |
| ---------------------------------- |
| |
| -- Add call to Activate_Tasks if there are tasks declared and the package |
| -- has no body. Note that in Ada 83 this may result in premature activation |
| -- of some tasks, given that we cannot tell whether a body will eventually |
| -- appear. |
| |
| procedure Expand_N_Package_Declaration (N : Node_Id) is |
| Id : constant Entity_Id := Defining_Entity (N); |
| Spec : constant Node_Id := Specification (N); |
| Decls : List_Id; |
| Fin_Id : Entity_Id; |
| |
| No_Body : Boolean := False; |
| -- True in the case of a package declaration that is a compilation |
| -- unit and for which no associated body will be compiled in this |
| -- compilation. |
| |
| begin |
| -- Case of a package declaration other than a compilation unit |
| |
| if Nkind (Parent (N)) /= N_Compilation_Unit then |
| null; |
| |
| -- Case of a compilation unit that does not require a body |
| |
| elsif not Body_Required (Parent (N)) |
| and then not Unit_Requires_Body (Id) |
| then |
| No_Body := True; |
| |
| -- Special case of generating calling stubs for a remote call interface |
| -- package: even though the package declaration requires one, the body |
| -- won't be processed in this compilation (so any stubs for RACWs |
| -- declared in the package must be generated here, along with the spec). |
| |
| elsif Parent (N) = Cunit (Main_Unit) |
| and then Is_Remote_Call_Interface (Id) |
| and then Distribution_Stub_Mode = Generate_Caller_Stub_Body |
| then |
| No_Body := True; |
| end if; |
| |
| -- For a nested instance, delay processing until freeze point |
| |
| if Has_Delayed_Freeze (Id) |
| and then Nkind (Parent (N)) /= N_Compilation_Unit |
| then |
| return; |
| end if; |
| |
| -- For a package declaration that implies no associated body, generate |
| -- task activation call and RACW supporting bodies now (since we won't |
| -- have a specific separate compilation unit for that). |
| |
| if No_Body then |
| Push_Scope (Id); |
| |
| -- Generate RACW subprogram bodies |
| |
| if Has_RACW (Id) then |
| Decls := Private_Declarations (Spec); |
| |
| if No (Decls) then |
| Decls := Visible_Declarations (Spec); |
| end if; |
| |
| if No (Decls) then |
| Decls := New_List; |
| Set_Visible_Declarations (Spec, Decls); |
| end if; |
| |
| Append_RACW_Bodies (Decls, Id); |
| Analyze_List (Decls); |
| end if; |
| |
| -- Generate task activation call as last step of elaboration |
| |
| if Present (Activation_Chain_Entity (N)) then |
| Build_Task_Activation_Call (N); |
| end if; |
| |
| -- Verify the run-time semantics of pragma Initial_Condition at the |
| -- end of the private declarations when the package lacks a body. |
| |
| Expand_Pragma_Initial_Condition (Id, N); |
| |
| Pop_Scope; |
| end if; |
| |
| -- Build dispatch tables of library-level tagged types for instances |
| -- that are not compilation units (see Analyze_Compilation_Unit). |
| |
| if Tagged_Type_Expansion |
| and then Is_Library_Level_Entity (Id) |
| and then Is_Generic_Instance (Id) |
| and then not Is_Compilation_Unit (Id) |
| then |
| Build_Static_Dispatch_Tables (N); |
| end if; |
| |
| -- Note: it is not necessary to worry about generating a subprogram |
| -- descriptor, since the only way to get exception handlers into a |
| -- package spec is to include instantiations, and that would cause |
| -- generation of subprogram descriptors to be delayed in any case. |
| |
| -- Set to encode entity names in package spec before gigi is called |
| |
| Qualify_Entity_Names (N); |
| |
| if Ekind (Id) /= E_Generic_Package then |
| Build_Finalizer |
| (N => N, |
| Clean_Stmts => No_List, |
| Mark_Id => Empty, |
| Top_Decls => No_List, |
| Defer_Abort => False, |
| Fin_Id => Fin_Id); |
| |
| Set_Finalizer (Id, Fin_Id); |
| end if; |
| |
| -- If this is a library-level package and unnesting is enabled, |
| -- check for the presence of blocks with nested subprograms occurring |
| -- in elaboration code, and generate procedures to encapsulate the |
| -- blocks in case the nested subprograms make up-level references. |
| |
| if Unnest_Subprogram_Mode |
| and then Is_Library_Level_Entity (Current_Scope) |
| then |
| Check_Unnesting_In_Decls_Or_Stmts (Visible_Declarations (Spec)); |
| Check_Unnesting_In_Decls_Or_Stmts (Private_Declarations (Spec)); |
| end if; |
| end Expand_N_Package_Declaration; |
| |
| --------------------------------- |
| -- Has_Simple_Protected_Object -- |
| --------------------------------- |
| |
| function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is |
| begin |
| if Has_Task (T) then |
| return False; |
| |
| elsif Is_Simple_Protected_Type (T) then |
| return True; |
| |
| elsif Is_Array_Type (T) then |
| return Has_Simple_Protected_Object (Component_Type (T)); |
| |
| elsif Is_Record_Type (T) then |
| declare |
| Comp : Entity_Id; |
| |
| begin |
| Comp := First_Component (T); |
| while Present (Comp) loop |
| if Has_Simple_Protected_Object (Etype (Comp)) then |
| return True; |
| end if; |
| |
| Next_Component (Comp); |
| end loop; |
| |
| return False; |
| end; |
| |
| else |
| return False; |
| end if; |
| end Has_Simple_Protected_Object; |
| |
| ------------------------------------ |
| -- Insert_Actions_In_Scope_Around -- |
| ------------------------------------ |
| |
| procedure Insert_Actions_In_Scope_Around |
| (N : Node_Id; |
| Clean : Boolean; |
| Manage_SS : Boolean) |
| is |
| Act_Before : constant List_Id := |
| Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before); |
| Act_After : constant List_Id := |
| Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After); |
| Act_Cleanup : constant List_Id := |
| Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup); |
| -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack. |
| -- Last), but this was incorrect as Process_Transients_In_Scope may |
| -- introduce new scopes and cause a reallocation of Scope_Stack.Table. |
| |
| procedure Process_Transients_In_Scope |
| (First_Object : Node_Id; |
| Last_Object : Node_Id; |
| Related_Node : Node_Id); |
| -- Find all transient objects in the list First_Object .. Last_Object |
| -- and generate finalization actions for them. Related_Node denotes the |
| -- node which created all transient objects. |
| |
| --------------------------------- |
| -- Process_Transients_In_Scope -- |
| --------------------------------- |
| |
| procedure Process_Transients_In_Scope |
| (First_Object : Node_Id; |
| Last_Object : Node_Id; |
| Related_Node : Node_Id) |
| is |
| Must_Hook : Boolean; |
| -- Flag denoting whether the context requires transient object |
| -- export to the outer finalizer. |
| |
| function Is_Subprogram_Call (N : Node_Id) return Traverse_Result; |
| -- Return Abandon if arbitrary node denotes a subprogram call |
| |
| function Has_Subprogram_Call is |
| new Traverse_Func (Is_Subprogram_Call); |
| |
| procedure Process_Transient_In_Scope |
| (Obj_Decl : Node_Id; |
| Blk_Data : Finalization_Exception_Data; |
| Blk_Stmts : List_Id); |
| -- Generate finalization actions for a single transient object |
| -- denoted by object declaration Obj_Decl. Blk_Data is the |
| -- exception data of the enclosing block. Blk_Stmts denotes the |
| -- statements of the enclosing block. |
| |
| ------------------------ |
| -- Is_Subprogram_Call -- |
| ------------------------ |
| |
| function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is |
| begin |
| -- A regular procedure or function call |
| |
| if Nkind (N) in N_Subprogram_Call then |
| return Abandon; |
| |
| -- Special cases |
| |
| -- Heavy expansion may relocate function calls outside the related |
| -- node. Inspect the original node to detect the initial placement |
| -- of the call. |
| |
| elsif Is_Rewrite_Substitution (N) then |
| return Has_Subprogram_Call (Original_Node (N)); |
| |
| -- Generalized indexing always involves a function call |
| |
| elsif Nkind (N) = N_Indexed_Component |
| and then Present (Generalized_Indexing (N)) |
| then |
| return Abandon; |
| |
| -- Keep searching |
| |
| else |
| return OK; |
| end if; |
| end Is_Subprogram_Call; |
| |
| -------------------------------- |
| -- Process_Transient_In_Scope -- |
| -------------------------------- |
| |
| procedure Process_Transient_In_Scope |
| (Obj_Decl : Node_Id; |
| Blk_Data : Finalization_Exception_Data; |
| Blk_Stmts : List_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Obj_Decl); |
| Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); |
| Fin_Call : Node_Id; |
| Fin_Stmts : List_Id; |
| Hook_Assign : Node_Id; |
| Hook_Clear : Node_Id; |
| Hook_Decl : Node_Id; |
| Hook_Insert : Node_Id; |
| Ptr_Decl : Node_Id; |
| |
| begin |
| -- Mark the transient object as successfully processed to avoid |
| -- double finalization. |
| |
| Set_Is_Finalized_Transient (Obj_Id); |
| |
| -- Construct all the pieces necessary to hook and finalize the |
| -- transient object. |
| |
| Build_Transient_Object_Statements |
| (Obj_Decl => Obj_Decl, |
| Fin_Call => Fin_Call, |
| Hook_Assign => Hook_Assign, |
| Hook_Clear => Hook_Clear, |
| Hook_Decl => Hook_Decl, |
| Ptr_Decl => Ptr_Decl); |
| |
| -- The context contains at least one subprogram call which may |
| -- raise an exception. This scenario employs "hooking" to pass |
| -- transient objects to the enclosing finalizer in case of an |
| -- exception. |
| |
| if Must_Hook then |
| |
| -- Add the access type which provides a reference to the |
| -- transient object. Generate: |
| |
| -- type Ptr_Typ is access all Desig_Typ; |
| |
| Insert_Action (Obj_Decl, Ptr_Decl); |
| |
| -- Add the temporary which acts as a hook to the transient |
| -- object. Generate: |
| |
| -- Hook : Ptr_Typ := null; |
| |
| Insert_Action (Obj_Decl, Hook_Decl); |
| |
| -- When the transient object is initialized by an aggregate, |
| -- the hook must capture the object after the last aggregate |
| -- assignment takes place. Only then is the object considered |
| -- fully initialized. Generate: |
| |
| -- Hook := Ptr_Typ (Obj_Id); |
| -- <or> |
| -- Hook := Obj_Id'Unrestricted_Access; |
| |
| -- Similarly if we have a build in place call: we must |
| -- initialize Hook only after the call has happened, otherwise |
| -- Obj_Id will not be initialized yet. |
| |
| if Ekind (Obj_Id) in E_Constant | E_Variable then |
| if Present (Last_Aggregate_Assignment (Obj_Id)) then |
| Hook_Insert := Last_Aggregate_Assignment (Obj_Id); |
| elsif Present (BIP_Initialization_Call (Obj_Id)) then |
| Hook_Insert := BIP_Initialization_Call (Obj_Id); |
| else |
| Hook_Insert := Obj_Decl; |
| end if; |
| |
| -- Otherwise the hook seizes the related object immediately |
| |
| else |
| Hook_Insert := Obj_Decl; |
| end if; |
| |
| Insert_After_And_Analyze (Hook_Insert, Hook_Assign); |
| end if; |
| |
| -- When exception propagation is enabled wrap the hook clear |
| -- statement and the finalization call into a block to catch |
| -- potential exceptions raised during finalization. Generate: |
| |
| -- begin |
| -- [Hook := null;] |
| -- [Deep_]Finalize (Obj_Ref); |
| |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence |
| -- (Enn, Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| |
| if Exceptions_OK then |
| Fin_Stmts := New_List; |
| |
| if Must_Hook then |
| Append_To (Fin_Stmts, Hook_Clear); |
| end if; |
| |
| Append_To (Fin_Stmts, Fin_Call); |
| |
| Prepend_To (Blk_Stmts, |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Fin_Stmts, |
| Exception_Handlers => New_List ( |
| Build_Exception_Handler (Blk_Data))))); |
| |
| -- Otherwise generate: |
| |
| -- [Hook := null;] |
| -- [Deep_]Finalize (Obj_Ref); |
| |
| -- Note that the statements are inserted in reverse order to |
| -- achieve the desired final order outlined above. |
| |
| else |
| Prepend_To (Blk_Stmts, Fin_Call); |
| |
| if Must_Hook then |
| Prepend_To (Blk_Stmts, Hook_Clear); |
| end if; |
| end if; |
| end Process_Transient_In_Scope; |
| |
| -- Local variables |
| |
| Built : Boolean := False; |
| Blk_Data : Finalization_Exception_Data; |
| Blk_Decl : Node_Id := Empty; |
| Blk_Decls : List_Id := No_List; |
| Blk_Ins : Node_Id; |
| Blk_Stmts : List_Id := No_List; |
| Loc : Source_Ptr := No_Location; |
| Obj_Decl : Node_Id; |
| |
| -- Start of processing for Process_Transients_In_Scope |
| |
| begin |
| -- The expansion performed by this routine is as follows: |
| |
| -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ; |
| -- Hook_1 : Ptr_Typ_1 := null; |
| -- Ctrl_Trans_Obj_1 : ...; |
| -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access; |
| -- . . . |
| -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ; |
| -- Hook_N : Ptr_Typ_N := null; |
| -- Ctrl_Trans_Obj_N : ...; |
| -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access; |
| |
| -- declare |
| -- Abrt : constant Boolean := ...; |
| -- Ex : Exception_Occurrence; |
| -- Raised : Boolean := False; |
| |
| -- begin |
| -- Abort_Defer; |
| |
| -- begin |
| -- Hook_N := null; |
| -- [Deep_]Finalize (Ctrl_Trans_Obj_N); |
| |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (Ex, Get_Current_Excep.all.all); |
| -- end; |
| -- . . . |
| -- begin |
| -- Hook_1 := null; |
| -- [Deep_]Finalize (Ctrl_Trans_Obj_1); |
| |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (Ex, Get_Current_Excep.all.all); |
| -- end; |
| |
| -- Abort_Undefer; |
| |
| -- if Raised and not Abrt then |
| -- Raise_From_Controlled_Operation (Ex); |
| -- end if; |
| -- end; |
| |
| -- Recognize a scenario where the transient context is an object |
| -- declaration initialized by a build-in-place function call: |
| |
| -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call); |
| |
| -- The rough expansion of the above is: |
| |
| -- Temp : ... := Ctrl_Func_Call; |
| -- Obj : ...; |
| -- Res : ... := BIP_Func_Call (..., Obj, ...); |
| |
| -- The finalization of any transient object must happen after the |
| -- build-in-place function call is executed. |
| |
| if Nkind (N) = N_Object_Declaration |
| and then Present (BIP_Initialization_Call (Defining_Identifier (N))) |
| then |
| Must_Hook := True; |
| Blk_Ins := BIP_Initialization_Call (Defining_Identifier (N)); |
| |
| -- Search the context for at least one subprogram call. If found, the |
| -- machinery exports all transient objects to the enclosing finalizer |
| -- due to the possibility of abnormal call termination. |
| |
| else |
| Must_Hook := Has_Subprogram_Call (N) = Abandon; |
| Blk_Ins := Last_Object; |
| end if; |
| |
| if Clean then |
| Insert_List_After_And_Analyze (Blk_Ins, Act_Cleanup); |
| end if; |
| |
| -- Examine all objects in the list First_Object .. Last_Object |
| |
| Obj_Decl := First_Object; |
| while Present (Obj_Decl) loop |
| if Nkind (Obj_Decl) = N_Object_Declaration |
| and then Analyzed (Obj_Decl) |
| and then Is_Finalizable_Transient (Obj_Decl, N) |
| |
| -- Do not process the node to be wrapped since it will be |
| -- handled by the enclosing finalizer. |
| |
| and then Obj_Decl /= Related_Node |
| then |
| Loc := Sloc (Obj_Decl); |
| |
| -- Before generating the cleanup code for the first transient |
| -- object, create a wrapper block which houses all hook clear |
| -- statements and finalization calls. This wrapper is needed by |
| -- the back end. |
| |
| if not Built then |
| Built := True; |
| Blk_Stmts := New_List; |
| |
| -- Generate: |
| -- Abrt : constant Boolean := ...; |
| -- Ex : Exception_Occurrence; |
| -- Raised : Boolean := False; |
| |
| if Exceptions_OK then |
| Blk_Decls := New_List; |
| Build_Object_Declarations (Blk_Data, Blk_Decls, Loc); |
| end if; |
| |
| Blk_Decl := |
| Make_Block_Statement (Loc, |
| Declarations => Blk_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Blk_Stmts)); |
| end if; |
| |
| -- Construct all necessary circuitry to hook and finalize a |
| -- single transient object. |
| |
| pragma Assert (Present (Blk_Stmts)); |
| Process_Transient_In_Scope |
| (Obj_Decl => Obj_Decl, |
| Blk_Data => Blk_Data, |
| Blk_Stmts => Blk_Stmts); |
| end if; |
| |
| -- Terminate the scan after the last object has been processed to |
| -- avoid touching unrelated code. |
| |
| if Obj_Decl = Last_Object then |
| exit; |
| end if; |
| |
| Next (Obj_Decl); |
| end loop; |
| |
| -- Complete the decoration of the enclosing finalization block and |
| -- insert it into the tree. |
| |
| if Present (Blk_Decl) then |
| |
| pragma Assert (Present (Blk_Stmts)); |
| pragma Assert (Loc /= No_Location); |
| |
| -- Note that this Abort_Undefer does not require a extra block or |
| -- an AT_END handler because each finalization exception is caught |
| -- in its own corresponding finalization block. As a result, the |
| -- call to Abort_Defer always takes place. |
| |
| if Abort_Allowed then |
| Prepend_To (Blk_Stmts, |
| Build_Runtime_Call (Loc, RE_Abort_Defer)); |
| |
| Append_To (Blk_Stmts, |
| Build_Runtime_Call (Loc, RE_Abort_Undefer)); |
| end if; |
| |
| -- Generate: |
| -- if Raised and then not Abrt then |
| -- Raise_From_Controlled_Operation (Ex); |
| -- end if; |
| |
| if Exceptions_OK then |
| Append_To (Blk_Stmts, Build_Raise_Statement (Blk_Data)); |
| end if; |
| |
| Insert_After_And_Analyze (Blk_Ins, Blk_Decl); |
| end if; |
| end Process_Transients_In_Scope; |
| |
| -- Local variables |
| |
| Loc : constant Source_Ptr := Sloc (N); |
| Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped; |
| First_Obj : Node_Id; |
| Last_Obj : Node_Id; |
| Mark_Id : Entity_Id; |
| Target : Node_Id; |
| |
| -- Start of processing for Insert_Actions_In_Scope_Around |
| |
| begin |
| -- Nothing to do if the scope does not manage the secondary stack or |
| -- does not contain meaningful actions for insertion. |
| |
| if not Manage_SS |
| and then No (Act_Before) |
| and then No (Act_After) |
| and then No (Act_Cleanup) |
| then |
| return; |
| end if; |
| |
| -- If the node to be wrapped is the trigger of an asynchronous select, |
| -- it is not part of a statement list. The actions must be inserted |
| -- before the select itself, which is part of some list of statements. |
| -- Note that the triggering alternative includes the triggering |
| -- statement and an optional statement list. If the node to be |
| -- wrapped is part of that list, the normal insertion applies. |
| |
| if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative |
| and then not Is_List_Member (Node_To_Wrap) |
| then |
| Target := Parent (Parent (Node_To_Wrap)); |
| else |
| Target := N; |
| end if; |
| |
| First_Obj := Target; |
| Last_Obj := Target; |
| |
| -- Add all actions associated with a transient scope into the main tree. |
| -- There are several scenarios here: |
| |
| -- +--- Before ----+ +----- After ---+ |
| -- 1) First_Obj ....... Target ........ Last_Obj |
| |
| -- 2) First_Obj ....... Target |
| |
| -- 3) Target ........ Last_Obj |
| |
| -- Flag declarations are inserted before the first object |
| |
| if Present (Act_Before) then |
| First_Obj := First (Act_Before); |
| Insert_List_Before (Target, Act_Before); |
| end if; |
| |
| -- Finalization calls are inserted after the last object |
| |
| if Present (Act_After) then |
| Last_Obj := Last (Act_After); |
| Insert_List_After (Target, Act_After); |
| end if; |
| |
| -- Mark and release the secondary stack when the context warrants it |
| |
| if Manage_SS then |
| Mark_Id := Make_Temporary (Loc, 'M'); |
| |
| -- Generate: |
| -- Mnn : constant Mark_Id := SS_Mark; |
| |
| Insert_Before_And_Analyze |
| (First_Obj, Build_SS_Mark_Call (Loc, Mark_Id)); |
| |
| -- Generate: |
| -- SS_Release (Mnn); |
| |
| Insert_After_And_Analyze |
| (Last_Obj, Build_SS_Release_Call (Loc, Mark_Id)); |
| end if; |
| |
| -- Check for transient objects associated with Target and generate the |
| -- appropriate finalization actions for them. |
| |
| Process_Transients_In_Scope |
| (First_Object => First_Obj, |
| Last_Object => Last_Obj, |
| Related_Node => Target); |
| |
| -- Reset the action lists |
| |
| Scope_Stack.Table |
| (Scope_Stack.Last).Actions_To_Be_Wrapped (Before) := No_List; |
| Scope_Stack.Table |
| (Scope_Stack.Last).Actions_To_Be_Wrapped (After) := No_List; |
| |
| if Clean then |
| Scope_Stack.Table |
| (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup) := No_List; |
| end if; |
| end Insert_Actions_In_Scope_Around; |
| |
| ------------------------------ |
| -- Is_Simple_Protected_Type -- |
| ------------------------------ |
| |
| function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is |
| begin |
| return |
| Is_Protected_Type (T) |
| and then not Uses_Lock_Free (T) |
| and then not Has_Entries (T) |
| and then Is_RTE (Find_Protection_Type (T), RE_Protection); |
| end Is_Simple_Protected_Type; |
| |
| ----------------------- |
| -- Make_Adjust_Call -- |
| ----------------------- |
| |
| function Make_Adjust_Call |
| (Obj_Ref : Node_Id; |
| Typ : Entity_Id; |
| Skip_Self : Boolean := False) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Obj_Ref); |
| Adj_Id : Entity_Id := Empty; |
| Ref : Node_Id; |
| Utyp : Entity_Id; |
| |
| begin |
| Ref := Obj_Ref; |
| |
| -- Recover the proper type which contains Deep_Adjust |
| |
| if Is_Class_Wide_Type (Typ) then |
| Utyp := Root_Type (Typ); |
| else |
| Utyp := Typ; |
| end if; |
| |
| Utyp := Underlying_Type (Base_Type (Utyp)); |
| Set_Assignment_OK (Ref); |
| |
| -- Deal with untagged derivation of private views |
| |
| if Present (Utyp) and then Is_Untagged_Derivation (Typ) then |
| Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); |
| Ref := Unchecked_Convert_To (Utyp, Ref); |
| Set_Assignment_OK (Ref); |
| end if; |
| |
| -- When dealing with the completion of a private type, use the base |
| -- type instead. |
| |
| if Present (Utyp) and then Utyp /= Base_Type (Utyp) then |
| pragma Assert (Is_Private_Type (Typ)); |
| |
| Utyp := Base_Type (Utyp); |
| Ref := Unchecked_Convert_To (Utyp, Ref); |
| end if; |
| |
| -- The underlying type may not be present due to a missing full view. In |
| -- this case freezing did not take place and there is no [Deep_]Adjust |
| -- primitive to call. |
| |
| if No (Utyp) then |
| return Empty; |
| |
| elsif Skip_Self then |
| if Has_Controlled_Component (Utyp) then |
| if Is_Tagged_Type (Utyp) then |
| Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); |
| else |
| Adj_Id := TSS (Utyp, TSS_Deep_Adjust); |
| end if; |
| end if; |
| |
| -- Class-wide types, interfaces and types with controlled components |
| |
| elsif Is_Class_Wide_Type (Typ) |
| or else Is_Interface (Typ) |
| or else Has_Controlled_Component (Utyp) |
| then |
| if Is_Tagged_Type (Utyp) then |
| Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); |
| else |
| Adj_Id := TSS (Utyp, TSS_Deep_Adjust); |
| end if; |
| |
| -- Derivations from [Limited_]Controlled |
| |
| elsif Is_Controlled (Utyp) then |
| if Has_Controlled_Component (Utyp) then |
| Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); |
| else |
| Adj_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Adjust_Case)); |
| end if; |
| |
| -- Tagged types |
| |
| elsif Is_Tagged_Type (Utyp) then |
| Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); |
| |
| else |
| raise Program_Error; |
| end if; |
| |
| if Present (Adj_Id) then |
| |
| -- If the object is unanalyzed, set its expected type for use in |
| -- Convert_View in case an additional conversion is needed. |
| |
| if No (Etype (Ref)) |
| and then Nkind (Ref) /= N_Unchecked_Type_Conversion |
| then |
| Set_Etype (Ref, Typ); |
| end if; |
| |
| -- The object reference may need another conversion depending on the |
| -- type of the formal and that of the actual. |
| |
| if not Is_Class_Wide_Type (Typ) then |
| Ref := Convert_View (Adj_Id, Ref); |
| end if; |
| |
| return |
| Make_Call (Loc, |
| Proc_Id => Adj_Id, |
| Param => Ref, |
| Skip_Self => Skip_Self); |
| else |
| return Empty; |
| end if; |
| end Make_Adjust_Call; |
| |
| --------------- |
| -- Make_Call -- |
| --------------- |
| |
| function Make_Call |
| (Loc : Source_Ptr; |
| Proc_Id : Entity_Id; |
| Param : Node_Id; |
| Skip_Self : Boolean := False) return Node_Id |
| is |
| Params : constant List_Id := New_List (Param); |
| |
| begin |
| -- Do not apply the controlled action to the object itself by signaling |
| -- the related routine to avoid self. |
| |
| if Skip_Self then |
| Append_To (Params, New_Occurrence_Of (Standard_False, Loc)); |
| end if; |
| |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Proc_Id, Loc), |
| Parameter_Associations => Params); |
| end Make_Call; |
| |
| -------------------------- |
| -- Make_Deep_Array_Body -- |
| -------------------------- |
| |
| function Make_Deep_Array_Body |
| (Prim : Final_Primitives; |
| Typ : Entity_Id) return List_Id |
| is |
| function Build_Adjust_Or_Finalize_Statements |
| (Typ : Entity_Id) return List_Id; |
| -- Create the statements necessary to adjust or finalize an array of |
| -- controlled elements. Generate: |
| -- |
| -- declare |
| -- Abort : constant Boolean := Triggered_By_Abort; |
| -- <or> |
| -- Abort : constant Boolean := False; -- no abort |
| -- |
| -- E : Exception_Occurrence; |
| -- Raised : Boolean := False; |
| -- |
| -- begin |
| -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop |
| -- ^-- in the finalization case |
| -- ... |
| -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop |
| -- begin |
| -- [Deep_]Adjust / Finalize (V (J1, ..., Jn)); |
| -- |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| -- end loop; |
| -- ... |
| -- end loop; |
| -- |
| -- if Raised and then not Abort then |
| -- Raise_From_Controlled_Operation (E); |
| -- end if; |
| -- end; |
| |
| function Build_Initialize_Statements (Typ : Entity_Id) return List_Id; |
| -- Create the statements necessary to initialize an array of controlled |
| -- elements. Include a mechanism to carry out partial finalization if an |
| -- exception occurs. Generate: |
| -- |
| -- declare |
| -- Counter : Integer := 0; |
| -- |
| -- begin |
| -- for J1 in V'Range (1) loop |
| -- ... |
| -- for JN in V'Range (N) loop |
| -- begin |
| -- [Deep_]Initialize (V (J1, ..., JN)); |
| -- |
| -- Counter := Counter + 1; |
| -- |
| -- exception |
| -- when others => |
| -- declare |
| -- Abort : constant Boolean := Triggered_By_Abort; |
| -- <or> |
| -- Abort : constant Boolean := False; -- no abort |
| -- E : Exception_Occurrence; |
| -- Raised : Boolean := False; |
| |
| -- begin |
| -- Counter := |
| -- V'Length (1) * |
| -- V'Length (2) * |
| -- ... |
| -- V'Length (N) - Counter; |
| |
| -- for F1 in reverse V'Range (1) loop |
| -- ... |
| -- for FN in reverse V'Range (N) loop |
| -- if Counter > 0 then |
| -- Counter := Counter - 1; |
| -- else |
| -- begin |
| -- [Deep_]Finalize (V (F1, ..., FN)); |
| |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, |
| -- Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| -- end if; |
| -- end loop; |
| -- ... |
| -- end loop; |
| -- end; |
| -- |
| -- if Raised and then not Abort then |
| -- Raise_From_Controlled_Operation (E); |
| -- end if; |
| -- |
| -- raise; |
| -- end; |
| -- end loop; |
| -- end loop; |
| -- end; |
| |
| function New_References_To |
| (L : List_Id; |
| Loc : Source_Ptr) return List_Id; |
| -- Given a list of defining identifiers, return a list of references to |
| -- the original identifiers, in the same order as they appear. |
| |
| ----------------------------------------- |
| -- Build_Adjust_Or_Finalize_Statements -- |
| ----------------------------------------- |
| |
| function Build_Adjust_Or_Finalize_Statements |
| (Typ : Entity_Id) return List_Id |
| is |
| Comp_Typ : constant Entity_Id := Component_Type (Typ); |
| Index_List : constant List_Id := New_List; |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Num_Dims : constant Int := Number_Dimensions (Typ); |
| |
| procedure Build_Indexes; |
| -- Generate the indexes used in the dimension loops |
| |
| ------------------- |
| -- Build_Indexes -- |
| ------------------- |
| |
| procedure Build_Indexes is |
| begin |
| -- Generate the following identifiers: |
| -- Jnn - for initialization |
| |
| for Dim in 1 .. Num_Dims loop |
| Append_To (Index_List, |
| Make_Defining_Identifier (Loc, New_External_Name ('J', Dim))); |
| end loop; |
| end Build_Indexes; |
| |
| -- Local variables |
| |
| Final_Decls : List_Id := No_List; |
| Final_Data : Finalization_Exception_Data; |
| Block : Node_Id; |
| Call : Node_Id; |
| Comp_Ref : Node_Id; |
| Core_Loop : Node_Id; |
| Dim : Int; |
| J : Entity_Id; |
| Loop_Id : Entity_Id; |
| Stmts : List_Id; |
| |
| -- Start of processing for Build_Adjust_Or_Finalize_Statements |
| |
| begin |
| Final_Decls := New_List; |
| |
| Build_Indexes; |
| Build_Object_Declarations (Final_Data, Final_Decls, Loc); |
| |
| Comp_Ref := |
| Make_Indexed_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Expressions => New_References_To (Index_List, Loc)); |
| Set_Etype (Comp_Ref, Comp_Typ); |
| |
| -- Generate: |
| -- [Deep_]Adjust (V (J1, ..., JN)) |
| |
| if Prim = Adjust_Case then |
| Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); |
| |
| -- Generate: |
| -- [Deep_]Finalize (V (J1, ..., JN)) |
| |
| else pragma Assert (Prim = Finalize_Case); |
| Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); |
| end if; |
| |
| if Present (Call) then |
| |
| -- Generate the block which houses the adjust or finalize call: |
| |
| -- begin |
| -- <adjust or finalize call> |
| |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| |
| if Exceptions_OK then |
| Core_Loop := |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Call), |
| Exception_Handlers => New_List ( |
| Build_Exception_Handler (Final_Data)))); |
| else |
| Core_Loop := Call; |
| end if; |
| |
| -- Generate the dimension loops starting from the innermost one |
| |
| -- for Jnn in [reverse] V'Range (Dim) loop |
| -- <core loop> |
| -- end loop; |
| |
| J := Last (Index_List); |
| Dim := Num_Dims; |
| while Present (J) and then Dim > 0 loop |
| Loop_Id := J; |
| Prev (J); |
| Remove (Loop_Id); |
| |
| Core_Loop := |
| Make_Loop_Statement (Loc, |
| Iteration_Scheme => |
| Make_Iteration_Scheme (Loc, |
| Loop_Parameter_Specification => |
| Make_Loop_Parameter_Specification (Loc, |
| Defining_Identifier => Loop_Id, |
| Discrete_Subtype_Definition => |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Attribute_Name => Name_Range, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, Dim))), |
| |
| Reverse_Present => |
| Prim = Finalize_Case)), |
| |
| Statements => New_List (Core_Loop), |
| End_Label => Empty); |
| |
| Dim := Dim - 1; |
| end loop; |
| |
| -- Generate the block which contains the core loop, declarations |
| -- of the abort flag, the exception occurrence, the raised flag |
| -- and the conditional raise: |
| |
| -- declare |
| -- Abort : constant Boolean := Triggered_By_Abort; |
| -- <or> |
| -- Abort : constant Boolean := False; -- no abort |
| |
| -- E : Exception_Occurrence; |
| -- Raised : Boolean := False; |
| |
| -- begin |
| -- <core loop> |
| |
| -- if Raised and then not Abort then |
| -- Raise_From_Controlled_Operation (E); |
| -- end if; |
| -- end; |
| |
| Stmts := New_List (Core_Loop); |
| |
| if Exceptions_OK then |
| Append_To (Stmts, Build_Raise_Statement (Final_Data)); |
| end if; |
| |
| Block := |
| Make_Block_Statement (Loc, |
| Declarations => Final_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stmts)); |
| |
| -- Otherwise previous errors or a missing full view may prevent the |
| -- proper freezing of the component type. If this is the case, there |
| -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call. |
| |
| else |
| Block := Make_Null_Statement (Loc); |
| end if; |
| |
| return New_List (Block); |
| end Build_Adjust_Or_Finalize_Statements; |
| |
| --------------------------------- |
| -- Build_Initialize_Statements -- |
| --------------------------------- |
| |
| function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is |
| Comp_Typ : constant Entity_Id := Component_Type (Typ); |
| Final_List : constant List_Id := New_List; |
| Index_List : constant List_Id := New_List; |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Num_Dims : constant Int := Number_Dimensions (Typ); |
| |
| function Build_Assignment (Counter_Id : Entity_Id) return Node_Id; |
| -- Generate the following assignment: |
| -- Counter := V'Length (1) * |
| -- ... |
| -- V'Length (N) - Counter; |
| -- |
| -- Counter_Id denotes the entity of the counter. |
| |
| function Build_Finalization_Call return Node_Id; |
| -- Generate a deep finalization call for an array element |
| |
| procedure Build_Indexes; |
| -- Generate the initialization and finalization indexes used in the |
| -- dimension loops. |
| |
| function Build_Initialization_Call return Node_Id; |
| -- Generate a deep initialization call for an array element |
| |
| ---------------------- |
| -- Build_Assignment -- |
| ---------------------- |
| |
| function Build_Assignment (Counter_Id : Entity_Id) return Node_Id is |
| Dim : Int; |
| Expr : Node_Id; |
| |
| begin |
| -- Start from the first dimension and generate: |
| -- V'Length (1) |
| |
| Dim := 1; |
| Expr := |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Attribute_Name => Name_Length, |
| Expressions => New_List (Make_Integer_Literal (Loc, Dim))); |
| |
| -- Process the rest of the dimensions, generate: |
| -- Expr * V'Length (N) |
| |
| Dim := Dim + 1; |
| while Dim <= Num_Dims loop |
| Expr := |
| Make_Op_Multiply (Loc, |
| Left_Opnd => Expr, |
| Right_Opnd => |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Attribute_Name => Name_Length, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, Dim)))); |
| |
| Dim := Dim + 1; |
| end loop; |
| |
| -- Generate: |
| -- Counter := Expr - Counter; |
| |
| return |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Counter_Id, Loc), |
| Expression => |
| Make_Op_Subtract (Loc, |
| Left_Opnd => Expr, |
| Right_Opnd => New_Occurrence_Of (Counter_Id, Loc))); |
| end Build_Assignment; |
| |
| ----------------------------- |
| -- Build_Finalization_Call -- |
| ----------------------------- |
| |
| function Build_Finalization_Call return Node_Id is |
| Comp_Ref : constant Node_Id := |
| Make_Indexed_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Expressions => New_References_To (Final_List, Loc)); |
| |
| begin |
| Set_Etype (Comp_Ref, Comp_Typ); |
| |
| -- Generate: |
| -- [Deep_]Finalize (V); |
| |
| return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); |
| end Build_Finalization_Call; |
| |
| ------------------- |
| -- Build_Indexes -- |
| ------------------- |
| |
| procedure Build_Indexes is |
| begin |
| -- Generate the following identifiers: |
| -- Jnn - for initialization |
| -- Fnn - for finalization |
| |
| for Dim in 1 .. Num_Dims loop |
| Append_To (Index_List, |
| Make_Defining_Identifier (Loc, New_External_Name ('J', Dim))); |
| |
| Append_To (Final_List, |
| Make_Defining_Identifier (Loc, New_External_Name ('F', Dim))); |
| end loop; |
| end Build_Indexes; |
| |
| ------------------------------- |
| -- Build_Initialization_Call -- |
| ------------------------------- |
| |
| function Build_Initialization_Call return Node_Id is |
| Comp_Ref : constant Node_Id := |
| Make_Indexed_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Expressions => New_References_To (Index_List, Loc)); |
| |
| begin |
| Set_Etype (Comp_Ref, Comp_Typ); |
| |
| -- Generate: |
| -- [Deep_]Initialize (V (J1, ..., JN)); |
| |
| return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); |
| end Build_Initialization_Call; |
| |
| -- Local variables |
| |
| Counter_Id : Entity_Id; |
| Dim : Int; |
| F : Node_Id; |
| Fin_Stmt : Node_Id; |
| Final_Block : Node_Id; |
| Final_Data : Finalization_Exception_Data; |
| Final_Decls : List_Id := No_List; |
| Final_Loop : Node_Id; |
| Init_Block : Node_Id; |
| Init_Call : Node_Id; |
| Init_Loop : Node_Id; |
| J : Node_Id; |
| Loop_Id : Node_Id; |
| Stmts : List_Id; |
| |
| -- Start of processing for Build_Initialize_Statements |
| |
| begin |
| Counter_Id := Make_Temporary (Loc, 'C'); |
| Final_Decls := New_List; |
| |
| Build_Indexes; |
| Build_Object_Declarations (Final_Data, Final_Decls, Loc); |
| |
| -- Generate the block which houses the finalization call, the index |
| -- guard and the handler which triggers Program_Error later on. |
| |
| -- if Counter > 0 then |
| -- Counter := Counter - 1; |
| -- else |
| -- begin |
| -- [Deep_]Finalize (V (F1, ..., FN)); |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| -- end if; |
| |
| Fin_Stmt := Build_Finalization_Call; |
| |
| if Present (Fin_Stmt) then |
| if Exceptions_OK then |
| Fin_Stmt := |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Fin_Stmt), |
| Exception_Handlers => New_List ( |
| Build_Exception_Handler (Final_Data)))); |
| end if; |
| |
| -- This is the core of the loop, the dimension iterators are added |
| -- one by one in reverse. |
| |
| Final_Loop := |
| Make_If_Statement (Loc, |
| Condition => |
| Make_Op_Gt (Loc, |
| Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), |
| Right_Opnd => Make_Integer_Literal (Loc, 0)), |
| |
| Then_Statements => New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Counter_Id, Loc), |
| Expression => |
| Make_Op_Subtract (Loc, |
| Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), |
| Right_Opnd => Make_Integer_Literal (Loc, 1)))), |
| |
| Else_Statements => New_List (Fin_Stmt)); |
| |
| -- Generate all finalization loops starting from the innermost |
| -- dimension. |
| |
| -- for Fnn in reverse V'Range (Dim) loop |
| -- <final loop> |
| -- end loop; |
| |
| F := Last (Final_List); |
| Dim := Num_Dims; |
| while Present (F) and then Dim > 0 loop |
| Loop_Id := F; |
| Prev (F); |
| Remove (Loop_Id); |
| |
| Final_Loop := |
| Make_Loop_Statement (Loc, |
| Iteration_Scheme => |
| Make_Iteration_Scheme (Loc, |
| Loop_Parameter_Specification => |
| Make_Loop_Parameter_Specification (Loc, |
| Defining_Identifier => Loop_Id, |
| Discrete_Subtype_Definition => |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Attribute_Name => Name_Range, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, Dim))), |
| |
| Reverse_Present => True)), |
| |
| Statements => New_List (Final_Loop), |
| End_Label => Empty); |
| |
| Dim := Dim - 1; |
| end loop; |
| |
| -- Generate the block which contains the finalization loops, the |
| -- declarations of the abort flag, the exception occurrence, the |
| -- raised flag and the conditional raise. |
| |
| -- declare |
| -- Abort : constant Boolean := Triggered_By_Abort; |
| -- <or> |
| -- Abort : constant Boolean := False; -- no abort |
| |
| -- E : Exception_Occurrence; |
| -- Raised : Boolean := False; |
| |
| -- begin |
| -- Counter := |
| -- V'Length (1) * |
| -- ... |
| -- V'Length (N) - Counter; |
| |
| -- <final loop> |
| |
| -- if Raised and then not Abort then |
| -- Raise_From_Controlled_Operation (E); |
| -- end if; |
| |
| -- raise; |
| -- end; |
| |
| Stmts := New_List (Build_Assignment (Counter_Id), Final_Loop); |
| |
| if Exceptions_OK then |
| Append_To (Stmts, Build_Raise_Statement (Final_Data)); |
| Append_To (Stmts, Make_Raise_Statement (Loc)); |
| end if; |
| |
| Final_Block := |
| Make_Block_Statement (Loc, |
| Declarations => Final_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stmts)); |
| |
| -- Otherwise previous errors or a missing full view may prevent the |
| -- proper freezing of the component type. If this is the case, there |
| -- is no [Deep_]Finalize primitive to call. |
| |
| else |
| Final_Block := Make_Null_Statement (Loc); |
| end if; |
| |
| -- Generate the block which contains the initialization call and |
| -- the partial finalization code. |
| |
| -- begin |
| -- [Deep_]Initialize (V (J1, ..., JN)); |
| |
| -- Counter := Counter + 1; |
| |
| -- exception |
| -- when others => |
| -- <finalization code> |
| -- end; |
| |
| Init_Call := Build_Initialization_Call; |
| |
| -- Only create finalization block if there is a nontrivial call |
| -- to initialization or a Default_Initial_Condition check to be |
| -- performed. |
| |
| if (Present (Init_Call) |
| and then Nkind (Init_Call) /= N_Null_Statement) |
| or else |
| (Has_DIC (Comp_Typ) |
| and then not GNATprove_Mode |
| and then Present (DIC_Procedure (Comp_Typ)) |
| and then not Has_Null_Body (DIC_Procedure (Comp_Typ))) |
| then |
| declare |
| Init_Stmts : constant List_Id := New_List; |
| |
| begin |
| if Present (Init_Call) then |
| Append_To (Init_Stmts, Init_Call); |
| end if; |
| |
| if Has_DIC (Comp_Typ) |
| and then Present (DIC_Procedure (Comp_Typ)) |
| then |
| Append_To |
| (Init_Stmts, |
| Build_DIC_Call (Loc, |
| Make_Indexed_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Expressions => New_References_To (Index_List, Loc)), |
| Comp_Typ)); |
| end if; |
| |
| Init_Loop := |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Init_Stmts, |
| Exception_Handlers => New_List ( |
| Make_Exception_Handler (Loc, |
| Exception_Choices => New_List ( |
| Make_Others_Choice (Loc)), |
| Statements => New_List (Final_Block))))); |
| end; |
| |
| Append_To (Statements (Handled_Statement_Sequence (Init_Loop)), |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Counter_Id, Loc), |
| Expression => |
| Make_Op_Add (Loc, |
| Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), |
| Right_Opnd => Make_Integer_Literal (Loc, 1)))); |
| |
| -- Generate all initialization loops starting from the innermost |
| -- dimension. |
| |
| -- for Jnn in V'Range (Dim) loop |
| -- <init loop> |
| -- end loop; |
| |
| J := Last (Index_List); |
| Dim := Num_Dims; |
| while Present (J) and then Dim > 0 loop |
| Loop_Id := J; |
| Prev (J); |
| Remove (Loop_Id); |
| |
| Init_Loop := |
| Make_Loop_Statement (Loc, |
| Iteration_Scheme => |
| Make_Iteration_Scheme (Loc, |
| Loop_Parameter_Specification => |
| Make_Loop_Parameter_Specification (Loc, |
| Defining_Identifier => Loop_Id, |
| Discrete_Subtype_Definition => |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Attribute_Name => Name_Range, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, Dim))))), |
| |
| Statements => New_List (Init_Loop), |
| End_Label => Empty); |
| |
| Dim := Dim - 1; |
| end loop; |
| |
| -- Generate the block which contains the counter variable and the |
| -- initialization loops. |
| |
| -- declare |
| -- Counter : Integer := 0; |
| -- begin |
| -- <init loop> |
| -- end; |
| |
| Init_Block := |
| Make_Block_Statement (Loc, |
| Declarations => New_List ( |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Counter_Id, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Integer, Loc), |
| Expression => Make_Integer_Literal (Loc, 0))), |
| |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Init_Loop))); |
| |
| if Debug_Generated_Code then |
| Set_Debug_Info_Needed (Counter_Id); |
| end if; |
| |
| -- Otherwise previous errors or a missing full view may prevent the |
| -- proper freezing of the component type. If this is the case, there |
| -- is no [Deep_]Initialize primitive to call. |
| |
| else |
| Init_Block := Make_Null_Statement (Loc); |
| end if; |
| |
| return New_List (Init_Block); |
| end Build_Initialize_Statements; |
| |
| ----------------------- |
| -- New_References_To -- |
| ----------------------- |
| |
| function New_References_To |
| (L : List_Id; |
| Loc : Source_Ptr) return List_Id |
| is |
| Refs : constant List_Id := New_List; |
| Id : Node_Id; |
| |
| begin |
| Id := First (L); |
| while Present (Id) loop |
| Append_To (Refs, New_Occurrence_Of (Id, Loc)); |
| Next (Id); |
| end loop; |
| |
| return Refs; |
| end New_References_To; |
| |
| -- Start of processing for Make_Deep_Array_Body |
| |
| begin |
| case Prim is |
| when Address_Case => |
| return Make_Finalize_Address_Stmts (Typ); |
| |
| when Adjust_Case |
| | Finalize_Case |
| => |
| return Build_Adjust_Or_Finalize_Statements (Typ); |
| |
| when Initialize_Case => |
| return Build_Initialize_Statements (Typ); |
| end case; |
| end Make_Deep_Array_Body; |
| |
| -------------------- |
| -- Make_Deep_Proc -- |
| -------------------- |
| |
| function Make_Deep_Proc |
| (Prim : Final_Primitives; |
| Typ : Entity_Id; |
| Stmts : List_Id) return Entity_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Formals : List_Id; |
| Proc_Id : Entity_Id; |
| |
| begin |
| -- Create the object formal, generate: |
| -- V : System.Address |
| |
| if Prim = Address_Case then |
| Formals := New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), |
| Parameter_Type => |
| New_Occurrence_Of (RTE (RE_Address), Loc))); |
| |
| -- Default case |
| |
| else |
| -- V : in out Typ |
| |
| Formals := New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), |
| In_Present => True, |
| Out_Present => True, |
| Parameter_Type => New_Occurrence_Of (Typ, Loc))); |
| |
| -- F : Boolean := True |
| |
| if Prim = Adjust_Case |
| or else Prim = Finalize_Case |
| then |
| Append_To (Formals, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_F), |
| Parameter_Type => |
| New_Occurrence_Of (Standard_Boolean, Loc), |
| Expression => |
| New_Occurrence_Of (Standard_True, Loc))); |
| end if; |
| end if; |
| |
| Proc_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim))); |
| |
| -- Generate: |
| -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is |
| -- begin |
| -- <stmts> |
| -- exception -- Finalize and Adjust cases only |
| -- raise Program_Error; |
| -- end Deep_Initialize / Adjust / Finalize; |
| |
| -- or |
| |
| -- procedure Finalize_Address (V : System.Address) is |
| -- begin |
| -- <stmts> |
| -- end Finalize_Address; |
| |
| Discard_Node ( |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Proc_Id, |
| Parameter_Specifications => Formals), |
| |
| Declarations => Empty_List, |
| |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts))); |
| |
| -- If there are no calls to component initialization, indicate that |
| -- the procedure is trivial, so prevent calls to it. |
| |
| if Is_Empty_List (Stmts) |
| or else Nkind (First (Stmts)) = N_Null_Statement |
| then |
| Set_Is_Trivial_Subprogram (Proc_Id); |
| end if; |
| |
| return Proc_Id; |
| end Make_Deep_Proc; |
| |
| --------------------------- |
| -- Make_Deep_Record_Body -- |
| --------------------------- |
| |
| function Make_Deep_Record_Body |
| (Prim : Final_Primitives; |
| Typ : Entity_Id; |
| Is_Local : Boolean := False) return List_Id |
| is |
| function Build_Adjust_Statements (Typ : Entity_Id) return List_Id; |
| -- Build the statements necessary to adjust a record type. The type may |
| -- have discriminants and contain variant parts. Generate: |
| -- |
| -- begin |
| -- begin |
| -- [Deep_]Adjust (V.Comp_1); |
| -- exception |
| -- when Id : others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| -- . . . |
| -- begin |
| -- [Deep_]Adjust (V.Comp_N); |
| -- exception |
| -- when Id : others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| -- |
| -- begin |
| -- Deep_Adjust (V._parent, False); -- If applicable |
| -- exception |
| -- when Id : others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| -- |
| -- if F then |
| -- begin |
| -- Adjust (V); -- If applicable |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| -- end if; |
| -- |
| -- if Raised and then not Abort then |
| -- Raise_From_Controlled_Operation (E); |
| -- end if; |
| -- end; |
| |
| function Build_Finalize_Statements (Typ : Entity_Id) return List_Id; |
| -- Build the statements necessary to finalize a record type. The type |
| -- may have discriminants and contain variant parts. Generate: |
| -- |
| -- declare |
| -- Abort : constant Boolean := Triggered_By_Abort; |
| -- <or> |
| -- Abort : constant Boolean := False; -- no abort |
| -- E : Exception_Occurrence; |
| -- Raised : Boolean := False; |
| -- |
| -- begin |
| -- if F then |
| -- begin |
| -- Finalize (V); -- If applicable |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| -- end if; |
| -- |
| -- case Variant_1 is |
| -- when Value_1 => |
| -- case State_Counter_N => -- If Is_Local is enabled |
| -- when N => . |
| -- goto LN; . |
| -- ... . |
| -- when 1 => . |
| -- goto L1; . |
| -- when others => . |
| -- goto L0; . |
| -- end case; . |
| -- |
| -- <<LN>> -- If Is_Local is enabled |
| -- begin |
| -- [Deep_]Finalize (V.Comp_N); |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| -- . . . |
| -- <<L1>> |
| -- begin |
| -- [Deep_]Finalize (V.Comp_1); |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| -- <<L0>> |
| -- end case; |
| -- |
| -- case State_Counter_1 => -- If Is_Local is enabled |
| -- when M => . |
| -- goto LM; . |
| -- ... |
| -- |
| -- begin |
| -- Deep_Finalize (V._parent, False); -- If applicable |
| -- exception |
| -- when Id : others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| -- |
| -- if Raised and then not Abort then |
| -- Raise_From_Controlled_Operation (E); |
| -- end if; |
| -- end; |
| |
| function Parent_Field_Type (Typ : Entity_Id) return Entity_Id; |
| -- Given a derived tagged type Typ, traverse all components, find field |
| -- _parent and return its type. |
| |
| procedure Preprocess_Components |
| (Comps : Node_Id; |
| Num_Comps : out Nat; |
| Has_POC : out Boolean); |
| -- Examine all components in component list Comps, count all controlled |
| -- components and determine whether at least one of them is per-object |
| -- constrained. Component _parent is always skipped. |
| |
| ----------------------------- |
| -- Build_Adjust_Statements -- |
| ----------------------------- |
| |
| function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); |
| |
| Finalizer_Data : Finalization_Exception_Data; |
| |
| function Process_Component_List_For_Adjust |
| (Comps : Node_Id) return List_Id; |
| -- Build all necessary adjust statements for a single component list |
| |
| --------------------------------------- |
| -- Process_Component_List_For_Adjust -- |
| --------------------------------------- |
| |
| function Process_Component_List_For_Adjust |
| (Comps : Node_Id) return List_Id |
| is |
| Stmts : constant List_Id := New_List; |
| |
| procedure Process_Component_For_Adjust (Decl : Node_Id); |
| -- Process the declaration of a single controlled component |
| |
| ---------------------------------- |
| -- Process_Component_For_Adjust -- |
| ---------------------------------- |
| |
| procedure Process_Component_For_Adjust (Decl : Node_Id) is |
| Id : constant Entity_Id := Defining_Identifier (Decl); |
| Typ : constant Entity_Id := Etype (Id); |
| |
| Adj_Call : Node_Id; |
| |
| begin |
| -- begin |
| -- [Deep_]Adjust (V.Id); |
| |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| |
| Adj_Call := |
| Make_Adjust_Call ( |
| Obj_Ref => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Selector_Name => Make_Identifier (Loc, Chars (Id))), |
| Typ => Typ); |
| |
| -- Guard against a missing [Deep_]Adjust when the component |
| -- type was not properly frozen. |
| |
| if Present (Adj_Call) then |
| if Exceptions_OK then |
| Adj_Call := |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Adj_Call), |
| Exception_Handlers => New_List ( |
| Build_Exception_Handler (Finalizer_Data)))); |
| end if; |
| |
| Append_To (Stmts, Adj_Call); |
| end if; |
| end Process_Component_For_Adjust; |
| |
| -- Local variables |
| |
| Decl : Node_Id; |
| Decl_Id : Entity_Id; |
| Decl_Typ : Entity_Id; |
| Has_POC : Boolean; |
| Num_Comps : Nat; |
| Var_Case : Node_Id; |
| |
| -- Start of processing for Process_Component_List_For_Adjust |
| |
| begin |
| -- Perform an initial check, determine the number of controlled |
| -- components in the current list and whether at least one of them |
| -- is per-object constrained. |
| |
| Preprocess_Components (Comps, Num_Comps, Has_POC); |
| |
| -- The processing in this routine is done in the following order: |
| -- 1) Regular components |
| -- 2) Per-object constrained components |
| -- 3) Variant parts |
| |
| if Num_Comps > 0 then |
| |
| -- Process all regular components in order of declarations |
| |
| Decl := First_Non_Pragma (Component_Items (Comps)); |
| while Present (Decl) loop |
| Decl_Id := Defining_Identifier (Decl); |
| Decl_Typ := Etype (Decl_Id); |
| |
| -- Skip _parent as well as per-object constrained components |
| |
| if Chars (Decl_Id) /= Name_uParent |
| and then Needs_Finalization (Decl_Typ) |
| then |
| if Has_Access_Constraint (Decl_Id) |
| and then No (Expression (Decl)) |
| then |
| null; |
| else |
| Process_Component_For_Adjust (Decl); |
| end if; |
| end if; |
| |
| Next_Non_Pragma (Decl); |
| end loop; |
| |
| -- Process all per-object constrained components in order of |
| -- declarations. |
| |
| if Has_POC then |
| Decl := First_Non_Pragma (Component_Items (Comps)); |
| while Present (Decl) loop |
| Decl_Id := Defining_Identifier (Decl); |
| Decl_Typ := Etype (Decl_Id); |
| |
| -- Skip _parent |
| |
| if Chars (Decl_Id) /= Name_uParent |
| and then Needs_Finalization (Decl_Typ) |
| and then Has_Access_Constraint (Decl_Id) |
| and then No (Expression (Decl)) |
| then |
| Process_Component_For_Adjust (Decl); |
| end if; |
| |
| Next_Non_Pragma (Decl); |
| end loop; |
| end if; |
| end if; |
| |
| -- Process all variants, if any |
| |
| Var_Case := Empty; |
| if Present (Variant_Part (Comps)) then |
| declare |
| Var_Alts : constant List_Id := New_List; |
| Var : Node_Id; |
| |
| begin |
| Var := First_Non_Pragma (Variants (Variant_Part (Comps))); |
| while Present (Var) loop |
| |
| -- Generate: |
| -- when <discrete choices> => |
| -- <adjust statements> |
| |
| Append_To (Var_Alts, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => |
| New_Copy_List (Discrete_Choices (Var)), |
| Statements => |
| Process_Component_List_For_Adjust ( |
| Component_List (Var)))); |
| |
| Next_Non_Pragma (Var); |
| end loop; |
| |
| -- Generate: |
| -- case V.<discriminant> is |
| -- when <discrete choices 1> => |
| -- <adjust statements 1> |
| -- ... |
| -- when <discrete choices N> => |
| -- <adjust statements N> |
| -- end case; |
| |
| Var_Case := |
| Make_Case_Statement (Loc, |
| Expression => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Selector_Name => |
| Make_Identifier (Loc, |
| Chars => Chars (Name (Variant_Part (Comps))))), |
| Alternatives => Var_Alts); |
| end; |
| end if; |
| |
| -- Add the variant case statement to the list of statements |
| |
| if Present (Var_Case) then |
| Append_To (Stmts, Var_Case); |
| end if; |
| |
| -- If the component list did not have any controlled components |
| -- nor variants, return null. |
| |
| if Is_Empty_List (Stmts) then |
| Append_To (Stmts, Make_Null_Statement (Loc)); |
| end if; |
| |
| return Stmts; |
| end Process_Component_List_For_Adjust; |
| |
| -- Local variables |
| |
| Bod_Stmts : List_Id := No_List; |
| Finalizer_Decls : List_Id := No_List; |
| Rec_Def : Node_Id; |
| |
| -- Start of processing for Build_Adjust_Statements |
| |
| begin |
| Finalizer_Decls := New_List; |
| Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); |
| |
| if Nkind (Typ_Def) = N_Derived_Type_Definition then |
| Rec_Def := Record_Extension_Part (Typ_Def); |
| else |
| Rec_Def := Typ_Def; |
| end if; |
| |
| -- Create an adjust sequence for all record components |
| |
| if Present (Component_List (Rec_Def)) then |
| Bod_Stmts := |
| Process_Component_List_For_Adjust (Component_List (Rec_Def)); |
| end if; |
| |
| -- A derived record type must adjust all inherited components. This |
| -- action poses the following problem: |
| |
| -- procedure Deep_Adjust (Obj : in out Parent_Typ) is |
| -- begin |
| -- Adjust (Obj); |
| -- ... |
| |
| -- procedure Deep_Adjust (Obj : in out Derived_Typ) is |
| -- begin |
| -- Deep_Adjust (Obj._parent); |
| -- ... |
| -- Adjust (Obj); |
| -- ... |
| |
| -- Adjusting the derived type will invoke Adjust of the parent and |
| -- then that of the derived type. This is undesirable because both |
| -- routines may modify shared components. Only the Adjust of the |
| -- derived type should be invoked. |
| |
| -- To prevent this double adjustment of shared components, |
| -- Deep_Adjust uses a flag to control the invocation of Adjust: |
| |
| -- procedure Deep_Adjust |
| -- (Obj : in out Some_Type; |
| -- Flag : Boolean := True) |
| -- is |
| -- begin |
| -- if Flag then |
| -- Adjust (Obj); |
| -- end if; |
| -- ... |
| |
| -- When Deep_Adjust is invoked for field _parent, a value of False is |
| -- provided for the flag: |
| |
| -- Deep_Adjust (Obj._parent, False); |
| |
| if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then |
| declare |
| Par_Typ : constant Entity_Id := Parent_Field_Type (Typ); |
| Adj_Stmt : Node_Id; |
| Call : Node_Id; |
| |
| begin |
| if Needs_Finalization (Par_Typ) then |
| Call := |
| Make_Adjust_Call |
| (Obj_Ref => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uParent)), |
| Typ => Par_Typ, |
| Skip_Self => True); |
| |
| -- Generate: |
| -- begin |
| -- Deep_Adjust (V._parent, False); |
| |
| -- exception |
| -- when Id : others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, |
| -- Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| |
| if Present (Call) then |
| Adj_Stmt := Call; |
| |
| if Exceptions_OK then |
| Adj_Stmt := |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Adj_Stmt), |
| Exception_Handlers => New_List ( |
| Build_Exception_Handler (Finalizer_Data)))); |
| end if; |
| |
| Prepend_To (Bod_Stmts, Adj_Stmt); |
| end if; |
| end if; |
| end; |
| end if; |
| |
| -- Adjust the object. This action must be performed last after all |
| -- components have been adjusted. |
| |
| if Is_Controlled (Typ) then |
| declare |
| Adj_Stmt : Node_Id; |
| Proc : Entity_Id; |
| |
| begin |
| Proc := Find_Optional_Prim_Op (Typ, Name_Adjust); |
| |
| -- Generate: |
| -- if F then |
| -- begin |
| -- Adjust (V); |
| |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, |
| -- Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| -- end if; |
| |
| if Present (Proc) then |
| Adj_Stmt := |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Proc, Loc), |
| Parameter_Associations => New_List ( |
| Make_Identifier (Loc, Name_V))); |
| |
| if Exceptions_OK then |
| Adj_Stmt := |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Adj_Stmt), |
| Exception_Handlers => New_List ( |
| Build_Exception_Handler |
| (Finalizer_Data)))); |
| end if; |
| |
| Append_To (Bod_Stmts, |
| Make_If_Statement (Loc, |
| Condition => Make_Identifier (Loc, Name_F), |
| Then_Statements => New_List (Adj_Stmt))); |
| end if; |
| end; |
| end if; |
| |
| -- At this point either all adjustment statements have been generated |
| -- or the type is not controlled. |
| |
| if Is_Empty_List (Bod_Stmts) then |
| Append_To (Bod_Stmts, Make_Null_Statement (Loc)); |
| |
| return Bod_Stmts; |
| |
| -- Generate: |
| -- declare |
| -- Abort : constant Boolean := Triggered_By_Abort; |
| -- <or> |
| -- Abort : constant Boolean := False; -- no abort |
| |
| -- E : Exception_Occurrence; |
| -- Raised : Boolean := False; |
| |
| -- begin |
| -- <adjust statements> |
| |
| -- if Raised and then not Abort then |
| -- Raise_From_Controlled_Operation (E); |
| -- end if; |
| -- end; |
| |
| else |
| if Exceptions_OK then |
| Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data)); |
| end if; |
| |
| return |
| New_List ( |
| Make_Block_Statement (Loc, |
| Declarations => |
| Finalizer_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts))); |
| end if; |
| end Build_Adjust_Statements; |
| |
| ------------------------------- |
| -- Build_Finalize_Statements -- |
| ------------------------------- |
| |
| function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); |
| |
| Counter : Nat := 0; |
| Finalizer_Data : Finalization_Exception_Data; |
| Last_POC_Call : Node_Id := Empty; |
| |
| function Process_Component_List_For_Finalize |
| (Comps : Node_Id; |
| In_Variant_Part : Boolean := False) return List_Id; |
| -- Build all necessary finalization statements for a single component |
| -- list. The statements may include a jump circuitry if flag Is_Local |
| -- is enabled. In_Variant_Part indicates whether this is a recursive |
| -- call. |
| |
| ----------------------------------------- |
| -- Process_Component_List_For_Finalize -- |
| ----------------------------------------- |
| |
| function Process_Component_List_For_Finalize |
| (Comps : Node_Id; |
| In_Variant_Part : Boolean := False) return List_Id |
| is |
| procedure Process_Component_For_Finalize |
| (Decl : Node_Id; |
| Alts : List_Id; |
| Decls : List_Id; |
| Stmts : List_Id; |
| Num_Comps : in out Nat); |
| -- Process the declaration of a single controlled component. If |
| -- flag Is_Local is enabled, create the corresponding label and |
| -- jump circuitry. Alts is the list of case alternatives, Decls |
| -- is the top level declaration list where labels are declared |
| -- and Stmts is the list of finalization actions. Num_Comps |
| -- denotes the current number of components needing finalization. |
| |
| ------------------------------------ |
| -- Process_Component_For_Finalize -- |
| ------------------------------------ |
| |
| procedure Process_Component_For_Finalize |
| (Decl : Node_Id; |
| Alts : List_Id; |
| Decls : List_Id; |
| Stmts : List_Id; |
| Num_Comps : in out Nat) |
| is |
| Id : constant Entity_Id := Defining_Identifier (Decl); |
| Typ : constant Entity_Id := Etype (Id); |
| Fin_Call : Node_Id; |
| |
| begin |
| if Is_Local then |
| declare |
| Label : Node_Id; |
| Label_Id : Entity_Id; |
| |
| begin |
| -- Generate: |
| -- LN : label; |
| |
| Label_Id := |
| Make_Identifier (Loc, |
| Chars => New_External_Name ('L', Num_Comps)); |
| Set_Entity (Label_Id, |
| Make_Defining_Identifier (Loc, Chars (Label_Id))); |
| Label := Make_Label (Loc, Label_Id); |
| |
| Append_To (Decls, |
| Make_Implicit_Label_Declaration (Loc, |
| Defining_Identifier => Entity (Label_Id), |
| Label_Construct => Label)); |
| |
| -- Generate: |
| -- when N => |
| -- goto LN; |
| |
| Append_To (Alts, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_List ( |
| Make_Integer_Literal (Loc, Num_Comps)), |
| |
| Statements => New_List ( |
| Make_Goto_Statement (Loc, |
| Name => |
| New_Occurrence_Of (Entity (Label_Id), Loc))))); |
| |
| -- Generate: |
| -- <<LN>> |
| |
| Append_To (Stmts, Label); |
| |
| -- Decrease the number of components to be processed. |
| -- This action yields a new Label_Id in future calls. |
| |
| Num_Comps := Num_Comps - 1; |
| end; |
| end if; |
| |
| -- Generate: |
| -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation |
| |
| -- begin -- Exception handlers allowed |
| -- [Deep_]Finalize (V.Id); |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, |
| -- Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| |
| Fin_Call := |
| Make_Final_Call |
| (Obj_Ref => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Selector_Name => Make_Identifier (Loc, Chars (Id))), |
| Typ => Typ); |
| |
| -- Guard against a missing [Deep_]Finalize when the component |
| -- type was not properly frozen. |
| |
| if Present (Fin_Call) then |
| if Exceptions_OK then |
| Fin_Call := |
| 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)))); |
| end if; |
| |
| Append_To (Stmts, Fin_Call); |
| end if; |
| end Process_Component_For_Finalize; |
| |
| -- Local variables |
| |
| Alts : List_Id; |
| Counter_Id : Entity_Id := Empty; |
| Decl : Node_Id; |
| Decl_Id : Entity_Id; |
| Decl_Typ : Entity_Id; |
| Decls : List_Id; |
| Has_POC : Boolean; |
| Jump_Block : Node_Id; |
| Label : Node_Id; |
| Label_Id : Entity_Id; |
| Num_Comps : Nat; |
| Stmts : List_Id; |
| Var_Case : Node_Id; |
| |
| -- Start of processing for Process_Component_List_For_Finalize |
| |
| begin |
| -- Perform an initial check, look for controlled and per-object |
| -- constrained components. |
| |
| Preprocess_Components (Comps, Num_Comps, Has_POC); |
| |
| -- Create a state counter to service the current component list. |
| -- This step is performed before the variants are inspected in |
| -- order to generate the same state counter names as those from |
| -- Build_Initialize_Statements. |
| |
| if Num_Comps > 0 and then Is_Local then |
| Counter := Counter + 1; |
| |
| Counter_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name ('C', Counter)); |
| end if; |
| |
| -- Process the component in the following order: |
| -- 1) Variants |
| -- 2) Per-object constrained components |
| -- 3) Regular components |
| |
| -- Start with the variant parts |
| |
| Var_Case := Empty; |
| if Present (Variant_Part (Comps)) then |
| declare |
| Var_Alts : constant List_Id := New_List; |
| Var : Node_Id; |
| |
| begin |
| Var := First_Non_Pragma (Variants (Variant_Part (Comps))); |
| while Present (Var) loop |
| |
| -- Generate: |
| -- when <discrete choices> => |
| -- <finalize statements> |
| |
| Append_To (Var_Alts, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => |
| New_Copy_List (Discrete_Choices (Var)), |
| Statements => |
| Process_Component_List_For_Finalize ( |
| Component_List (Var), |
| In_Variant_Part => True))); |
| |
| Next_Non_Pragma (Var); |
| end loop; |
| |
| -- Generate: |
| -- case V.<discriminant> is |
| -- when <discrete choices 1> => |
| -- <finalize statements 1> |
| -- ... |
| -- when <discrete choices N> => |
| -- <finalize statements N> |
| -- end case; |
| |
| Var_Case := |
| Make_Case_Statement (Loc, |
| Expression => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Selector_Name => |
| Make_Identifier (Loc, |
| Chars => Chars (Name (Variant_Part (Comps))))), |
| Alternatives => Var_Alts); |
| end; |
| end if; |
| |
| -- The current component list does not have a single controlled |
| -- component, however it may contain variants. Return the case |
| -- statement for the variants or nothing. |
| |
| if Num_Comps = 0 then |
| if Present (Var_Case) then |
| return New_List (Var_Case); |
| else |
| return New_List (Make_Null_Statement (Loc)); |
| end if; |
| end if; |
| |
| -- Prepare all lists |
| |
| Alts := New_List; |
| Decls := New_List; |
| Stmts := New_List; |
| |
| -- Process all per-object constrained components in reverse order |
| |
| if Has_POC then |
| Decl := Last_Non_Pragma (Component_Items (Comps)); |
| while Present (Decl) loop |
| Decl_Id := Defining_Identifier (Decl); |
| Decl_Typ := Etype (Decl_Id); |
| |
| -- Skip _parent |
| |
| if Chars (Decl_Id) /= Name_uParent |
| and then Needs_Finalization (Decl_Typ) |
| and then Has_Access_Constraint (Decl_Id) |
| and then No (Expression (Decl)) |
| then |
| Process_Component_For_Finalize |
| (Decl, Alts, Decls, Stmts, Num_Comps); |
| end if; |
| |
| Prev_Non_Pragma (Decl); |
| end loop; |
| end if; |
| |
| if not In_Variant_Part then |
| Last_POC_Call := Last (Stmts); |
| -- In the case of a type extension, the deep-finalize call |
| -- for the _Parent component will be inserted here. |
| end if; |
| |
| -- Process the rest of the components in reverse order |
| |
| Decl := Last_Non_Pragma (Component_Items (Comps)); |
| while Present (Decl) loop |
| Decl_Id := Defining_Identifier (Decl); |
| Decl_Typ := Etype (Decl_Id); |
| |
| -- Skip _parent |
| |
| if Chars (Decl_Id) /= Name_uParent |
| and then Needs_Finalization (Decl_Typ) |
| then |
| -- Skip per-object constrained components since they were |
| -- handled in the above step. |
| |
| if Has_Access_Constraint (Decl_Id) |
| and then No (Expression (Decl)) |
| then |
| null; |
| else |
| Process_Component_For_Finalize |
| (Decl, Alts, Decls, Stmts, Num_Comps); |
| end if; |
| end if; |
| |
| Prev_Non_Pragma (Decl); |
| end loop; |
| |
| -- Generate: |
| -- declare |
| -- LN : label; -- If Is_Local is enabled |
| -- ... . |
| -- L0 : label; . |
| |
| -- begin . |
| -- case CounterX is . |
| -- when N => . |
| -- goto LN; . |
| -- ... . |
| -- when 1 => . |
| -- goto L1; . |
| -- when others => . |
| -- goto L0; . |
| -- end case; . |
| |
| -- <<LN>> -- If Is_Local is enabled |
| -- begin |
| -- [Deep_]Finalize (V.CompY); |
| -- exception |
| -- when Id : others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, |
| -- Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| -- ... |
| -- <<L0>> -- If Is_Local is enabled |
| -- end; |
| |
| if Is_Local then |
| |
| -- Add the declaration of default jump location L0, its |
| -- corresponding alternative and its place in the statements. |
| |
| Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0)); |
| Set_Entity (Label_Id, |
| Make_Defining_Identifier (Loc, Chars (Label_Id))); |
| Label := Make_Label (Loc, Label_Id); |
| |
| Append_To (Decls, -- declaration |
| Make_Implicit_Label_Declaration (Loc, |
| Defining_Identifier => Entity (Label_Id), |
| Label_Construct => Label)); |
| |
| Append_To (Alts, -- alternative |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_List ( |
| Make_Others_Choice (Loc)), |
| |
| Statements => New_List ( |
| Make_Goto_Statement (Loc, |
| Name => New_Occurrence_Of (Entity (Label_Id), Loc))))); |
| |
| Append_To (Stmts, Label); -- statement |
| |
| -- Create the jump block |
| |
| Prepend_To (Stmts, |
| Make_Case_Statement (Loc, |
| Expression => Make_Identifier (Loc, Chars (Counter_Id)), |
| Alternatives => Alts)); |
| end if; |
| |
| Jump_Block := |
| Make_Block_Statement (Loc, |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Stmts)); |
| |
| if Present (Var_Case) then |
| return New_List (Var_Case, Jump_Block); |
| else |
| return New_List (Jump_Block); |
| end if; |
| end Process_Component_List_For_Finalize; |
| |
| -- Local variables |
| |
| Bod_Stmts : List_Id := No_List; |
| Finalizer_Decls : List_Id := No_List; |
| Rec_Def : Node_Id; |
| |
| -- Start of processing for Build_Finalize_Statements |
| |
| begin |
| Finalizer_Decls := New_List; |
| Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); |
| |
| if Nkind (Typ_Def) = N_Derived_Type_Definition then |
| Rec_Def := Record_Extension_Part (Typ_Def); |
| else |
| Rec_Def := Typ_Def; |
| end if; |
| |
| -- Create a finalization sequence for all record components |
| |
| if Present (Component_List (Rec_Def)) then |
| Bod_Stmts := |
| Process_Component_List_For_Finalize (Component_List (Rec_Def)); |
| end if; |
| |
| -- A derived record type must finalize all inherited components. This |
| -- action poses the following problem: |
| |
| -- procedure Deep_Finalize (Obj : in out Parent_Typ) is |
| -- begin |
| -- Finalize (Obj); |
| -- ... |
| |
| -- procedure Deep_Finalize (Obj : in out Derived_Typ) is |
| -- begin |
| -- Deep_Finalize (Obj._parent); |
| -- ... |
| -- Finalize (Obj); |
| -- ... |
| |
| -- Finalizing the derived type will invoke Finalize of the parent and |
| -- then that of the derived type. This is undesirable because both |
| -- routines may modify shared components. Only the Finalize of the |
| -- derived type should be invoked. |
| |
| -- To prevent this double adjustment of shared components, |
| -- Deep_Finalize uses a flag to control the invocation of Finalize: |
| |
| -- procedure Deep_Finalize |
| -- (Obj : in out Some_Type; |
| -- Flag : Boolean := True) |
| -- is |
| -- begin |
| -- if Flag then |
| -- Finalize (Obj); |
| -- end if; |
| -- ... |
| |
| -- When Deep_Finalize is invoked for field _parent, a value of False |
| -- is provided for the flag: |
| |
| -- Deep_Finalize (Obj._parent, False); |
| |
| if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then |
| declare |
| Par_Typ : constant Entity_Id := Parent_Field_Type (Typ); |
| Call : Node_Id; |
| Fin_Stmt : Node_Id; |
| |
| begin |
| if Needs_Finalization (Par_Typ) then |
| Call := |
| Make_Final_Call |
| (Obj_Ref => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_V), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uParent)), |
| Typ => Par_Typ, |
| Skip_Self => True); |
| |
| -- Generate: |
| -- begin |
| -- Deep_Finalize (V._parent, False); |
| |
| -- exception |
| -- when Id : others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, |
| -- Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| |
| if Present (Call) then |
| Fin_Stmt := Call; |
| |
| if Exceptions_OK then |
| Fin_Stmt := |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Fin_Stmt), |
| Exception_Handlers => New_List ( |
| Build_Exception_Handler |
| (Finalizer_Data)))); |
| end if; |
| |
| -- The intended component finalization order is |
| -- 1) POC components of extension |
| -- 2) _Parent component |
| -- 3) non-POC components of extension. |
| -- |
| -- With this "finalize the parent part in the middle" |
| -- ordering, we can avoid the need for making two |
| -- calls to the parent's subprogram in the way that |
| -- is necessary for Init_Procs. This does have the |
| -- peculiar (but legal) consequence that the parent's |
| -- non-POC components are finalized before the |
| -- non-POC extension components. This violates the |
| -- usual "finalize in reverse declaration order" |
| -- principle, but that's ok (see Ada RM 7.6.1(9)). |
| -- |
| -- Last_POC_Call should be non-empty if the extension |
| -- has at least one POC. Interactions with variant |
| -- parts are incorrectly ignored. |
| |
| if Present (Last_POC_Call) then |
| Insert_After (Last_POC_Call, Fin_Stmt); |
| else |
| -- At this point, we could look for the common case |
| -- where there are no POC components anywhere in |
| -- sight (inherited or not) and, in that common case, |
| -- call Append_To instead of Prepend_To. That would |
| -- result in finalizing the parent part after, rather |
| -- than before, the extension components. That might |
| -- be more intuitive (as discussed in preceding |
| -- comment), but it is not required. |
| Prepend_To (Bod_Stmts, Fin_Stmt); |
| end if; |
| end if; |
| end if; |
| end; |
| end if; |
| |
| -- Finalize the object. This action must be performed first before |
| -- all components have been finalized. |
| |
| if Is_Controlled (Typ) and then not Is_Local then |
| declare |
| Fin_Stmt : Node_Id; |
| Proc : Entity_Id; |
| |
| begin |
| Proc := Find_Optional_Prim_Op (Typ, Name_Finalize); |
| |
| -- Generate: |
| -- if F then |
| -- begin |
| -- Finalize (V); |
| |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (E, |
| -- Get_Current_Excep.all.all); |
| -- end if; |
| -- end; |
| -- end if; |
| |
| if Present (Proc) then |
| Fin_Stmt := |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Proc, Loc), |
| Parameter_Associations => New_List ( |
| Make_Identifier (Loc, Name_V))); |
| |
| if Exceptions_OK then |
| Fin_Stmt := |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Fin_Stmt), |
| Exception_Handlers => New_List ( |
| Build_Exception_Handler |
| (Finalizer_Data)))); |
| end if; |
| |
| Prepend_To (Bod_Stmts, |
| Make_If_Statement (Loc, |
| Condition => Make_Identifier (Loc, Name_F), |
| Then_Statements => New_List (Fin_Stmt))); |
| end if; |
| end; |
| end if; |
| |
| -- At this point either all finalization statements have been |
| -- generated or the type is not controlled. |
| |
| if No (Bod_Stmts) then |
| return New_List (Make_Null_Statement (Loc)); |
| |
| -- Generate: |
| -- declare |
| -- Abort : constant Boolean := Triggered_By_Abort; |
| -- <or> |
| -- Abort : constant Boolean := False; -- no abort |
| |
| -- E : Exception_Occurrence; |
| -- Raised : Boolean := False; |
| |
| -- begin |
| -- <finalize statements> |
| |
| -- if Raised and then not Abort then |
| -- Raise_From_Controlled_Operation (E); |
| -- end if; |
| -- end; |
| |
| else |
| if Exceptions_OK then |
| Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data)); |
| end if; |
| |
| return |
| New_List ( |
| Make_Block_Statement (Loc, |
| Declarations => |
| Finalizer_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts))); |
| end if; |
| end Build_Finalize_Statements; |
| |
| ----------------------- |
| -- Parent_Field_Type -- |
| ----------------------- |
| |
| function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is |
| Field : Entity_Id; |
| |
| begin |
| Field := First_Entity (Typ); |
| while Present (Field) loop |
| if Chars (Field) = Name_uParent then |
| return Etype (Field); |
| end if; |
| |
| Next_Entity (Field); |
| end loop; |
| |
| -- A derived tagged type should always have a parent field |
| |
| raise Program_Error; |
| end Parent_Field_Type; |
| |
| --------------------------- |
| -- Preprocess_Components -- |
| --------------------------- |
| |
| procedure Preprocess_Components |
| (Comps : Node_Id; |
| Num_Comps : out Nat; |
| Has_POC : out Boolean) |
| is |
| Decl : Node_Id; |
| Id : Entity_Id; |
| Typ : Entity_Id; |
| |
| begin |
| Num_Comps := 0; |
| Has_POC := False; |
| |
| Decl := First_Non_Pragma (Component_Items (Comps)); |
| while Present (Decl) loop |
| Id := Defining_Identifier (Decl); |
| Typ := Etype (Id); |
| |
| -- Skip field _parent |
| |
| if Chars (Id) /= Name_uParent |
| and then Needs_Finalization (Typ) |
| then |
| Num_Comps := Num_Comps + 1; |
| |
| if Has_Access_Constraint (Id) |
| and then No (Expression (Decl)) |
| then |
| Has_POC := True; |
| end if; |
| end if; |
| |
| Next_Non_Pragma (Decl); |
| end loop; |
| end Preprocess_Components; |
| |
| -- Start of processing for Make_Deep_Record_Body |
| |
| begin |
| case Prim is |
| when Address_Case => |
| return Make_Finalize_Address_Stmts (Typ); |
| |
| when Adjust_Case => |
| return Build_Adjust_Statements (Typ); |
| |
| when Finalize_Case => |
| return Build_Finalize_Statements (Typ); |
| |
| when Initialize_Case => |
| declare |
| Loc : constant Source_Ptr := Sloc (Typ); |
| |
| begin |
| if Is_Controlled (Typ) then |
| return New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (Find_Prim_Op (Typ, Name_Of (Prim)), Loc), |
| Parameter_Associations => New_List ( |
| Make_Identifier (Loc, Name_V)))); |
| else |
| return Empty_List; |
| end if; |
| end; |
| end case; |
| end Make_Deep_Record_Body; |
| |
| ---------------------- |
| -- Make_Final_Call -- |
| ---------------------- |
| |
| function Make_Final_Call |
| (Obj_Ref : Node_Id; |
| Typ : Entity_Id; |
| Skip_Self : Boolean := False) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Obj_Ref); |
| Atyp : Entity_Id; |
| Prot_Typ : Entity_Id := Empty; |
| Fin_Id : Entity_Id := Empty; |
| Ref : Node_Id; |
| Utyp : Entity_Id; |
| |
| begin |
| Ref := Obj_Ref; |
| |
| -- Recover the proper type which contains [Deep_]Finalize |
| |
| if Is_Class_Wide_Type (Typ) then |
| Utyp := Root_Type (Typ); |
| Atyp := Utyp; |
| |
| elsif Is_Concurrent_Type (Typ) then |
| Utyp := Corresponding_Record_Type (Typ); |
| Atyp := Empty; |
| Ref := Convert_Concurrent (Ref, Typ); |
| |
| elsif Is_Private_Type (Typ) |
| and then Present (Underlying_Type (Typ)) |
| and then Is_Concurrent_Type (Underlying_Type (Typ)) |
| then |
| Utyp := Corresponding_Record_Type (Underlying_Type (Typ)); |
| Atyp := Typ; |
| Ref := Convert_Concurrent (Ref, Underlying_Type (Typ)); |
| |
| else |
| Utyp := Typ; |
| Atyp := Typ; |
| end if; |
| |
| Utyp := Underlying_Type (Base_Type (Utyp)); |
| Set_Assignment_OK (Ref); |
| |
| -- Deal with untagged derivation of private views. If the parent type |
| -- is a protected type, Deep_Finalize is found on the corresponding |
| -- record of the ancestor. |
| |
| if Is_Untagged_Derivation (Typ) then |
| if Is_Protected_Type (Typ) then |
| Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); |
| else |
| Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); |
| |
| if Is_Protected_Type (Utyp) then |
| Utyp := Corresponding_Record_Type (Utyp); |
| end if; |
| end if; |
| |
| Ref := Unchecked_Convert_To (Utyp, Ref); |
| Set_Assignment_OK (Ref); |
| end if; |
| |
| -- Deal with derived private types which do not inherit primitives from |
| -- their parents. In this case, [Deep_]Finalize can be found in the full |
| -- view of the parent type. |
| |
| if Present (Utyp) |
| and then Is_Tagged_Type (Utyp) |
| and then Is_Derived_Type (Utyp) |
| and then Is_Empty_Elmt_List (Primitive_Operations (Utyp)) |
| and then Is_Private_Type (Etype (Utyp)) |
| and then Present (Full_View (Etype (Utyp))) |
| then |
| Utyp := Full_View (Etype (Utyp)); |
| Ref := Unchecked_Convert_To (Utyp, Ref); |
| Set_Assignment_OK (Ref); |
| end if; |
| |
| -- When dealing with the completion of a private type, use the base type |
| -- instead. |
| |
| if Present (Utyp) and then Utyp /= Base_Type (Utyp) then |
| pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp)); |
| |
| Utyp := Base_Type (Utyp); |
| Ref := Unchecked_Convert_To (Utyp, Ref); |
| Set_Assignment_OK (Ref); |
| end if; |
| |
| -- Detect if Typ is a protected type or an expanded protected type and |
| -- store the relevant type within Prot_Typ for later processing. |
| |
| if Is_Protected_Type (Typ) then |
| Prot_Typ := Typ; |
| |
| elsif Ekind (Typ) = E_Record_Type |
| and then Present (Corresponding_Concurrent_Type (Typ)) |
| and then Is_Protected_Type (Corresponding_Concurrent_Type (Typ)) |
| then |
| Prot_Typ := Corresponding_Concurrent_Type (Typ); |
| end if; |
| |
| -- The underlying type may not be present due to a missing full view. In |
| -- this case freezing did not take place and there is no [Deep_]Finalize |
| -- primitive to call. |
| |
| if No (Utyp) then |
| return Empty; |
| |
| elsif Skip_Self then |
| if Has_Controlled_Component (Utyp) then |
| if Is_Tagged_Type (Utyp) then |
| Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); |
| else |
| Fin_Id := TSS (Utyp, TSS_Deep_Finalize); |
| end if; |
| end if; |
| |
| -- Class-wide types, interfaces and types with controlled components |
| |
| elsif Is_Class_Wide_Type (Typ) |
| or else Is_Interface (Typ) |
| or else Has_Controlled_Component (Utyp) |
| then |
| if Is_Tagged_Type (Utyp) then |
| Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); |
| else |
| Fin_Id := TSS (Utyp, TSS_Deep_Finalize); |
| end if; |
| |
| -- Derivations from [Limited_]Controlled |
| |
| elsif Is_Controlled (Utyp) then |
| if Has_Controlled_Component (Utyp) then |
| Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); |
| else |
| Fin_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Finalize_Case)); |
| end if; |
| |
| -- Tagged types |
| |
| elsif Is_Tagged_Type (Utyp) then |
| Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); |
| |
| -- Protected types: these also require finalization even though they |
| -- are not marked controlled explicitly. |
| |
| elsif Present (Prot_Typ) then |
| -- Protected objects do not need to be finalized on restricted |
| -- runtimes. |
| |
| if Restricted_Profile then |
| return Empty; |
| |
| -- ??? Only handle the simple case for now. Will not support a record |
| -- or array containing protected objects. |
| |
| elsif Is_Simple_Protected_Type (Prot_Typ) then |
| Fin_Id := RTE (RE_Finalize_Protection); |
| else |
| raise Program_Error; |
| end if; |
| else |
| raise Program_Error; |
| end if; |
| |
| if Present (Fin_Id) then |
| |
| -- When finalizing a class-wide object, do not convert to the root |
| -- type in order to produce a dispatching call. |
| |
| if Is_Class_Wide_Type (Typ) then |
| null; |
| |
| -- Ensure that a finalization routine is at least decorated in order |
| -- to inspect the object parameter. |
| |
| elsif Analyzed (Fin_Id) |
| or else Ekind (Fin_Id) = E_Procedure |
| then |
| -- In certain cases, such as the creation of Stream_Read, the |
| -- visible entity of the type is its full view. Since Stream_Read |
| -- will have to create an object of type Typ, the local object |
| -- will be finalzed by the scope finalizer generated later on. The |
| -- object parameter of Deep_Finalize will always use the private |
| -- view of the type. To avoid such a clash between a private and a |
| -- full view, perform an unchecked conversion of the object |
| -- reference to the private view. |
| |
| declare |
| Formal_Typ : constant Entity_Id := |
| Etype (First_Formal (Fin_Id)); |
| begin |
| if Is_Private_Type (Formal_Typ) |
| and then Present (Full_View (Formal_Typ)) |
| and then Full_View (Formal_Typ) = Utyp |
| then |
| Ref := Unchecked_Convert_To (Formal_Typ, Ref); |
| end if; |
| end; |
| |
| -- If the object is unanalyzed, set its expected type for use in |
| -- Convert_View in case an additional conversion is needed. |
| |
| if No (Etype (Ref)) |
| and then Nkind (Ref) /= N_Unchecked_Type_Conversion |
| then |
| Set_Etype (Ref, Typ); |
| end if; |
| |
| Ref := Convert_View (Fin_Id, Ref); |
| end if; |
| |
| return |
| Make_Call (Loc, |
| Proc_Id => Fin_Id, |
| Param => Ref, |
| Skip_Self => Skip_Self); |
| else |
| return Empty; |
| end if; |
| end Make_Final_Call; |
| |
| -------------------------------- |
| -- Make_Finalize_Address_Body -- |
| -------------------------------- |
| |
| procedure Make_Finalize_Address_Body (Typ : Entity_Id) is |
| Is_Task : constant Boolean := |
| Ekind (Typ) = E_Record_Type |
| and then Is_Concurrent_Record_Type (Typ) |
| and then Ekind (Corresponding_Concurrent_Type (Typ)) = |
| E_Task_Type; |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Proc_Id : Entity_Id; |
| Stmts : List_Id; |
| |
| begin |
| -- The corresponding records of task types are not controlled by design. |
| -- For the sake of completeness, create an empty Finalize_Address to be |
| -- used in task class-wide allocations. |
| |
| if Is_Task then |
| null; |
| |
| -- Nothing to do if the type is not controlled or it already has a |
| -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not |
| -- come from source. These are usually generated for completeness and |
| -- do not need the Finalize_Address primitive. |
| |
| elsif not Needs_Finalization (Typ) |
| or else Present (TSS (Typ, TSS_Finalize_Address)) |
| or else |
| (Is_Class_Wide_Type (Typ) |
| and then Ekind (Root_Type (Typ)) = E_Record_Subtype |
| and then not Comes_From_Source (Root_Type (Typ))) |
| then |
| return; |
| end if; |
| |
| -- Do not generate Finalize_Address routine for CodePeer |
| |
| if CodePeer_Mode then |
| return; |
| end if; |
| |
| Proc_Id := |
| Make_Defining_Identifier (Loc, |
| Make_TSS_Name (Typ, TSS_Finalize_Address)); |
| |
| -- Generate: |
| |
| -- procedure <Typ>FD (V : System.Address) is |
| -- begin |
| -- null; -- for tasks |
| |
| -- declare -- for all other types |
| -- type Pnn is access all Typ; |
| -- for Pnn'Storage_Size use 0; |
| -- begin |
| -- [Deep_]Finalize (Pnn (V).all); |
| -- end; |
| -- end TypFD; |
| |
| if Is_Task then |
| Stmts := New_List (Make_Null_Statement (Loc)); |
| else |
| Stmts := Make_Finalize_Address_Stmts (Typ); |
| end if; |
| |
| Discard_Node ( |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Proc_Id, |
| |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_V), |
| Parameter_Type => |
| New_Occurrence_Of (RTE (RE_Address), Loc)))), |
| |
| Declarations => No_List, |
| |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stmts))); |
| |
| Set_TSS (Typ, Proc_Id); |
| end Make_Finalize_Address_Body; |
| |
| --------------------------------- |
| -- Make_Finalize_Address_Stmts -- |
| --------------------------------- |
| |
| function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| |
| Decls : List_Id; |
| Desig_Typ : Entity_Id; |
| Fin_Block : Node_Id; |
| Fin_Call : Node_Id; |
| Obj_Expr : Node_Id; |
| Ptr_Typ : Entity_Id; |
| |
| begin |
| if Is_Array_Type (Typ) then |
| if Is_Constrained (First_Subtype (Typ)) then |
| Desig_Typ := First_Subtype (Typ); |
| else |
| Desig_Typ := Base_Type (Typ); |
| end if; |
| |
| -- Class-wide types of constrained root types |
| |
| elsif Is_Class_Wide_Type (Typ) |
| and then Has_Discriminants (Root_Type (Typ)) |
| and then not |
| Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ))) |
| then |
| declare |
| Parent_Typ : Entity_Id; |
| |
| begin |
| -- Climb the parent type chain looking for a non-constrained type |
| |
| Parent_Typ := Root_Type (Typ); |
| while Parent_Typ /= Etype (Parent_Typ) |
| and then Has_Discriminants (Parent_Typ) |
| and then not |
| Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ)) |
| loop |
| Parent_Typ := Etype (Parent_Typ); |
| end loop; |
| |
| -- Handle views created for tagged types with unknown |
| -- discriminants. |
| |
| if Is_Underlying_Record_View (Parent_Typ) then |
| Parent_Typ := Underlying_Record_View (Parent_Typ); |
| end if; |
| |
| Desig_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ)); |
| end; |
| |
| -- General case |
| |
| else |
| Desig_Typ := Typ; |
| end if; |
| |
| -- Generate: |
| -- type Ptr_Typ is access all Typ; |
| -- for Ptr_Typ'Storage_Size use 0; |
| |
| Ptr_Typ := Make_Temporary (Loc, 'P'); |
| |
| Decls := New_List ( |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => Ptr_Typ, |
| Type_Definition => |
| Make_Access_To_Object_Definition (Loc, |
| All_Present => True, |
| Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))), |
| |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Occurrence_Of (Ptr_Typ, Loc), |
| Chars => Name_Storage_Size, |
| Expression => Make_Integer_Literal (Loc, 0))); |
| |
| Obj_Expr := Make_Identifier (Loc, Name_V); |
| |
| -- Unconstrained arrays require special processing in order to retrieve |
| -- the elements. To achieve this, we have to skip the dope vector which |
| -- lays in front of the elements and then use a thin pointer to perform |
| -- the address-to-access conversion. |
| |
| if Is_Array_Type (Typ) |
| and then not Is_Constrained (First_Subtype (Typ)) |
| then |
| declare |
| Dope_Id : Entity_Id; |
| |
| begin |
| -- Ensure that Ptr_Typ is a thin pointer; generate: |
| -- for Ptr_Typ'Size use System.Address'Size; |
| |
| Append_To (Decls, |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Occurrence_Of (Ptr_Typ, Loc), |
| Chars => Name_Size, |
| Expression => |
| Make_Integer_Literal (Loc, System_Address_Size))); |
| |
| -- Generate: |
| -- Dnn : constant Storage_Offset := |
| -- Desig_Typ'Descriptor_Size / Storage_Unit; |
| |
| Dope_Id := Make_Temporary (Loc, 'D'); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Dope_Id, |
| Constant_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Storage_Offset), Loc), |
| Expression => |
| Make_Op_Divide (Loc, |
| Left_Opnd => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Desig_Typ, Loc), |
| Attribute_Name => Name_Descriptor_Size), |
| Right_Opnd => |
| Make_Integer_Literal (Loc, System_Storage_Unit)))); |
| |
| -- Shift the address from the start of the dope vector to the |
| -- start of the elements: |
| -- |
| -- V + Dnn |
| -- |
| -- Note that this is done through a wrapper routine since RTSfind |
| -- cannot retrieve operations with string names of the form "+". |
| |
| Obj_Expr := |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Add_Offset_To_Address), Loc), |
| Parameter_Associations => New_List ( |
| Obj_Expr, |
| New_Occurrence_Of (Dope_Id, Loc))); |
| end; |
| end if; |
| |
| Fin_Call := |
| Make_Final_Call ( |
| Obj_Ref => |
| Make_Explicit_Dereference (Loc, |
| Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)), |
| Typ => Desig_Typ); |
| |
| if Present (Fin_Call) then |
| Fin_Block := |
| Make_Block_Statement (Loc, |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Fin_Call))); |
| |
| -- Otherwise previous errors or a missing full view may prevent the |
| -- proper freezing of the designated type. If this is the case, there |
| -- is no [Deep_]Finalize primitive to call. |
| |
| else |
| Fin_Block := Make_Null_Statement (Loc); |
| end if; |
| |
| return New_List (Fin_Block); |
| end Make_Finalize_Address_Stmts; |
| |
| ------------------------------------- |
| -- Make_Handler_For_Ctrl_Operation -- |
| ------------------------------------- |
| |
| -- Generate: |
| |
| -- when E : others => |
| -- Raise_From_Controlled_Operation (E); |
| |
| -- or: |
| |
| -- when others => |
| -- raise Program_Error [finalize raised exception]; |
| |
| -- depending on whether Raise_From_Controlled_Operation is available |
| |
| function Make_Handler_For_Ctrl_Operation |
| (Loc : Source_Ptr) return Node_Id |
| is |
| E_Occ : Entity_Id; |
| -- Choice parameter (for the first case above) |
| |
| Raise_Node : Node_Id; |
| -- Procedure call or raise statement |
| |
| begin |
| -- Standard run-time: add choice parameter E and pass it to |
| -- Raise_From_Controlled_Operation so that the original exception |
| -- name and message can be recorded in the exception message for |
| -- Program_Error. |
| |
| if RTE_Available (RE_Raise_From_Controlled_Operation) then |
| E_Occ := Make_Defining_Identifier (Loc, Name_E); |
| Raise_Node := |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Raise_From_Controlled_Operation), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (E_Occ, Loc))); |
| |
| -- Restricted run-time: exception messages are not supported |
| |
| else |
| E_Occ := Empty; |
| Raise_Node := |
| Make_Raise_Program_Error (Loc, |
| Reason => PE_Finalize_Raised_Exception); |
| end if; |
| |
| return |
| Make_Implicit_Exception_Handler (Loc, |
| Exception_Choices => New_List (Make_Others_Choice (Loc)), |
| Choice_Parameter => E_Occ, |
| Statements => New_List (Raise_Node)); |
| end Make_Handler_For_Ctrl_Operation; |
| |
| -------------------- |
| -- Make_Init_Call -- |
| -------------------- |
| |
| function Make_Init_Call |
| (Obj_Ref : Node_Id; |
| Typ : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Obj_Ref); |
| Is_Conc : Boolean; |
| Proc : Entity_Id; |
| Ref : Node_Id; |
| Utyp : Entity_Id; |
| |
| begin |
| Ref := Obj_Ref; |
| |
| -- Deal with the type and object reference. Depending on the context, an |
| -- object reference may need several conversions. |
| |
| if Is_Concurrent_Type (Typ) then |
| Is_Conc := True; |
| Utyp := Corresponding_Record_Type (Typ); |
| Ref := Convert_Concurrent (Ref, Typ); |
| |
| elsif Is_Private_Type (Typ) |
| and then Present (Full_View (Typ)) |
| and then Is_Concurrent_Type (Underlying_Type (Typ)) |
| then |
| Is_Conc := True; |
| Utyp := Corresponding_Record_Type (Underlying_Type (Typ)); |
| Ref := Convert_Concurrent (Ref, Underlying_Type (Typ)); |
| |
| else |
| Is_Conc := False; |
| Utyp := Typ; |
| end if; |
| |
| Utyp := Underlying_Type (Base_Type (Utyp)); |
| Set_Assignment_OK (Ref); |
| |
| -- Deal with untagged derivation of private views |
| |
| if Is_Untagged_Derivation (Typ) and then not Is_Conc then |
| Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); |
| Ref := Unchecked_Convert_To (Utyp, Ref); |
| |
| -- The following is to prevent problems with UC see 1.156 RH ??? |
| |
| Set_Assignment_OK (Ref); |
| end if; |
| |
| -- If the underlying_type is a subtype, then we are dealing with the |
| -- completion of a private type. We need to access the base type and |
| -- generate a conversion to it. |
| |
| if Present (Utyp) and then Utyp /= Base_Type (Utyp) then |
| pragma Assert (Is_Private_Type (Typ)); |
| Utyp := Base_Type (Utyp); |
| Ref := Unchecked_Convert_To (Utyp, Ref); |
| end if; |
| |
| -- The underlying type may not be present due to a missing full view. |
| -- In this case freezing did not take place and there is no suitable |
| -- [Deep_]Initialize primitive to call. |
| -- If Typ is protected then no additional processing is needed either. |
| |
| if No (Utyp) |
| or else Is_Protected_Type (Typ) |
| then |
| return Empty; |
| end if; |
| |
| -- Select the appropriate version of initialize |
| |
| if Has_Controlled_Component (Utyp) then |
| Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case)); |
| else |
| Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case)); |
| Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref); |
| end if; |
| |
| -- If initialization procedure for an array of controlled objects is |
| -- trivial, do not generate a useless call to it. |
| -- The initialization procedure may be missing altogether in the case |
| -- of a derived container whose components have trivial initialization. |
| |
| if No (Proc) |
| or else (Is_Array_Type (Utyp) and then Is_Trivial_Subprogram (Proc)) |
| or else |
| (not Comes_From_Source (Proc) |
| and then Present (Alias (Proc)) |
| and then Is_Trivial_Subprogram (Alias (Proc))) |
| then |
| return Empty; |
| end if; |
| |
| -- The object reference may need another conversion depending on the |
| -- type of the formal and that of the actual. |
| |
| Ref := Convert_View (Proc, Ref); |
| |
| -- Generate: |
| -- [Deep_]Initialize (Ref); |
| |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Proc, Loc), |
| Parameter_Associations => New_List (Ref)); |
| end Make_Init_Call; |
| |
| ------------------------------ |
| -- Make_Local_Deep_Finalize -- |
| ------------------------------ |
| |
| function Make_Local_Deep_Finalize |
| (Typ : Entity_Id; |
| Nam : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Formals : List_Id; |
| |
| begin |
| Formals := New_List ( |
| |
| -- V : in out Typ |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), |
| In_Present => True, |
| Out_Present => True, |
| Parameter_Type => New_Occurrence_Of (Typ, Loc)), |
| |
| -- F : Boolean := True |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_F), |
| Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), |
| Expression => New_Occurrence_Of (Standard_True, Loc))); |
| |
| -- Add the necessary number of counters to represent the initialization |
| -- state of an object. |
| |
| return |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Nam, |
| Parameter_Specifications => Formals), |
| |
| Declarations => No_List, |
| |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True))); |
| end Make_Local_Deep_Finalize; |
| |
| ------------------------------------ |
| -- Make_Set_Finalize_Address_Call -- |
| ------------------------------------ |
| |
| function Make_Set_Finalize_Address_Call |
| (Loc : Source_Ptr; |
| Ptr_Typ : Entity_Id) return Node_Id |
| is |
| -- It is possible for Ptr_Typ to be a partial view, if the access type |
| -- is a full view declared in the private part of a nested package, and |
| -- the finalization actions take place when completing analysis of the |
| -- enclosing unit. For this reason use Underlying_Type twice below. |
| |
| Desig_Typ : constant Entity_Id := |
| Available_View |
| (Designated_Type (Underlying_Type (Ptr_Typ))); |
| Fin_Addr : constant Entity_Id := Finalize_Address (Desig_Typ); |
| Fin_Mas : constant Entity_Id := |
| Finalization_Master (Underlying_Type (Ptr_Typ)); |
| |
| begin |
| -- Both the finalization master and primitive Finalize_Address must be |
| -- available. |
| |
| pragma Assert (Present (Fin_Addr) and Present (Fin_Mas)); |
| |
| -- Generate: |
| -- Set_Finalize_Address |
| -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access); |
| |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Set_Finalize_Address), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Fin_Mas, Loc), |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Fin_Addr, Loc), |
| Attribute_Name => Name_Unrestricted_Access))); |
| end Make_Set_Finalize_Address_Call; |
| |
| -------------------------- |
| -- Make_Transient_Block -- |
| -------------------------- |
| |
| function Make_Transient_Block |
| (Loc : Source_Ptr; |
| Action : Node_Id; |
| Par : Node_Id) return Node_Id |
| is |
| function Manages_Sec_Stack (Id : Entity_Id) return Boolean; |
| -- Determine whether scoping entity Id manages the secondary stack |
| |
| function Within_Loop_Statement (N : Node_Id) return Boolean; |
| -- Return True when N appears within a loop and no block is containing N |
| |
| ----------------------- |
| -- Manages_Sec_Stack -- |
| ----------------------- |
| |
| function Manages_Sec_Stack (Id : Entity_Id) return Boolean is |
| begin |
| case Ekind (Id) is |
| |
| -- An exception handler with a choice parameter utilizes a dummy |
| -- block to provide a declarative region. Such a block should not |
| -- be considered because it never manifests in the tree and can |
| -- never release the secondary stack. |
| |
| when E_Block => |
| return |
| Uses_Sec_Stack (Id) and then not Is_Exception_Handler (Id); |
| |
| when E_Entry |
| | E_Entry_Family |
| | E_Function |
| | E_Procedure |
| => |
| return Uses_Sec_Stack (Id); |
| |
| when others => |
| return False; |
| end case; |
| end Manages_Sec_Stack; |
| |
| --------------------------- |
| -- Within_Loop_Statement -- |
| --------------------------- |
| |
| function Within_Loop_Statement (N : Node_Id) return Boolean is |
| Par : Node_Id := Parent (N); |
| |
| begin |
| while Nkind (Par) not in |
| N_Handled_Sequence_Of_Statements | N_Loop_Statement | |
| N_Package_Specification | N_Proper_Body |
| loop |
| pragma Assert (Present (Par)); |
| Par := Parent (Par); |
| end loop; |
| |
| return Nkind (Par) = N_Loop_Statement; |
| end Within_Loop_Statement; |
| |
| -- Local variables |
| |
| Decls : constant List_Id := New_List; |
| Instrs : constant List_Id := New_List (Action); |
| Trans_Id : constant Entity_Id := Current_Scope; |
| |
| Block : Node_Id; |
| Insert : Node_Id; |
| Scop : Entity_Id; |
| |
| -- Start of processing for Make_Transient_Block |
| |
| begin |
| -- Even though the transient block is tasked with managing the secondary |
| -- stack, the block may forgo this functionality depending on how the |
| -- secondary stack is managed by enclosing scopes. |
| |
| if Manages_Sec_Stack (Trans_Id) then |
| |
| -- Determine whether an enclosing scope already manages the secondary |
| -- stack. |
| |
| Scop := Scope (Trans_Id); |
| while Present (Scop) loop |
| |
| -- It should not be possible to reach Standard without hitting one |
| -- of the other cases first unless Standard was manually pushed. |
| |
| if Scop = Standard_Standard then |
| exit; |
| |
| -- The transient block is within a function which returns on the |
| -- secondary stack. Take a conservative approach and assume that |
| -- the value on the secondary stack is part of the result. Note |
| -- that it is not possible to detect this dependency without flow |
| -- analysis which the compiler does not have. Letting the object |
| -- live longer than the transient block will not leak any memory |
| -- because the caller will reclaim the total storage used by the |
| -- function. |
| |
| elsif Ekind (Scop) = E_Function |
| and then Sec_Stack_Needed_For_Return (Scop) |
| then |
| Set_Uses_Sec_Stack (Trans_Id, False); |
| exit; |
| |
| -- The transient block must manage the secondary stack when the |
| -- block appears within a loop in order to reclaim the memory at |
| -- each iteration. |
| |
| elsif Ekind (Scop) = E_Loop then |
| exit; |
| |
| -- Ditto when the block appears without a block that does not |
| -- manage the secondary stack and is located within a loop. |
| |
| elsif Ekind (Scop) = E_Block |
| and then not Manages_Sec_Stack (Scop) |
| and then Present (Block_Node (Scop)) |
| and then Within_Loop_Statement (Block_Node (Scop)) |
| then |
| exit; |
| |
| -- The transient block does not need to manage the secondary stack |
| -- when there is an enclosing construct which already does that. |
| -- This optimization saves on SS_Mark and SS_Release calls but may |
| -- allow objects to live a little longer than required. |
| |
| -- The transient block must manage the secondary stack when switch |
| -- -gnatd.s (strict management) is in effect. |
| |
| elsif Manages_Sec_Stack (Scop) and then not Debug_Flag_Dot_S then |
| Set_Uses_Sec_Stack (Trans_Id, False); |
| exit; |
| |
| -- Prevent the search from going too far because transient blocks |
| -- are bounded by packages and subprogram scopes. |
| |
| elsif Ekind (Scop) in E_Entry |
| | E_Entry_Family |
| | E_Function |
| | E_Package |
| | E_Procedure |
| | E_Subprogram_Body |
| then |
| exit; |
| end if; |
| |
| Scop := Scope (Scop); |
| end loop; |
| end if; |
| |
| -- Create the transient block. Set the parent now since the block itself |
| -- is not part of the tree. The current scope is the E_Block entity that |
| -- has been pushed by Establish_Transient_Scope. |
| |
| pragma Assert (Ekind (Trans_Id) = E_Block); |
| |
| Block := |
| Make_Block_Statement (Loc, |
| Identifier => New_Occurrence_Of (Trans_Id, Loc), |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs), |
| Has_Created_Identifier => True); |
| Set_Parent (Block, Par); |
| |
| -- Insert actions stuck in the transient scopes as well as all freezing |
| -- nodes needed by those actions. Do not insert cleanup actions here, |
| -- they will be transferred to the newly created block. |
| |
| Insert_Actions_In_Scope_Around |
| (Action, Clean => False, Manage_SS => False); |
| |
| Insert := Prev (Action); |
| |
| if Present (Insert) then |
| Freeze_All (First_Entity (Trans_Id), Insert); |
| end if; |
| |
| -- Transfer cleanup actions to the newly created block |
| |
| declare |
| Cleanup_Actions : List_Id |
| renames Scope_Stack.Table (Scope_Stack.Last). |
| Actions_To_Be_Wrapped (Cleanup); |
| begin |
| Set_Cleanup_Actions (Block, Cleanup_Actions); |
| Cleanup_Actions := No_List; |
| end; |
| |
| -- When the transient scope was established, we pushed the entry for the |
| -- transient scope onto the scope stack, so that the scope was active |
| -- for the installation of finalizable entities etc. Now we must remove |
| -- this entry, since we have constructed a proper block. |
| |
| Pop_Scope; |
| |
| return Block; |
| end Make_Transient_Block; |
| |
| ------------------------ |
| -- Node_To_Be_Wrapped -- |
| ------------------------ |
| |
| function Node_To_Be_Wrapped return Node_Id is |
| begin |
| return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped; |
| end Node_To_Be_Wrapped; |
| |
| ---------------------------- |
| -- Store_Actions_In_Scope -- |
| ---------------------------- |
| |
| procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id) is |
| SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); |
| Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK); |
| |
| begin |
| if Is_Empty_List (Actions) then |
| Actions := L; |
| |
| if Is_List_Member (SE.Node_To_Be_Wrapped) then |
| Set_Parent (L, Parent (SE.Node_To_Be_Wrapped)); |
| else |
| Set_Parent (L, SE.Node_To_Be_Wrapped); |
| end if; |
| |
| Analyze_List (L); |
| |
| elsif AK = Before then |
| Insert_List_After_And_Analyze (Last (Actions), L); |
| |
| else |
| Insert_List_Before_And_Analyze (First (Actions), L); |
| end if; |
| end Store_Actions_In_Scope; |
| |
| ---------------------------------- |
| -- Store_After_Actions_In_Scope -- |
| ---------------------------------- |
| |
| procedure Store_After_Actions_In_Scope (L : List_Id) is |
| begin |
| Store_Actions_In_Scope (After, L); |
| end Store_After_Actions_In_Scope; |
| |
| ----------------------------------- |
| -- Store_Before_Actions_In_Scope -- |
| ----------------------------------- |
| |
| procedure Store_Before_Actions_In_Scope (L : List_Id) is |
| begin |
| Store_Actions_In_Scope (Before, L); |
| end Store_Before_Actions_In_Scope; |
| |
| ----------------------------------- |
| -- Store_Cleanup_Actions_In_Scope -- |
| ----------------------------------- |
| |
| procedure Store_Cleanup_Actions_In_Scope (L : List_Id) is |
| begin |
| Store_Actions_In_Scope (Cleanup, L); |
| end Store_Cleanup_Actions_In_Scope; |
| |
| ------------------ |
| -- Unnest_Block -- |
| ------------------ |
| |
| procedure Unnest_Block (Decl : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (Decl); |
| Ent : Entity_Id; |
| Local_Body : Node_Id; |
| Local_Call : Node_Id; |
| Local_Proc : Entity_Id; |
| Local_Scop : Entity_Id; |
| |
| begin |
| Local_Scop := Entity (Identifier (Decl)); |
| Ent := First_Entity (Local_Scop); |
| |
| Local_Proc := Make_Temporary (Loc, 'P'); |
| |
| Local_Body := |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Local_Proc), |
| Declarations => Declarations (Decl), |
| Handled_Statement_Sequence => |
| Handled_Statement_Sequence (Decl)); |
| |
| -- Handlers in the block may contain nested subprograms that require |
| -- unnesting. |
| |
| Check_Unnesting_In_Handlers (Local_Body); |
| |
| Rewrite (Decl, Local_Body); |
| Analyze (Decl); |
| Set_Has_Nested_Subprogram (Local_Proc); |
| |
| Local_Call := |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Local_Proc, Loc)); |
| |
| Insert_After (Decl, Local_Call); |
| Analyze (Local_Call); |
| |
| -- The new subprogram has the same scope as the original block |
| |
| Set_Scope (Local_Proc, Scope (Local_Scop)); |
| |
| -- And the entity list of the new procedure is that of the block |
| |
| Set_First_Entity (Local_Proc, Ent); |
| |
| -- Reset the scopes of all the entities to the new procedure |
| |
| while Present (Ent) loop |
| Set_Scope (Ent, Local_Proc); |
| Next_Entity (Ent); |
| end loop; |
| end Unnest_Block; |
| |
| ------------------------- |
| -- Unnest_If_Statement -- |
| ------------------------- |
| |
| procedure Unnest_If_Statement (If_Stmt : Node_Id) is |
| |
| procedure Check_Stmts_For_Subp_Unnesting (Stmts : in out List_Id); |
| -- A list of statements (that may be a list associated with a then, |
| -- elsif, or else part of an if-statement) is traversed at the top |
| -- level to determine whether it contains a subprogram body, and if so, |
| -- the statements will be replaced with a new procedure body containing |
| -- the statements followed by a call to the procedure. The individual |
| -- statements may also be blocks, loops, or other if statements that |
| -- themselves may require contain nested subprograms needing unnesting. |
| |
| procedure Check_Stmts_For_Subp_Unnesting (Stmts : in out List_Id) is |
| Subp_Found : Boolean := False; |
| |
| begin |
| if Is_Empty_List (Stmts) then |
| return; |
| end if; |
| |
| declare |
| Stmt : Node_Id := First (Stmts); |
| begin |
| while Present (Stmt) loop |
| if Nkind (Stmt) = N_Subprogram_Body then |
| Subp_Found := True; |
| exit; |
| end if; |
| |
| Next (Stmt); |
| end loop; |
| end; |
| |
| -- The statements themselves may be blocks, loops, etc. that in turn |
| -- contain nested subprograms requiring an unnesting transformation. |
| -- We perform this traversal after looking for subprogram bodies, to |
| -- avoid considering procedures created for one of those statements |
| -- (such as a block rewritten as a procedure) as a nested subprogram |
| -- of the statement list (which could result in an unneeded wrapper |
| -- procedure). |
| |
| Check_Unnesting_In_Decls_Or_Stmts (Stmts); |
| |
| -- If there was a top-level subprogram body in the statement list, |
| -- then perform an unnesting transformation on the list by replacing |
| -- the statements with a wrapper procedure body containing the |
| -- original statements followed by a call to that procedure. |
| |
| if Subp_Found then |
| Unnest_Statement_List (Stmts); |
| end if; |
| end Check_Stmts_For_Subp_Unnesting; |
| |
| -- Local variables |
| |
| Then_Stmts : List_Id := Then_Statements (If_Stmt); |
| Else_Stmts : List_Id := Else_Statements (If_Stmt); |
| |
| -- Start of processing for Unnest_If_Statement |
| |
| begin |
| Check_Stmts_For_Subp_Unnesting (Then_Stmts); |
| Set_Then_Statements (If_Stmt, Then_Stmts); |
| |
| if not Is_Empty_List (Elsif_Parts (If_Stmt)) then |
| declare |
| Elsif_Part : Node_Id := |
| First (Elsif_Parts (If_Stmt)); |
| Elsif_Stmts : List_Id; |
| begin |
| while Present (Elsif_Part) loop |
| Elsif_Stmts := Then_Statements (Elsif_Part); |
| |
| Check_Stmts_For_Subp_Unnesting (Elsif_Stmts); |
| Set_Then_Statements (Elsif_Part, Elsif_Stmts); |
| |
| Next (Elsif_Part); |
| end loop; |
| end; |
| end if; |
| |
| Check_Stmts_For_Subp_Unnesting (Else_Stmts); |
| Set_Else_Statements (If_Stmt, Else_Stmts); |
| end Unnest_If_Statement; |
| |
| ----------------- |
| -- Unnest_Loop -- |
| ----------------- |
| |
| procedure Unnest_Loop (Loop_Stmt : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (Loop_Stmt); |
| Ent : Entity_Id; |
| Local_Body : Node_Id; |
| Local_Call : Node_Id; |
| Local_Proc : Entity_Id; |
| Local_Scop : Entity_Id; |
| Loop_Copy : constant Node_Id := |
| Relocate_Node (Loop_Stmt); |
| begin |
| Local_Scop := Entity (Identifier (Loop_Stmt)); |
| Ent := First_Entity (Local_Scop); |
| |
| Local_Proc := Make_Temporary (Loc, 'P'); |
| |
| Local_Body := |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Local_Proc), |
| Declarations => Empty_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Loop_Copy))); |
| |
| Rewrite (Loop_Stmt, Local_Body); |
| Analyze (Loop_Stmt); |
| |
| Set_Has_Nested_Subprogram (Local_Proc); |
| |
| Local_Call := |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Local_Proc, Loc)); |
| |
| Insert_After (Loop_Stmt, Local_Call); |
| Analyze (Local_Call); |
| |
| -- New procedure has the same scope as the original loop, and the scope |
| -- of the loop is the new procedure. |
| |
| Set_Scope (Local_Proc, Scope (Local_Scop)); |
| Set_Scope (Local_Scop, Local_Proc); |
| |
| -- The entity list of the new procedure is that of the loop |
| |
| Set_First_Entity (Local_Proc, Ent); |
| |
| -- Note that the entities associated with the loop don't need to have |
| -- their Scope fields reset, since they're still associated with the |
| -- same loop entity that now belongs to the copied loop statement. |
| end Unnest_Loop; |
| |
| --------------------------- |
| -- Unnest_Statement_List -- |
| --------------------------- |
| |
| procedure Unnest_Statement_List (Stmts : in out List_Id) is |
| Loc : constant Source_Ptr := Sloc (First (Stmts)); |
| Local_Body : Node_Id; |
| Local_Call : Node_Id; |
| Local_Proc : Entity_Id; |
| New_Stmts : constant List_Id := Empty_List; |
| |
| begin |
| Local_Proc := Make_Temporary (Loc, 'P'); |
| |
| Local_Body := |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Local_Proc), |
| Declarations => Empty_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stmts)); |
| |
| Append_To (New_Stmts, Local_Body); |
| |
| Analyze (Local_Body); |
| |
| Set_Has_Nested_Subprogram (Local_Proc); |
| |
| Local_Call := |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Local_Proc, Loc)); |
| |
| Append_To (New_Stmts, Local_Call); |
| Analyze (Local_Call); |
| |
| -- Traverse the statements, and for any that are declarations or |
| -- subprogram bodies that have entities, set the Scope of those |
| -- entities to the new procedure's Entity_Id. |
| |
| declare |
| Stmt : Node_Id := First (Stmts); |
| |
| begin |
| while Present (Stmt) loop |
| case Nkind (Stmt) is |
| when N_Declaration |
| | N_Renaming_Declaration |
| => |
| Set_Scope (Defining_Identifier (Stmt), Local_Proc); |
| |
| when N_Subprogram_Body => |
| Set_Scope |
| (Defining_Unit_Name (Specification (Stmt)), Local_Proc); |
| |
| when others => |
| null; |
| end case; |
| |
| Next (Stmt); |
| end loop; |
| end; |
| |
| Stmts := New_Stmts; |
| end Unnest_Statement_List; |
| |
| -------------------------------- |
| -- Wrap_Transient_Declaration -- |
| -------------------------------- |
| |
| -- If a transient scope has been established during the processing of the |
| -- Expression of an Object_Declaration, it is not possible to wrap the |
| -- declaration into a transient block as usual case, otherwise the object |
| -- would be itself declared in the wrong scope. Therefore, all entities (if |
| -- any) defined in the transient block are moved to the proper enclosing |
| -- scope. Furthermore, if they are controlled variables they are finalized |
| -- right after the declaration. The finalization list of the transient |
| -- scope is defined as a renaming of the enclosing one so during their |
| -- initialization they will be attached to the proper finalization list. |
| -- For instance, the following declaration : |
| |
| -- X : Typ := F (G (A), G (B)); |
| |
| -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2) |
| -- is expanded into : |
| |
| -- X : Typ := [ complex Expression-Action ]; |
| -- [Deep_]Finalize (_v1); |
| -- [Deep_]Finalize (_v2); |
| |
| procedure Wrap_Transient_Declaration (N : Node_Id) is |
| Curr_S : Entity_Id; |
| Encl_S : Entity_Id; |
| |
| begin |
| Curr_S := Current_Scope; |
| Encl_S := Scope (Curr_S); |
| |
| -- Insert all actions including cleanup generated while analyzing or |
| -- expanding the transient context back into the tree. Manage the |
| -- secondary stack when the object declaration appears in a library |
| -- level package [body]. |
| |
| Insert_Actions_In_Scope_Around |
| (N => N, |
| Clean => True, |
| Manage_SS => |
| Uses_Sec_Stack (Curr_S) |
| and then Nkind (N) = N_Object_Declaration |
| and then Ekind (Encl_S) in E_Package | E_Package_Body |
| and then Is_Library_Level_Entity (Encl_S)); |
| Pop_Scope; |
| |
| -- Relocate local entities declared within the transient scope to the |
| -- enclosing scope. This action sets their Is_Public flag accordingly. |
| |
| Transfer_Entities (Curr_S, Encl_S); |
| |
| -- Mark the enclosing dynamic scope to ensure that the secondary stack |
| -- is properly released upon exiting the said scope. |
| |
| if Uses_Sec_Stack (Curr_S) then |
| Curr_S := Enclosing_Dynamic_Scope (Curr_S); |
| |
| -- Do not mark a function that returns on the secondary stack as the |
| -- reclamation is done by the caller. |
| |
| if Ekind (Curr_S) = E_Function |
| and then Needs_Secondary_Stack (Etype (Curr_S)) |
| then |
| null; |
| |
| -- Otherwise mark the enclosing dynamic scope |
| |
| else |
| Set_Uses_Sec_Stack (Curr_S); |
| Check_Restriction (No_Secondary_Stack, N); |
| end if; |
| end if; |
| end Wrap_Transient_Declaration; |
| |
| ------------------------------- |
| -- Wrap_Transient_Expression -- |
| ------------------------------- |
| |
| procedure Wrap_Transient_Expression (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Expr : Node_Id := Relocate_Node (N); |
| Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N); |
| Typ : constant Entity_Id := Etype (N); |
| |
| begin |
| -- Generate: |
| |
| -- Temp : Typ; |
| -- declare |
| -- M : constant Mark_Id := SS_Mark; |
| -- procedure Finalizer is ... (See Build_Finalizer) |
| |
| -- begin |
| -- Temp := <Expr>; -- general case |
| -- Temp := (if <Expr> then True else False); -- boolean case |
| |
| -- at end |
| -- Finalizer; |
| -- end; |
| |
| -- A special case is made for Boolean expressions so that the back end |
| -- knows to generate a conditional branch instruction, if running with |
| -- -fpreserve-control-flow. This ensures that a control-flow change |
| -- signaling the decision outcome occurs before the cleanup actions. |
| |
| if Opt.Suppress_Control_Flow_Optimizations |
| and then Is_Boolean_Type (Typ) |
| then |
| Expr := |
| Make_If_Expression (Loc, |
| Expressions => New_List ( |
| Expr, |
| New_Occurrence_Of (Standard_True, Loc), |
| New_Occurrence_Of (Standard_False, Loc))); |
| end if; |
| |
| Insert_Actions (N, New_List ( |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Temp, |
| Object_Definition => New_Occurrence_Of (Typ, Loc)), |
| |
| Make_Transient_Block (Loc, |
| Action => |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Temp, Loc), |
| Expression => Expr), |
| Par => Parent (N)))); |
| |
| if Debug_Generated_Code then |
| Set_Debug_Info_Needed (Temp); |
| end if; |
| |
| Rewrite (N, New_Occurrence_Of (Temp, Loc)); |
| Analyze_And_Resolve (N, Typ); |
| end Wrap_Transient_Expression; |
| |
| ------------------------------ |
| -- Wrap_Transient_Statement -- |
| ------------------------------ |
| |
| procedure Wrap_Transient_Statement (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| New_Stmt : constant Node_Id := Relocate_Node (N); |
| |
| begin |
| -- Generate: |
| -- declare |
| -- M : constant Mark_Id := SS_Mark; |
| -- procedure Finalizer is ... (See Build_Finalizer) |
| -- |
| -- begin |
| -- <New_Stmt>; |
| -- |
| -- at end |
| -- Finalizer; |
| -- end; |
| |
| Rewrite (N, |
| Make_Transient_Block (Loc, |
| Action => New_Stmt, |
| Par => Parent (N))); |
| |
| -- With the scope stack back to normal, we can call analyze on the |
| -- resulting block. At this point, the transient scope is being |
| -- treated like a perfectly normal scope, so there is nothing |
| -- special about it. |
| |
| -- Note: Wrap_Transient_Statement is called with the node already |
| -- analyzed (i.e. Analyzed (N) is True). This is important, since |
| -- otherwise we would get a recursive processing of the node when |
| -- we do this Analyze call. |
| |
| Analyze (N); |
| end Wrap_Transient_Statement; |
| |
| end Exp_Ch7; |