diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/exp_ch7.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/exp_ch7.adb | 3381 |
1 files changed, 3381 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/exp_ch7.adb b/gcc-4.2.1/gcc/ada/exp_ch7.adb new file mode 100644 index 000000000..2535bb2c7 --- /dev/null +++ b/gcc-4.2.1/gcc/ada/exp_ch7.adb @@ -0,0 +1,3381 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 7 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2006, 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 2, 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 COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- 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 Errout; use Errout; +with Exp_Ch9; use Exp_Ch9; +with Exp_Ch11; use Exp_Ch11; +with Exp_Dbug; use Exp_Dbug; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Hostparm; use Hostparm; +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 Targparm; use Targparm; +with Sinfo; use Sinfo; +with Sem; use Sem; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Exp_Ch7 is + + -------------------------------- + -- Transient Scope Management -- + -------------------------------- + + -- A transient scope is created when temporary objects are created by the + -- compiler. These temporary objects are allocated on the secondary stack + -- and the transient scope is responsible for finalizing the object when + -- appropriate and reclaiming the memory at the right time. The temporary + -- objects are generally the objects allocated to store the result of a + -- function returning an unconstrained or a tagged value. Expressions + -- needing to be wrapped in a transient scope (functions calls returning + -- unconstrained or tagged values) may appear in 3 different contexts which + -- lead to 3 different kinds of transient scope expansion: + + -- 1. In a simple statement (procedure call, assignment, ...). In + -- this case the instruction is wrapped into a transient block. + -- (See Wrap_Transient_Statement for details) + + -- 2. In an expression of a control structure (test in a IF statement, + -- expression in a CASE statement, ...). + -- (See Wrap_Transient_Expression for details) + + -- 3. In a expression of an object_declaration. No wrapping is possible + -- here, so the finalization actions, if any are done right after the + -- declaration and the secondary stack deallocation is done in the + -- proper enclosing scope (see Wrap_Transient_Declaration for details) + + -- Note about function returning tagged types: It has been decided to + -- always allocate their result in the secondary stack while it is not + -- absolutely mandatory when the tagged type is constrained because the + -- caller knows the size of the returned object and thus could allocate the + -- result in the primary stack. But, allocating them always in the + -- secondary stack simplifies many implementation hassles: + + -- - If it is dispatching function call, the computation of the size of + -- the result is possible but complex from the outside. + + -- - If the returned type is controlled, the assignment of the returned + -- value to the anonymous object involves an Adjust, and we have no + -- easy way to access the anonymous object created by the back-end + + -- - If the returned type is class-wide, this is an unconstrained type + -- anyway + + -- Furthermore, the little loss in efficiency which is the result of this + -- decision is not such a big deal because function returning tagged types + -- are not very much used in real life as opposed to functions returning + -- access to a tagged type + + -------------------------------------------------- + -- Transient Blocks and Finalization Management -- + -------------------------------------------------- + + function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id; + -- N is a node wich may generate a transient scope. Loop over the + -- parent pointers of N until it find the appropriate node to + -- wrap. It it returns Empty, it means that no transient scope is + -- needed in this context. + + function Make_Clean + (N : Node_Id; + Clean : Entity_Id; + Mark : Entity_Id; + Flist : Entity_Id; + Is_Task : Boolean; + Is_Master : Boolean; + Is_Protected_Subprogram : Boolean; + Is_Task_Allocation_Block : Boolean; + Is_Asynchronous_Call_Block : Boolean) return Node_Id; + -- Expand a the clean-up procedure for controlled and/or transient + -- block, and/or task master or task body, or blocks used to + -- implement task allocation or asynchronous entry calls, or + -- procedures used to implement protected procedures. Clean is the + -- entity for such a procedure. Mark is the entity for the secondary + -- stack mark, if empty only controlled block clean-up will be + -- performed. Flist is the entity for the local final list, if empty + -- only transient scope clean-up will be performed. The flags + -- Is_Task and Is_Master control the calls to the corresponding + -- finalization actions for a task body or for an entity that is a + -- task master. + + procedure Set_Node_To_Be_Wrapped (N : Node_Id); + -- Set the field Node_To_Be_Wrapped of the current scope + + procedure Insert_Actions_In_Scope_Around (N : Node_Id); + -- Insert the before-actions kept in the scope stack before N, and the + -- after after-actions, after N which must be a member of a list. + + function Make_Transient_Block + (Loc : Source_Ptr; + Action : Node_Id) return Node_Id; + -- Create a transient block whose name is Scope, which is also a + -- controlled block if Flist is not empty and whose only code is + -- Action (either a single statement or single declaration). + + type Final_Primitives is (Initialize_Case, Adjust_Case, Finalize_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); + + 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); + + procedure Build_Record_Deep_Procs (Typ : Entity_Id); + -- Build the deep Initialize/Adjust/Finalize for a record Typ with + -- Has_Component_Component set and store them using the TSS mechanism. + + procedure 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 Make_Deep_Proc + (Prim : Final_Primitives; + Typ : Entity_Id; + Stmts : List_Id) return Node_Id; + -- This function generates the tree for Deep_Initialize, Deep_Adjust + -- or Deep_Finalize procedures according to the first parameter, + -- these procedures operate on the type Typ. The Stmts parameter + -- gives the body of the procedure. + + function Make_Deep_Array_Body + (Prim : Final_Primitives; + Typ : Entity_Id) return List_Id; + -- This function generates the list of statements for implementing + -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures + -- according to the first parameter, these procedures operate on the + -- array type Typ. + + function Make_Deep_Record_Body + (Prim : Final_Primitives; + Typ : Entity_Id) 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. + + procedure Check_Visibly_Controlled + (Prim : Final_Primitives; + Typ : Entity_Id; + E : in out Entity_Id; + Cref : in out Node_Id); + -- The controlled operation declared for a derived type may not be + -- overriding, if the controlled operations of the parent type are + -- hidden, for example when the parent is a private type whose full + -- view is controlled. For other primitive operations we modify the + -- name of the operation to indicate that it is not overriding, but + -- this is not possible for Initialize, etc. because they have to be + -- retrievable by name. Before generating the proper call to one of + -- these operations we check whether Typ is known to be controlled at + -- the point of definition. If it is not then we must retrieve the + -- hidden operation of the parent and use it instead. This is one + -- case that might be solved more cleanly once Overriding pragmas or + -- declarations are in place. + + function Convert_View + (Proc : Entity_Id; + Arg : Node_Id; + Ind : Pos := 1) return Node_Id; + -- Proc is one of the Initialize/Adjust/Finalize operations, and + -- Arg is the argument being passed to it. Ind indicates which + -- formal of procedure Proc we are trying to match. This function + -- will, if necessary, generate an 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. + + ----------------------------- + -- Finalization Management -- + ----------------------------- + + -- This part describe how Initialization/Adjusment/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 adusting 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. + -- - For types that are both Is_Controlled and Has_Controlled_Components, + -- the record controller and the object itself are handled separately. + -- It could seem simpler to attach the object at the end of its record + -- controller but this would not tackle view conversions properly. + -- - A classwide type can always potentially have controlled components + -- but the record controller of the corresponding actual type may not + -- be known at compile time so the dispatch table contains a special + -- field that allows to compute the offset of the record controller + -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset + + -- Here is a simple example of the expansion of a controlled block : + + -- declare + -- X : Controlled ; + -- Y : Controlled := Init; + -- + -- type R is record + -- C : Controlled; + -- end record; + -- W : R; + -- Z : R := (C => X); + -- begin + -- X := Y; + -- W := Z; + -- end; + -- + -- is expanded into + -- + -- declare + -- _L : System.FI.Finalizable_Ptr; + + -- procedure _Clean is + -- begin + -- Abort_Defer; + -- System.FI.Finalize_List (_L); + -- Abort_Undefer; + -- end _Clean; + + -- X : Controlled; + -- begin + -- Abort_Defer; + -- Initialize (X); + -- Attach_To_Final_List (_L, Finalizable (X), 1); + -- at end: Abort_Undefer; + -- Y : Controlled := Init; + -- Adjust (Y); + -- Attach_To_Final_List (_L, Finalizable (Y), 1); + -- + -- type R is record + -- _C : Record_Controller; + -- 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; + + function Global_Flist_Ref (Flist_Ref : Node_Id) return Boolean; + -- Return True if Flist_Ref refers to a global final list, either + -- the object GLobal_Final_List which is used to attach standalone + -- objects, or any of the list controllers associated with library + -- level access to controlled objects + + procedure Clean_Simple_Protected_Objects (N : Node_Id); + -- Protected objects without entries are not controlled types, and the + -- locks have to be released explicitly when such an object goes out + -- of scope. Traverse declarations in scope to determine whether such + -- objects are present. + + ---------------------------- + -- 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_Return_By_Reference_Type (Typ) then + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Adjust_Case, + Typ => Typ, + Stmts => Make_Deep_Array_Body (Adjust_Case, Typ))); + end if; + + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Finalize_Case, + Typ => Typ, + Stmts => Make_Deep_Array_Body (Finalize_Case, Typ))); + end Build_Array_Deep_Procs; + + ----------------------------- + -- 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_Final_List -- + ---------------------- + + procedure Build_Final_List (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; + + begin + Set_Associated_Final_Chain (Typ, + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Typ), 'L'))); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Associated_Final_Chain (Typ), + Object_Definition => + New_Reference_To + (RTE (RE_List_Controller), Loc)); + + -- The type may have been frozen already, and this is a late freezing + -- action, in which case the declaration must be elaborated at once. + -- If the call is for an allocator, the chain must also be created now, + -- because the freezing of the type does not build one. Otherwise, the + -- declaration is one of the freezing actions for a user-defined type. + + if Is_Frozen (Typ) + or else (Nkind (N) = N_Allocator + and then Ekind (Etype (N)) = E_Anonymous_Access_Type) + then + Insert_Action (N, Decl); + else + Append_Freeze_Action (Typ, Decl); + end if; + end Build_Final_List; + + --------------------- + -- 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_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_Return_By_Reference_Type (Typ) then + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Adjust_Case, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Adjust_Case, Typ))); + end if; + + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Finalize_Case, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Finalize_Case, Typ))); + 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_Defining_Identifier (Loc, New_Internal_Name ('J')); + + Append (New_Reference_To (Index, Loc), Index_List); + + return New_List ( + Make_Implicit_Loop_Statement (N, + Identifier => Empty, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Index, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Obj), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, Dim))))), + Statements => Free_One_Dimension (Dim + 1))); + end if; + end Free_One_Dimension; + + -- Start of processing for Cleanup_Array + + begin + return Free_One_Dimension (1); + end Cleanup_Array; + + -------------------- + -- Cleanup_Record -- + -------------------- + + function Cleanup_Record + (N : Node_Id; + Obj : Node_Id; + Typ : Entity_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (N); + Tsk : Node_Id; + Comp : Entity_Id; + Stmts : constant List_Id := New_List; + U_Typ : constant Entity_Id := Underlying_Type (Typ); + + begin + if Has_Discriminants (U_Typ) + and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration + and then + Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition + and then + Present + (Variant_Part + (Component_List (Type_Definition (Parent (U_Typ))))) + then + -- For now, do not attempt to free a component that may appear in + -- a variant, and instead issue a warning. Doing this "properly" + -- would require building a case statement and would be quite a + -- mess. Note that the RM only requires that free "work" for the + -- case of a task access value, so already we go way beyond this + -- in that we deal with the array case and non-discriminated + -- record cases. + + Error_Msg_N + ("task/protected object in variant record will not be freed?", N); + return New_List (Make_Null_Statement (Loc)); + end if; + + Comp := First_Component (Typ); + + while Present (Comp) loop + if Has_Task (Etype (Comp)) + or else Has_Simple_Protected_Object (Etype (Comp)) + then + Tsk := + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr_No_Checks (Obj), + Selector_Name => New_Occurrence_Of (Comp, Loc)); + Set_Etype (Tsk, Etype (Comp)); + + if Is_Task_Type (Etype (Comp)) then + Append_To (Stmts, Cleanup_Task (N, Tsk)); + + elsif Is_Simple_Protected_Type (Etype (Comp)) then + Append_To (Stmts, Cleanup_Protected_Object (N, Tsk)); + + elsif Is_Record_Type (Etype (Comp)) then + + -- Recurse, by generating the prefix of the argument to + -- the eventual cleanup call. + + Append_List_To + (Stmts, Cleanup_Record (N, Tsk, Etype (Comp))); + + elsif Is_Array_Type (Etype (Comp)) then + Append_List_To + (Stmts, Cleanup_Array (N, Tsk, Etype (Comp))); + end if; + end if; + + Next_Component (Comp); + end loop; + + return Stmts; + end Cleanup_Record; + + ------------------------------ + -- Cleanup_Protected_Object -- + ------------------------------ + + function Cleanup_Protected_Object + (N : Node_Id; + Ref : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + + begin + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Finalize_Protection), Loc), + Parameter_Associations => New_List ( + Concurrent_Ref (Ref))); + end Cleanup_Protected_Object; + + ------------------------------------ + -- Clean_Simple_Protected_Objects -- + ------------------------------------ + + procedure Clean_Simple_Protected_Objects (N : Node_Id) is + Stmts : constant List_Id := Statements (Handled_Statement_Sequence (N)); + Stmt : Node_Id := Last (Stmts); + E : Entity_Id; + + begin + E := First_Entity (Current_Scope); + while Present (E) loop + if (Ekind (E) = E_Variable + or else Ekind (E) = E_Constant) + and then Has_Simple_Protected_Object (Etype (E)) + and then not Has_Task (Etype (E)) + and then Nkind (Parent (E)) /= N_Object_Renaming_Declaration + then + declare + Typ : constant Entity_Id := Etype (E); + Ref : constant Node_Id := New_Occurrence_Of (E, Sloc (Stmt)); + + begin + if Is_Simple_Protected_Type (Typ) then + Append_To (Stmts, Cleanup_Protected_Object (N, Ref)); + + elsif Has_Simple_Protected_Object (Typ) then + if Is_Record_Type (Typ) then + Append_List_To (Stmts, Cleanup_Record (N, Ref, Typ)); + + elsif Is_Array_Type (Typ) then + Append_List_To (Stmts, Cleanup_Array (N, Ref, Typ)); + end if; + end if; + end; + end if; + + Next_Entity (E); + end loop; + + -- Analyze inserted cleanup statements + + if Present (Stmt) then + Stmt := Next (Stmt); + + while Present (Stmt) loop + Analyze (Stmt); + Next (Stmt); + end loop; + end if; + end Clean_Simple_Protected_Objects; + + ------------------ + -- Cleanup_Task -- + ------------------ + + function Cleanup_Task + (N : Node_Id; + Ref : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + begin + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Free_Task), Loc), + Parameter_Associations => + New_List (Concurrent_Ref (Ref))); + end Cleanup_Task; + + --------------------------------- + -- Has_Simple_Protected_Object -- + --------------------------------- + + function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is + Comp : Entity_Id; + + begin + if 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 + 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; + + else + return False; + end if; + end Has_Simple_Protected_Object; + + ------------------------------ + -- Is_Simple_Protected_Type -- + ------------------------------ + + function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is + begin + return Is_Protected_Type (T) and then not Has_Entries (T); + end Is_Simple_Protected_Type; + + ------------------------------ + -- Check_Visibly_Controlled -- + ------------------------------ + + procedure Check_Visibly_Controlled + (Prim : Final_Primitives; + Typ : Entity_Id; + E : in out Entity_Id; + Cref : in out Node_Id) + is + Parent_Type : Entity_Id; + Op : Entity_Id; + + begin + if Is_Derived_Type (Typ) + and then Comes_From_Source (E) + and then not Is_Overriding_Operation (E) + then + -- We know that the explicit operation on the type does not override + -- the inherited operation of the parent, and that the derivation + -- is from a private type that is not visibly controlled. + + Parent_Type := Etype (Typ); + Op := Find_Prim_Op (Parent_Type, Name_Of (Prim)); + + if Present (Op) then + E := Op; + + -- Wrap the object to be initialized into the proper + -- unchecked conversion, to be compatible with the operation + -- to be called. + + if Nkind (Cref) = N_Unchecked_Type_Conversion then + Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref)); + else + Cref := Unchecked_Convert_To (Parent_Type, Cref); + end if; + end if; + end if; + end Check_Visibly_Controlled; + + --------------------- + -- Controlled_Type -- + --------------------- + + function Controlled_Type (T : Entity_Id) return Boolean is + + function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean; + -- If type is not frozen yet, check explicitly among its components, + -- because flag is not necessarily set. + + ----------------------------------- + -- Has_Some_Controlled_Component -- + ----------------------------------- + + function Has_Some_Controlled_Component + (Rec : Entity_Id) return Boolean + is + Comp : Entity_Id; + + begin + if Has_Controlled_Component (Rec) then + return True; + + elsif not Is_Frozen (Rec) then + if Is_Record_Type (Rec) then + Comp := First_Entity (Rec); + + while Present (Comp) loop + if not Is_Type (Comp) + and then Controlled_Type (Etype (Comp)) + then + return True; + end if; + + Next_Entity (Comp); + end loop; + + return False; + + elsif Is_Array_Type (Rec) then + return Is_Controlled (Component_Type (Rec)); + + else + return Has_Controlled_Component (Rec); + end if; + else + return False; + end if; + end Has_Some_Controlled_Component; + + -- Start of processing for Controlled_Type + + begin + -- Class-wide types must be treated as controlled because they may + -- contain an extension that has controlled components + + -- We can skip this if finalization is not available + + return (Is_Class_Wide_Type (T) + and then not In_Finalization_Root (T) + and then not Restriction_Active (No_Finalization)) + or else Is_Controlled (T) + or else Has_Some_Controlled_Component (T) + or else (Is_Concurrent_Type (T) + and then Present (Corresponding_Record_Type (T)) + and then Controlled_Type (Corresponding_Record_Type (T))); + end Controlled_Type; + + -------------------------- + -- Controller_Component -- + -------------------------- + + function Controller_Component (Typ : Entity_Id) return Entity_Id is + T : Entity_Id := Base_Type (Typ); + Comp : Entity_Id; + Comp_Scop : Entity_Id; + Res : Entity_Id := Empty; + Res_Scop : Entity_Id := Empty; + + begin + if Is_Class_Wide_Type (T) then + T := Root_Type (T); + end if; + + if Is_Private_Type (T) then + T := Underlying_Type (T); + end if; + + -- Fetch the outermost controller + + Comp := First_Entity (T); + while Present (Comp) loop + if Chars (Comp) = Name_uController then + Comp_Scop := Scope (Original_Record_Component (Comp)); + + -- If this controller is at the outermost level, no need to + -- look for another one + + if Comp_Scop = T then + return Comp; + + -- Otherwise record the outermost one and continue looking + + elsif Res = Empty or else Is_Ancestor (Res_Scop, Comp_Scop) then + Res := Comp; + Res_Scop := Comp_Scop; + end if; + end if; + + Next_Entity (Comp); + end loop; + + -- If we fall through the loop, there is no controller component + + return Res; + end Controller_Component; + + ------------------ + -- 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) = N_Type_Conversion + or else Nkind (Arg) = N_Unchecked_Type_Conversion + then + Atyp := Entity (Subtype_Mark (Arg)); + else + Atyp := Etype (Arg); + end if; + + if Is_Abstract (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) = N_Unchecked_Type_Conversion + or else Nkind (Arg) = N_Type_Conversion) + and then not Is_Class_Wide_Type (Atyp) + then + Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg))); + Set_Etype (Arg, Ftyp); + return Arg; + + else + return Arg; + end if; + end Convert_View; + + ------------------------------- + -- 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 ot tagged + -- result. It creates a new scope on the stack scope in order to enclose + -- all transient variables generated + + procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is + Loc : constant Source_Ptr := Sloc (N); + Wrap_Node : Node_Id; + + Sec_Stk : constant Boolean := + Sec_Stack and not Functions_Return_By_DSP_On_Target; + -- We never need a secondary stack if functions return by DSP + + begin + -- Do not create a transient scope if we are already inside one + + for S in reverse Scope_Stack.First .. Scope_Stack.Last loop + + if Scope_Stack.Table (S).Is_Transient then + if Sec_Stk then + Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity); + end if; + + return; + + -- If we have encountered Standard there are no enclosing + -- transient scopes. + + elsif Scope_Stack.Table (S).Entity = Standard_Standard then + exit; + + end if; + end loop; + + Wrap_Node := Find_Node_To_Be_Wrapped (N); + + -- Case of no wrap node, false alert, no transient scope needed + + if No (Wrap_Node) then + null; + + -- If the node to wrap is an iteration_scheme, the expression is + -- one of the bounds, and the expansion will make an explicit + -- declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb), + -- so do not apply any transformations here. + + elsif Nkind (Wrap_Node) = N_Iteration_Scheme then + null; + + else + New_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B')); + Set_Scope_Is_Transient; + + if Sec_Stk then + Set_Uses_Sec_Stack (Current_Scope); + Check_Restriction (No_Secondary_Stack, N); + end if; + + Set_Etype (Current_Scope, Standard_Void_Type); + Set_Node_To_Be_Wrapped (Wrap_Node); + + if Debug_Flag_W then + Write_Str (" <Transient>"); + Write_Eol; + end if; + end if; + end Establish_Transient_Scope; + + ---------------------------- + -- Expand_Cleanup_Actions -- + ---------------------------- + + procedure Expand_Cleanup_Actions (N : Node_Id) is + Loc : Source_Ptr; + S : constant Entity_Id := + Current_Scope; + Flist : constant Entity_Id := + Finalization_Chain_Entity (S); + Is_Task : constant Boolean := + (Nkind (Original_Node (N)) = N_Task_Body); + Is_Master : constant Boolean := + Nkind (N) /= N_Entry_Body + and then Is_Task_Master (N); + Is_Protected : 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_Asynchronous_Call : constant Boolean := + Nkind (N) = N_Block_Statement + and then Is_Asynchronous_Call_Block (N); + + Clean : Entity_Id; + Mark : Entity_Id := Empty; + New_Decls : constant List_Id := New_List; + Blok : Node_Id; + End_Lab : Node_Id; + Wrapped : Boolean; + Chain : Entity_Id := Empty; + Decl : Node_Id; + Old_Poll : Boolean; + + begin + + -- Compute a location that is not directly in the user code in + -- order to avoid to generate confusing debug info. A good + -- approximation is the name of the outer user-defined scope + + declare + S1 : Entity_Id := S; + + begin + while not Comes_From_Source (S1) and then S1 /= Standard_Standard loop + S1 := Scope (S1); + end loop; + + Loc := Sloc (S1); + end; + + -- There are cleanup actions only if the secondary stack needs + -- releasing or some finalizations are needed or in the context + -- of tasking + + if Uses_Sec_Stack (Current_Scope) + and then not Sec_Stack_Needed_For_Return (Current_Scope) + then + null; + elsif No (Flist) + and then not Is_Master + and then not Is_Task + and then not Is_Protected + and then not Is_Task_Allocation + and then not Is_Asynchronous_Call + then + Clean_Simple_Protected_Objects (N); + return; + end if; + + -- If the current scope is the subprogram body that is the rewriting + -- of a task body, and the descriptors have not been delayed (due to + -- some nested instantiations) do not generate redundant cleanup + -- actions: the cleanup procedure already exists for this body. + + if Nkind (N) = N_Subprogram_Body + and then Nkind (Original_Node (N)) = N_Task_Body + and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N)) + then + return; + end if; + + -- Set polling off, since we don't need to poll during cleanup + -- actions, and indeed for the cleanup routine, which is executed + -- with aborts deferred, we don't want polling. + + Old_Poll := Polling_Required; + Polling_Required := False; + + -- Make sure we have a declaration list, since we will add to it + + if No (Declarations (N)) then + Set_Declarations (N, New_List); + end if; + + -- The task activation call has already been built for task + -- allocation blocks. + + 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, expand: + -- _Mxx : constant Mark_Id := SS_Mark; + + -- Suppress calls to SS_Mark and SS_Release if Java_VM, + -- since we never use the secondary stack on the JVM. + + if Uses_Sec_Stack (Current_Scope) + and then not Sec_Stack_Needed_For_Return (Current_Scope) + and then not Java_VM + then + Mark := Make_Defining_Identifier (Loc, New_Internal_Name ('M')); + Append_To (New_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Mark, + Object_Definition => New_Reference_To (RTE (RE_Mark_Id), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_SS_Mark), Loc)))); + + Set_Uses_Sec_Stack (Current_Scope, False); + end if; + + -- If finalization list is present then expand: + -- Local_Final_List : System.FI.Finalizable_Ptr; + + if Present (Flist) then + Append_To (New_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Flist, + Object_Definition => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); + end if; + + -- Clean-up procedure definition + + Clean := Make_Defining_Identifier (Loc, Name_uClean); + Set_Suppress_Elaboration_Warnings (Clean); + Append_To (New_Decls, + Make_Clean (N, Clean, Mark, Flist, + Is_Task, + Is_Master, + Is_Protected, + Is_Task_Allocation, + Is_Asynchronous_Call)); + + -- If exception handlers are present, wrap the Sequence of + -- statements in a block because it is not possible to get + -- exception handlers and an AT END call in the same scope. + + if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then + + -- Preserve end label to provide proper cross-reference information + + End_Lab := End_Label (Handled_Statement_Sequence (N)); + Blok := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => Handled_Statement_Sequence (N)); + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Loc, New_List (Blok))); + Set_End_Label (Handled_Statement_Sequence (N), End_Lab); + Wrapped := True; + + -- Comment needed here, see RH for 1.306 ??? + + if Nkind (N) = N_Subprogram_Body then + Set_Has_Nested_Block_With_Handler (Current_Scope); + end if; + + -- Otherwise we do not wrap + + else + Wrapped := False; + Blok := Empty; + end if; + + -- Don't move the _chain Activation_Chain declaration in task + -- allocation blocks. Task allocation blocks use this object + -- in their cleanup handlers, and gigi complains if it is declared + -- in the sequence of statements of the scope that declares the + -- handler. + + if Is_Task_Allocation then + Chain := Activation_Chain_Entity (N); + Decl := First (Declarations (N)); + + while Nkind (Decl) /= N_Object_Declaration + or else Defining_Identifier (Decl) /= Chain + loop + Next (Decl); + pragma Assert (Present (Decl)); + end loop; + + Remove (Decl); + Prepend_To (New_Decls, Decl); + end if; + + -- Now we move the declarations into the Sequence of statements + -- in order to get them protected by the AT END call. It may seem + -- weird to put declarations in the sequence of statement but in + -- fact nothing forbids that at the tree level. We also set the + -- First_Real_Statement field so that we remember where the real + -- statements (i.e. original statements) begin. Note that if we + -- wrapped the statements, the first real statement is inside the + -- inner block. If the First_Real_Statement is already set (as is + -- the case for subprogram bodies that are expansions of task bodies) + -- then do not reset it, because its declarative part would migrate + -- to the statement part. + + if not Wrapped then + if No (First_Real_Statement (Handled_Statement_Sequence (N))) then + Set_First_Real_Statement (Handled_Statement_Sequence (N), + First (Statements (Handled_Statement_Sequence (N)))); + end if; + + else + Set_First_Real_Statement (Handled_Statement_Sequence (N), Blok); + end if; + + Append_List_To (Declarations (N), + Statements (Handled_Statement_Sequence (N))); + Set_Statements (Handled_Statement_Sequence (N), Declarations (N)); + + -- We need to reset the Sloc of the handled statement sequence to + -- properly reflect the new initial "statement" in the sequence. + + Set_Sloc + (Handled_Statement_Sequence (N), Sloc (First (Declarations (N)))); + + -- The declarations of the _Clean procedure and finalization chain + -- replace the old declarations that have been moved inward + + Set_Declarations (N, New_Decls); + Analyze_Declarations (New_Decls); + + -- The At_End call is attached to the sequence of statements + + declare + HSS : Node_Id; + + begin + -- If the construct is a protected subprogram, then the call to + -- the corresponding unprotected program appears in a block which + -- is the last statement in the body, and it is this block that + -- must be covered by the At_End handler. + + if Is_Protected then + HSS := Handled_Statement_Sequence + (Last (Statements (Handled_Statement_Sequence (N)))); + else + HSS := Handled_Statement_Sequence (N); + end if; + + Set_At_End_Proc (HSS, New_Occurrence_Of (Clean, Loc)); + Expand_At_End_Handler (HSS, Empty); + end; + + -- Restore saved polling mode + + Polling_Required := Old_Poll; + end Expand_Cleanup_Actions; + + ------------------------------- + -- Expand_Ctrl_Function_Call -- + ------------------------------- + + procedure Expand_Ctrl_Function_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Rtype : constant Entity_Id := Etype (N); + Utype : constant Entity_Id := Underlying_Type (Rtype); + Ref : Node_Id; + Action : Node_Id; + Action2 : Node_Id := Empty; + + Attach_Level : Uint := Uint_1; + Len_Ref : Node_Id := Empty; + + function Last_Array_Component + (Ref : Node_Id; + Typ : Entity_Id) return Node_Id; + -- Creates a reference to the last component of the array object + -- designated by Ref whose type is Typ. + + -------------------------- + -- Last_Array_Component -- + -------------------------- + + function Last_Array_Component + (Ref : Node_Id; + Typ : Entity_Id) return Node_Id + is + Index_List : constant List_Id := New_List; + + begin + for N in 1 .. Number_Dimensions (Typ) loop + Append_To (Index_List, + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr_No_Checks (Ref), + Attribute_Name => Name_Last, + Expressions => New_List ( + Make_Integer_Literal (Loc, N)))); + end loop; + + return + Make_Indexed_Component (Loc, + Prefix => Duplicate_Subexpr (Ref), + Expressions => Index_List); + end Last_Array_Component; + + -- Start of processing for Expand_Ctrl_Function_Call + + begin + -- Optimization, if the returned value (which is on the sec-stack) + -- is returned again, no need to copy/readjust/finalize, we can just + -- pass the value thru (see Expand_N_Return_Statement), and thus no + -- attachment is needed + + if Nkind (Parent (N)) = N_Return_Statement then + return; + end if; + + -- Resolution is now finished, make sure we don't start analysis again + -- because of the duplication + + Set_Analyzed (N); + Ref := Duplicate_Subexpr_No_Checks (N); + + -- Now we can generate the Attach Call, note that this value is + -- always in the (secondary) stack and thus is attached to a singly + -- linked final list: + + -- Resx := F (X)'reference; + -- Attach_To_Final_List (_Lx, Resx.all, 1); + + -- or when there are controlled components + + -- Attach_To_Final_List (_Lx, Resx._controller, 1); + + -- or when it is both is_controlled and has_controlled_components + + -- Attach_To_Final_List (_Lx, Resx._controller, 1); + -- Attach_To_Final_List (_Lx, Resx, 1); + + -- or if it is an array with is_controlled (and has_controlled) + + -- Attach_To_Final_List (_Lx, Resx (Resx'last), 3); + -- An attach level of 3 means that a whole array is to be + -- attached to the finalization list (including the controlled + -- components) + + -- or if it is an array with has_controlled components but not + -- is_controlled + + -- Attach_To_Final_List (_Lx, Resx (Resx'last)._controller, 3); + + if Has_Controlled_Component (Rtype) then + declare + T1 : Entity_Id := Rtype; + T2 : Entity_Id := Utype; + + begin + if Is_Array_Type (T2) then + Len_Ref := + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr_Move_Checks + (Unchecked_Convert_To (T2, Ref)), + Attribute_Name => Name_Length); + end if; + + while Is_Array_Type (T2) loop + if T1 /= T2 then + Ref := Unchecked_Convert_To (T2, Ref); + end if; + + Ref := Last_Array_Component (Ref, T2); + Attach_Level := Uint_3; + T1 := Component_Type (T2); + T2 := Underlying_Type (T1); + end loop; + + -- If the type has controlled components, go to the controller + -- except in the case of arrays of controlled objects since in + -- this case objects and their components are already chained + -- and the head of the chain is the last array element. + + if Is_Array_Type (Rtype) and then Is_Controlled (T2) then + null; + + elsif Has_Controlled_Component (T2) then + if T1 /= T2 then + Ref := Unchecked_Convert_To (T2, Ref); + end if; + + Ref := + Make_Selected_Component (Loc, + Prefix => Ref, + Selector_Name => Make_Identifier (Loc, Name_uController)); + end if; + end; + + -- Here we know that 'Ref' has a controller so we may as well + -- attach it directly + + Action := + Make_Attach_Call ( + Obj_Ref => Ref, + Flist_Ref => Find_Final_List (Current_Scope), + With_Attach => Make_Integer_Literal (Loc, Attach_Level)); + + -- If it is also Is_Controlled we need to attach the global object + + if Is_Controlled (Rtype) then + Action2 := + Make_Attach_Call ( + Obj_Ref => Duplicate_Subexpr_No_Checks (N), + Flist_Ref => Find_Final_List (Current_Scope), + With_Attach => Make_Integer_Literal (Loc, Attach_Level)); + end if; + + else + -- Here, we have a controlled type that does not seem to have + -- controlled components but it could be a class wide type whose + -- further derivations have controlled components. So we don't know + -- if the object itself needs to be attached or if it + -- has a record controller. We need to call a runtime function + -- (Deep_Tag_Attach) which knows what to do thanks to the + -- RC_Offset in the dispatch table. + + Action := + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Deep_Tag_Attach), Loc), + Parameter_Associations => New_List ( + Find_Final_List (Current_Scope), + + Make_Attribute_Reference (Loc, + Prefix => Ref, + Attribute_Name => Name_Address), + + Make_Integer_Literal (Loc, Attach_Level))); + end if; + + if Present (Len_Ref) then + Action := + Make_Implicit_If_Statement (N, + Condition => Make_Op_Gt (Loc, + Left_Opnd => Len_Ref, + Right_Opnd => Make_Integer_Literal (Loc, 0)), + Then_Statements => New_List (Action)); + end if; + + Insert_Action (N, Action); + if Present (Action2) then + Insert_Action (N, Action2); + end if; + end Expand_Ctrl_Function_Call; + + --------------------------- + -- 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 + Ent : constant Entity_Id := Corresponding_Spec (N); + + begin + -- This is done only for non-generic packages + + if Ekind (Ent) = E_Package then + New_Scope (Corresponding_Spec (N)); + Build_Task_Activation_Call (N); + Pop_Scope; + end if; + + Set_Elaboration_Flag (N, Corresponding_Spec (N)); + Set_In_Package_Body (Ent, False); + + -- Set to encode entity names in package body before gigi is called + + Qualify_Entity_Names (N); + 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 Ada83, 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 + begin + if Nkind (Parent (N)) = N_Compilation_Unit + and then not Body_Required (Parent (N)) + and then not Unit_Requires_Body (Defining_Entity (N)) + and then Present (Activation_Chain_Entity (N)) + then + New_Scope (Defining_Entity (N)); + Build_Task_Activation_Call (N); + Pop_Scope; + 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); + end Expand_N_Package_Declaration; + + --------------------- + -- Find_Final_List -- + --------------------- + + function Find_Final_List + (E : Entity_Id; + Ref : Node_Id := Empty) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Ref); + S : Entity_Id; + Id : Entity_Id; + R : Node_Id; + + begin + -- Case of an internal component. The Final list is the record + -- controller of the enclosing record + + if Present (Ref) then + R := Ref; + loop + case Nkind (R) is + when N_Unchecked_Type_Conversion | N_Type_Conversion => + R := Expression (R); + + when N_Indexed_Component | N_Explicit_Dereference => + R := Prefix (R); + + when N_Selected_Component => + R := Prefix (R); + exit; + + when N_Identifier => + exit; + + when others => + raise Program_Error; + end case; + end loop; + + return + Make_Selected_Component (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => R, + Selector_Name => Make_Identifier (Loc, Name_uController)), + Selector_Name => Make_Identifier (Loc, Name_F)); + + -- Case of a dynamically allocated object. The final list is the + -- corresponding list controller (The next entity in the scope of + -- the access type with the right type). If the type comes from a + -- With_Type clause, no controller was created, and we use the + -- global chain instead. + + elsif Is_Access_Type (E) then + if not From_With_Type (E) then + return + Make_Selected_Component (Loc, + Prefix => + New_Reference_To + (Associated_Final_Chain (Base_Type (E)), Loc), + Selector_Name => Make_Identifier (Loc, Name_F)); + else + return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E)); + end if; + + else + if Is_Dynamic_Scope (E) then + S := E; + else + S := Enclosing_Dynamic_Scope (E); + end if; + + -- When the finalization chain entity is 'Error', it means that + -- there should not be any chain at that level and that the + -- enclosing one should be used + + -- This is a nasty kludge, see ??? note in exp_ch11 + + while Finalization_Chain_Entity (S) = Error loop + S := Enclosing_Dynamic_Scope (S); + end loop; + + if S = Standard_Standard then + return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E)); + else + if No (Finalization_Chain_Entity (S)) then + + Id := Make_Defining_Identifier (Sloc (S), + New_Internal_Name ('F')); + Set_Finalization_Chain_Entity (S, Id); + + -- Set momentarily some semantics attributes to allow normal + -- analysis of expansions containing references to this chain. + -- Will be fully decorated during the expansion of the scope + -- itself + + Set_Ekind (Id, E_Variable); + Set_Etype (Id, RTE (RE_Finalizable_Ptr)); + end if; + + return New_Reference_To (Finalization_Chain_Entity (S), Sloc (E)); + end if; + end if; + end Find_Final_List; + + ----------------------------- + -- Find_Node_To_Be_Wrapped -- + ----------------------------- + + function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is + P : Node_Id; + The_Parent : Node_Id; + + begin + The_Parent := N; + loop + P := The_Parent; + pragma Assert (P /= Empty); + The_Parent := Parent (P); + + case Nkind (The_Parent) is + + -- Simple statement can be wrapped + + when N_Pragma => + return The_Parent; + + -- Usually assignments are good candidate for wrapping + -- except when they have been generated as part of a + -- controlled aggregate where the wrapping should take + -- place more globally. + + when N_Assignment_Statement => + if No_Ctrl_Actions (The_Parent) then + null; + else + return The_Parent; + end if; + + -- An entry call statement is a special case if it occurs in + -- the context of a Timed_Entry_Call. In this case we wrap + -- the entire timed entry call. + + when N_Entry_Call_Statement | + N_Procedure_Call_Statement => + if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative + and then + (Nkind (Parent (Parent (The_Parent))) + = N_Timed_Entry_Call + or else + Nkind (Parent (Parent (The_Parent))) + = N_Conditional_Entry_Call) + then + return Parent (Parent (The_Parent)); + else + return The_Parent; + end if; + + -- Object declarations are also a boundary for the transient scope + -- even if they are not really wrapped + -- (see Wrap_Transient_Declaration) + + when N_Object_Declaration | + N_Object_Renaming_Declaration | + N_Subtype_Declaration => + return The_Parent; + + -- The expression itself is to be wrapped if its parent is a + -- compound statement or any other statement where the expression + -- is known to be scalar + + when N_Accept_Alternative | + N_Attribute_Definition_Clause | + N_Case_Statement | + N_Code_Statement | + N_Delay_Alternative | + N_Delay_Until_Statement | + N_Delay_Relative_Statement | + N_Discriminant_Association | + N_Elsif_Part | + N_Entry_Body_Formal_Part | + N_Exit_Statement | + N_If_Statement | + N_Iteration_Scheme | + N_Terminate_Alternative => + return P; + + when N_Attribute_Reference => + + if Is_Procedure_Attribute_Name + (Attribute_Name (The_Parent)) + then + return The_Parent; + end if; + + -- A raise statement can be wrapped. This will arise when the + -- expression in a raise_with_expression uses the secondary + -- stack, for example. + + when N_Raise_Statement => + return The_Parent; + + -- If the expression is within the iteration scheme of a loop, + -- we must create a declaration for it, followed by an assignment + -- in order to have a usable statement to wrap. + + when N_Loop_Parameter_Specification => + return Parent (The_Parent); + + -- The following nodes contains "dummy calls" which don't + -- need to be wrapped. + + when N_Parameter_Specification | + N_Discriminant_Specification | + N_Component_Declaration => + return Empty; + + -- The return statement is not to be wrapped when the function + -- itself needs wrapping at the outer-level + + when N_Return_Statement => + if Requires_Transient_Scope (Return_Type (The_Parent)) then + return Empty; + else + return The_Parent; + end if; + + -- If we leave a scope without having been able to find a node to + -- wrap, something is going wrong but this can happen in error + -- situation that are not detected yet (such as a dynamic string + -- in a pragma export) + + when N_Subprogram_Body | + N_Package_Declaration | + N_Package_Body | + N_Block_Statement => + return Empty; + + -- otherwise continue the search + + when others => + null; + end case; + end loop; + end Find_Node_To_Be_Wrapped; + + ---------------------- + -- Global_Flist_Ref -- + ---------------------- + + function Global_Flist_Ref (Flist_Ref : Node_Id) return Boolean is + Flist : Entity_Id; + + begin + -- Look for the Global_Final_List + + if Is_Entity_Name (Flist_Ref) then + Flist := Entity (Flist_Ref); + + -- Look for the final list associated with an access to controlled + + elsif Nkind (Flist_Ref) = N_Selected_Component + and then Is_Entity_Name (Prefix (Flist_Ref)) + then + Flist := Entity (Prefix (Flist_Ref)); + else + return False; + end if; + + return Present (Flist) + and then Present (Scope (Flist)) + and then Enclosing_Dynamic_Scope (Flist) = Standard_Standard; + end Global_Flist_Ref; + + ---------------------------------- + -- Has_New_Controlled_Component -- + ---------------------------------- + + function Has_New_Controlled_Component (E : Entity_Id) return Boolean is + Comp : Entity_Id; + + begin + if not Is_Tagged_Type (E) then + return Has_Controlled_Component (E); + elsif not Is_Derived_Type (E) then + return Has_Controlled_Component (E); + end if; + + Comp := First_Component (E); + while Present (Comp) loop + + if Chars (Comp) = Name_uParent then + null; + + elsif Scope (Original_Record_Component (Comp)) = E + and then Controlled_Type (Etype (Comp)) + then + return True; + end if; + + Next_Component (Comp); + end loop; + + return False; + end Has_New_Controlled_Component; + + -------------------------- + -- In_Finalization_Root -- + -------------------------- + + -- It would seem simpler to test Scope (RTE (RE_Root_Controlled)) but + -- the purpose of this function is to avoid a circular call to Rtsfind + -- which would been caused by such a test. + + function In_Finalization_Root (E : Entity_Id) return Boolean is + S : constant Entity_Id := Scope (E); + + begin + return Chars (Scope (S)) = Name_System + and then Chars (S) = Name_Finalization_Root + and then Scope (Scope (S)) = Standard_Standard; + end In_Finalization_Root; + + ------------------------------------ + -- Insert_Actions_In_Scope_Around -- + ------------------------------------ + + procedure Insert_Actions_In_Scope_Around (N : Node_Id) is + SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); + Target : Node_Id; + + begin + -- If the node to be wrapped is the triggering alternative 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. + + if Nkind (Parent (Node_To_Be_Wrapped)) = N_Triggering_Alternative then + Target := Parent (Parent (Node_To_Be_Wrapped)); + else + Target := N; + end if; + + if Present (SE.Actions_To_Be_Wrapped_Before) then + Insert_List_Before (Target, SE.Actions_To_Be_Wrapped_Before); + SE.Actions_To_Be_Wrapped_Before := No_List; + end if; + + if Present (SE.Actions_To_Be_Wrapped_After) then + Insert_List_After (Target, SE.Actions_To_Be_Wrapped_After); + SE.Actions_To_Be_Wrapped_After := No_List; + end if; + end Insert_Actions_In_Scope_Around; + + ----------------------- + -- Make_Adjust_Call -- + ----------------------- + + function Make_Adjust_Call + (Ref : Node_Id; + Typ : Entity_Id; + Flist_Ref : Node_Id; + With_Attach : Node_Id; + Allocator : Boolean := False) return List_Id + is + Loc : constant Source_Ptr := Sloc (Ref); + Res : constant List_Id := New_List; + Utyp : Entity_Id; + Proc : Entity_Id; + Cref : Node_Id := Ref; + Cref2 : Node_Id; + Attach : Node_Id := With_Attach; + + begin + if Is_Class_Wide_Type (Typ) then + Utyp := Underlying_Type (Base_Type (Root_Type (Typ))); + else + Utyp := Underlying_Type (Base_Type (Typ)); + end if; + + Set_Assignment_OK (Cref); + + -- Deal with non-tagged derivation of private views + + if Is_Untagged_Derivation (Typ) then + Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); + Cref := Unchecked_Convert_To (Utyp, Cref); + Set_Assignment_OK (Cref); + -- To prevent problems with UC see 1.156 RH ??? + end if; + + -- If the underlying_type is a subtype, we are dealing with + -- the completion of a private type. We need to access + -- the base type and generate a conversion to it. + + if Utyp /= Base_Type (Utyp) then + pragma Assert (Is_Private_Type (Typ)); + Utyp := Base_Type (Utyp); + Cref := Unchecked_Convert_To (Utyp, Cref); + end if; + + -- If the object is unanalyzed, set its expected type for use + -- in Convert_View in case an additional conversion is needed. + + if No (Etype (Cref)) + and then Nkind (Cref) /= N_Unchecked_Type_Conversion + then + Set_Etype (Cref, Typ); + end if; + + -- We do not need to attach to one of the Global Final Lists + -- the objects whose type is Finalize_Storage_Only + + if Finalize_Storage_Only (Typ) + and then (Global_Flist_Ref (Flist_Ref) + or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) + = Standard_True) + then + Attach := Make_Integer_Literal (Loc, 0); + end if; + + -- Special case for allocators: need initialization of the chain + -- pointers. For the 0 case, reset them to null. + + if Allocator then + pragma Assert (Nkind (Attach) = N_Integer_Literal); + + if Intval (Attach) = 0 then + Set_Intval (Attach, Uint_4); + end if; + end if; + + -- Generate: + -- Deep_Adjust (Flist_Ref, Ref, Attach); + + if Has_Controlled_Component (Utyp) + or else Is_Class_Wide_Type (Typ) + then + if Is_Tagged_Type (Utyp) then + Proc := Find_Prim_Op (Utyp, TSS_Deep_Adjust); + + else + Proc := TSS (Utyp, TSS_Deep_Adjust); + end if; + + Cref := Convert_View (Proc, Cref, 2); + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => + New_List (Flist_Ref, Cref, Attach))); + + -- Generate: + -- if With_Attach then + -- Attach_To_Final_List (Ref, Flist_Ref); + -- end if; + -- Adjust (Ref); + + else -- Is_Controlled (Utyp) + + Proc := Find_Prim_Op (Utyp, Name_Of (Adjust_Case)); + Cref := Convert_View (Proc, Cref); + Cref2 := New_Copy_Tree (Cref); + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => New_List (Cref2))); + + Append_To (Res, Make_Attach_Call (Cref, Flist_Ref, Attach)); + end if; + + return Res; + end Make_Adjust_Call; + + ---------------------- + -- Make_Attach_Call -- + ---------------------- + + -- Generate: + -- System.FI.Attach_To_Final_List (Flist, Ref, Nb_Link) + + function Make_Attach_Call + (Obj_Ref : Node_Id; + Flist_Ref : Node_Id; + With_Attach : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Obj_Ref); + + begin + -- Optimization: If the number of links is statically '0', don't + -- call the attach_proc. + + if Nkind (With_Attach) = N_Integer_Literal + and then Intval (With_Attach) = Uint_0 + then + return Make_Null_Statement (Loc); + end if; + + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Attach_To_Final_List), Loc), + Parameter_Associations => New_List ( + Flist_Ref, + OK_Convert_To (RTE (RE_Finalizable), Obj_Ref), + With_Attach)); + end Make_Attach_Call; + + ---------------- + -- Make_Clean -- + ---------------- + + function Make_Clean + (N : Node_Id; + Clean : Entity_Id; + Mark : Entity_Id; + Flist : Entity_Id; + Is_Task : Boolean; + Is_Master : Boolean; + Is_Protected_Subprogram : Boolean; + Is_Task_Allocation_Block : Boolean; + Is_Asynchronous_Call_Block : Boolean) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Clean); + Stmt : constant List_Id := New_List; + + Sbody : Node_Id; + Spec : Node_Id; + Name : Node_Id; + Param : Node_Id; + Param_Type : Entity_Id; + Pid : Entity_Id := Empty; + Cancel_Param : Entity_Id; + + begin + if Is_Task then + if Restricted_Profile then + Append_To + (Stmt, Build_Runtime_Call (Loc, RE_Complete_Restricted_Task)); + else + Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Task)); + end if; + + elsif Is_Master then + if Restriction_Active (No_Task_Hierarchy) = False then + Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Master)); + end if; + + elsif Is_Protected_Subprogram then + + -- Add statements to the cleanup handler of the (ordinary) + -- subprogram expanded to implement a protected subprogram, + -- unlocking the protected object parameter and undeferring abort. + -- If this is a protected procedure, and the object contains + -- entries, this also calls the entry service routine. + + -- NOTE: This cleanup handler references _object, a parameter + -- to the procedure. + + -- Find the _object parameter representing the protected object + + Spec := Parent (Corresponding_Spec (N)); + + Param := First (Parameter_Specifications (Spec)); + loop + Param_Type := Etype (Parameter_Type (Param)); + + if Ekind (Param_Type) = E_Record_Type then + Pid := Corresponding_Concurrent_Type (Param_Type); + end if; + + exit when No (Param) or else Present (Pid); + Next (Param); + end loop; + + pragma Assert (Present (Param)); + + -- If the associated protected object declares entries, + -- a protected procedure has to service entry queues. + -- In this case, add + + -- Service_Entries (_object._object'Access); + + -- _object is the record used to implement the protected object. + -- It is a parameter to the protected subprogram. + + if Nkind (Specification (N)) = N_Procedure_Specification + and then Has_Entries (Pid) + then + if Abort_Allowed + or else Restriction_Active (No_Entry_Queue) = False + or else Number_Entries (Pid) > 1 + then + Name := New_Reference_To (RTE (RE_Service_Entries), Loc); + else + Name := New_Reference_To (RTE (RE_Service_Entry), Loc); + end if; + + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => Name, + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To ( + Defining_Identifier (Param), Loc), + Selector_Name => + Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)))); + + else + -- Unlock (_object._object'Access); + + -- object is the record used to implement the protected object. + -- It is a parameter to the protected subprogram. + + -- If the protected object is controlled (i.e it has entries or + -- needs finalization for interrupt handling), call + -- Unlock_Entries, except if the protected object follows the + -- ravenscar profile, in which case call Unlock_Entry, otherwise + -- call the simplified version, Unlock. + + if Has_Entries (Pid) + or else Has_Interrupt_Handler (Pid) + or else (Has_Attach_Handler (Pid) + and then not Restricted_Profile) + or else (Ada_Version >= Ada_05 + and then Present (Interface_List (Parent (Pid)))) + then + if Abort_Allowed + or else Restriction_Active (No_Entry_Queue) = False + or else Number_Entries (Pid) > 1 + then + Name := New_Reference_To (RTE (RE_Unlock_Entries), Loc); + else + Name := New_Reference_To (RTE (RE_Unlock_Entry), Loc); + end if; + + else + Name := New_Reference_To (RTE (RE_Unlock), Loc); + end if; + + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => Name, + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + New_Reference_To (Defining_Identifier (Param), Loc), + Selector_Name => + Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)))); + end if; + + if Abort_Allowed then + + -- Abort_Undefer; + + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + RTE (RE_Abort_Undefer), Loc), + Parameter_Associations => Empty_List)); + end if; + + elsif Is_Task_Allocation_Block then + + -- Add a call to Expunge_Unactivated_Tasks to the cleanup + -- handler of a block created for the dynamic allocation of + -- tasks: + + -- 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. + + -- This only applies to dynamically allocated tasks; + -- other unactivated tasks are completed by Complete_Task or + -- Complete_Master. + + -- NOTE: This cleanup handler references _chain, a local + -- object. + + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + RTE (RE_Expunge_Unactivated_Tasks), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Activation_Chain_Entity (N), Loc)))); + + elsif Is_Asynchronous_Call_Block then + + -- Add a call to attempt to cancel the asynchronous entry call + -- whenever the block containing the abortable part is exited. + + -- NOTE: This cleanup handler references C, a local object + + -- Get the argument to the Cancel procedure + Cancel_Param := Entry_Cancel_Parameter (Entity (Identifier (N))); + + -- If it is of type Communication_Block, this must be a + -- protected entry call. + + if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then + + Append_To (Stmt, + + -- if Enqueued (Cancel_Parameter) then + + Make_Implicit_If_Statement (Clean, + Condition => Make_Function_Call (Loc, + Name => New_Reference_To ( + RTE (RE_Enqueued), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Cancel_Param, Loc))), + Then_Statements => New_List ( + + -- Cancel_Protected_Entry_Call (Cancel_Param); + + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Cancel_Protected_Entry_Call), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Cancel_Param, Loc)))))); + + -- Asynchronous delay + + elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Cancel_Param, Loc), + Attribute_Name => Name_Unchecked_Access)))); + + -- Task entry call + + else + -- Append call to Cancel_Task_Entry_Call (C); + + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Cancel_Task_Entry_Call), + Loc), + Parameter_Associations => New_List ( + New_Reference_To (Cancel_Param, Loc)))); + + end if; + end if; + + if Present (Flist) then + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Finalize_List), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Flist, Loc)))); + end if; + + if Present (Mark) then + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_SS_Release), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Mark, Loc)))); + end if; + + Sbody := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Clean), + + Declarations => New_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmt)); + + if Present (Flist) or else Is_Task or else Is_Master then + Wrap_Cleanup_Procedure (Sbody); + end if; + + -- We do not want debug information for _Clean routines, + -- since it just confuses the debugging operation unless + -- we are debugging generated code. + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Clean, True); + end if; + + return Sbody; + end Make_Clean; + + -------------------------- + -- Make_Deep_Array_Body -- + -------------------------- + + -- Array components are initialized and adjusted in the normal order + -- and finalized in the reverse order. Exceptions are handled and + -- Program_Error is re-raise in the Adjust and Finalize case + -- (RM 7.6.1(12)). Generate the following code : + -- + -- procedure Deep_<P> -- with <P> being Initialize or Adjust or Finalize + -- (L : in out Finalizable_Ptr; + -- V : in out Typ) + -- is + -- begin + -- for J1 in Typ'First (1) .. Typ'Last (1) loop + -- ^ reverse ^ -- in the finalization case + -- ... + -- for J2 in Typ'First (n) .. Typ'Last (n) loop + -- Make_<P>_Call (Typ, V (J1, .. , Jn), L, V); + -- end loop; + -- ... + -- end loop; + -- exception -- not in the + -- when others => raise Program_Error; -- Initialize case + -- end Deep_<P>; + + function Make_Deep_Array_Body + (Prim : Final_Primitives; + Typ : Entity_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + + Index_List : constant List_Id := New_List; + -- Stores the list of references to the indexes (one per dimension) + + function One_Component return List_Id; + -- Create one statement to initialize/adjust/finalize one array + -- component, designated by a full set of indices. + + function One_Dimension (N : Int) return List_Id; + -- Create loop to deal with one dimension of the array. The single + -- statement in the body of the loop initializes the inner dimensions if + -- any, or else a single component. + + ------------------- + -- One_Component -- + ------------------- + + function One_Component return List_Id is + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Comp_Ref : constant Node_Id := + Make_Indexed_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Expressions => Index_List); + + begin + -- Set the etype of the component Reference, which is used to + -- determine whether a conversion to a parent type is needed. + + Set_Etype (Comp_Ref, Comp_Typ); + + case Prim is + when Initialize_Case => + return Make_Init_Call (Comp_Ref, Comp_Typ, + Make_Identifier (Loc, Name_L), + Make_Identifier (Loc, Name_B)); + + when Adjust_Case => + return Make_Adjust_Call (Comp_Ref, Comp_Typ, + Make_Identifier (Loc, Name_L), + Make_Identifier (Loc, Name_B)); + + when Finalize_Case => + return Make_Final_Call (Comp_Ref, Comp_Typ, + Make_Identifier (Loc, Name_B)); + end case; + end One_Component; + + ------------------- + -- One_Dimension -- + ------------------- + + function One_Dimension (N : Int) return List_Id is + Index : Entity_Id; + + begin + if N > Number_Dimensions (Typ) then + return One_Component; + + else + Index := + Make_Defining_Identifier (Loc, New_External_Name ('J', N)); + + Append_To (Index_List, New_Reference_To (Index, Loc)); + + return New_List ( + Make_Implicit_Loop_Statement (Typ, + 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 => Make_Identifier (Loc, Name_V), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, N))), + Reverse_Present => Prim = Finalize_Case)), + Statements => One_Dimension (N + 1))); + end if; + end One_Dimension; + + -- Start of processing for Make_Deep_Array_Body + + begin + return One_Dimension (1); + end Make_Deep_Array_Body; + + -------------------- + -- Make_Deep_Proc -- + -------------------- + + -- Generate: + -- procedure DEEP_<prim> + -- (L : IN OUT Finalizable_Ptr; -- not for Finalize + -- V : IN OUT <typ>; + -- B : IN Short_Short_Integer) is + -- begin + -- <stmts>; + -- exception -- Finalize and Adjust Cases only + -- raise Program_Error; -- idem + -- end DEEP_<prim>; + + 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_Name : Entity_Id; + Handler : List_Id := No_List; + Type_B : Entity_Id; + + begin + if Prim = Finalize_Case then + Formals := New_List; + Type_B := Standard_Boolean; + + else + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_L), + In_Present => True, + Out_Present => True, + Parameter_Type => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); + Type_B := Standard_Short_Short_Integer; + end if; + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + In_Present => True, + Out_Present => True, + Parameter_Type => New_Reference_To (Typ, Loc))); + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_B), + Parameter_Type => New_Reference_To (Type_B, Loc))); + + if Prim = Finalize_Case or else Prim = Adjust_Case then + Handler := New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Raise_Program_Error (Loc, + Reason => PE_Finalize_Raised_Exception)))); + end if; + + Proc_Name := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim))); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Name, + Parameter_Specifications => Formals), + + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts, + Exception_Handlers => Handler))); + + return Proc_Name; + end Make_Deep_Proc; + + --------------------------- + -- Make_Deep_Record_Body -- + --------------------------- + + -- The Deep procedures call the appropriate Controlling proc on the + -- the controller component. In the init case, it also attach the + -- controller to the current finalization list. + + function Make_Deep_Record_Body + (Prim : Final_Primitives; + Typ : Entity_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Controller_Typ : Entity_Id; + Obj_Ref : constant Node_Id := Make_Identifier (Loc, Name_V); + Controller_Ref : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => Obj_Ref, + Selector_Name => + Make_Identifier (Loc, Name_uController)); + Res : constant List_Id := New_List; + + begin + if Is_Return_By_Reference_Type (Typ) then + Controller_Typ := RTE (RE_Limited_Record_Controller); + else + Controller_Typ := RTE (RE_Record_Controller); + end if; + + case Prim is + when Initialize_Case => + Append_List_To (Res, + Make_Init_Call ( + Ref => Controller_Ref, + Typ => Controller_Typ, + Flist_Ref => Make_Identifier (Loc, Name_L), + With_Attach => Make_Identifier (Loc, Name_B))); + + -- When the type is also a controlled type by itself, + -- Initialize it and attach it to the finalization chain + + if Is_Controlled (Typ) then + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + Find_Prim_Op (Typ, Name_Of (Prim)), Loc), + Parameter_Associations => + New_List (New_Copy_Tree (Obj_Ref)))); + + Append_To (Res, Make_Attach_Call ( + Obj_Ref => New_Copy_Tree (Obj_Ref), + Flist_Ref => Make_Identifier (Loc, Name_L), + With_Attach => Make_Identifier (Loc, Name_B))); + end if; + + when Adjust_Case => + Append_List_To (Res, + Make_Adjust_Call (Controller_Ref, Controller_Typ, + Make_Identifier (Loc, Name_L), + Make_Identifier (Loc, Name_B))); + + -- When the type is also a controlled type by itself, + -- Adjust it it and attach it to the finalization chain + + if Is_Controlled (Typ) then + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + Find_Prim_Op (Typ, Name_Of (Prim)), Loc), + Parameter_Associations => + New_List (New_Copy_Tree (Obj_Ref)))); + + Append_To (Res, Make_Attach_Call ( + Obj_Ref => New_Copy_Tree (Obj_Ref), + Flist_Ref => Make_Identifier (Loc, Name_L), + With_Attach => Make_Identifier (Loc, Name_B))); + end if; + + when Finalize_Case => + if Is_Controlled (Typ) then + Append_To (Res, + Make_Implicit_If_Statement (Obj_Ref, + Condition => Make_Identifier (Loc, Name_B), + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Finalize_One), Loc), + Parameter_Associations => New_List ( + OK_Convert_To (RTE (RE_Finalizable), + New_Copy_Tree (Obj_Ref))))), + + Else_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + Find_Prim_Op (Typ, Name_Of (Prim)), Loc), + Parameter_Associations => + New_List (New_Copy_Tree (Obj_Ref)))))); + end if; + + Append_List_To (Res, + Make_Final_Call (Controller_Ref, Controller_Typ, + Make_Identifier (Loc, Name_B))); + end case; + return Res; + end Make_Deep_Record_Body; + + ---------------------- + -- Make_Final_Call -- + ---------------------- + + function Make_Final_Call + (Ref : Node_Id; + Typ : Entity_Id; + With_Detach : Node_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (Ref); + Res : constant List_Id := New_List; + Cref : Node_Id; + Cref2 : Node_Id; + Proc : Entity_Id; + Utyp : Entity_Id; + + begin + if Is_Class_Wide_Type (Typ) then + Utyp := Root_Type (Typ); + Cref := Ref; + + elsif Is_Concurrent_Type (Typ) then + Utyp := Corresponding_Record_Type (Typ); + Cref := Convert_Concurrent (Ref, Typ); + + elsif Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + and then Is_Concurrent_Type (Full_View (Typ)) + then + Utyp := Corresponding_Record_Type (Full_View (Typ)); + Cref := Convert_Concurrent (Ref, Full_View (Typ)); + else + Utyp := Typ; + Cref := Ref; + end if; + + Utyp := Underlying_Type (Base_Type (Utyp)); + Set_Assignment_OK (Cref); + + -- Deal with non-tagged derivation of private views. If the parent is + -- now known to be protected, the finalization routine is the one + -- defined on the corresponding record of the ancestor (corresponding + -- records do not automatically inherit operations, but maybe they + -- should???) + + if Is_Untagged_Derivation (Typ) then + if Is_Protected_Type (Typ) then + Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); + else + Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); + end if; + + Cref := Unchecked_Convert_To (Utyp, Cref); + + -- We need to set Assignment_OK to prevent problems with unchecked + -- conversions, where we do not want them to be converted back in the + -- case of untagged record derivation (see code in Make_*_Call + -- procedures for similar situations). + + Set_Assignment_OK (Cref); + end if; + + -- If the underlying_type is a subtype, we are dealing with + -- the completion of a private type. We need to access + -- the base type and generate a conversion to it. + + if Utyp /= Base_Type (Utyp) then + pragma Assert (Is_Private_Type (Typ)); + Utyp := Base_Type (Utyp); + Cref := Unchecked_Convert_To (Utyp, Cref); + end if; + + -- Generate: + -- Deep_Finalize (Ref, With_Detach); + + if Has_Controlled_Component (Utyp) + or else Is_Class_Wide_Type (Typ) + then + if Is_Tagged_Type (Utyp) then + Proc := Find_Prim_Op (Utyp, TSS_Deep_Finalize); + else + Proc := TSS (Utyp, TSS_Deep_Finalize); + end if; + + Cref := Convert_View (Proc, Cref); + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => + New_List (Cref, With_Detach))); + + -- Generate: + -- if With_Detach then + -- Finalize_One (Ref); + -- else + -- Finalize (Ref); + -- end if; + + else + Proc := Find_Prim_Op (Utyp, Name_Of (Finalize_Case)); + + if Chars (With_Detach) = Chars (Standard_True) then + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Finalize_One), Loc), + Parameter_Associations => New_List ( + OK_Convert_To (RTE (RE_Finalizable), Cref)))); + + elsif Chars (With_Detach) = Chars (Standard_False) then + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => + New_List (Convert_View (Proc, Cref)))); + + else + Cref2 := New_Copy_Tree (Cref); + Append_To (Res, + Make_Implicit_If_Statement (Ref, + Condition => With_Detach, + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Finalize_One), Loc), + Parameter_Associations => New_List ( + OK_Convert_To (RTE (RE_Finalizable), Cref)))), + + Else_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => + New_List (Convert_View (Proc, Cref2)))))); + end if; + end if; + + return Res; + end Make_Final_Call; + + -------------------- + -- Make_Init_Call -- + -------------------- + + function Make_Init_Call + (Ref : Node_Id; + Typ : Entity_Id; + Flist_Ref : Node_Id; + With_Attach : Node_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (Ref); + Is_Conc : Boolean; + Res : constant List_Id := New_List; + Proc : Entity_Id; + Utyp : Entity_Id; + Cref : Node_Id; + Cref2 : Node_Id; + Attach : Node_Id := With_Attach; + + begin + if Is_Concurrent_Type (Typ) then + Is_Conc := True; + Utyp := Corresponding_Record_Type (Typ); + Cref := 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)); + Cref := Convert_Concurrent (Ref, Underlying_Type (Typ)); + + else + Is_Conc := False; + Utyp := Typ; + Cref := Ref; + end if; + + Utyp := Underlying_Type (Base_Type (Utyp)); + + Set_Assignment_OK (Cref); + + -- Deal with non-tagged derivation of private views + + if Is_Untagged_Derivation (Typ) + and then not Is_Conc + then + Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); + Cref := Unchecked_Convert_To (Utyp, Cref); + Set_Assignment_OK (Cref); + -- To prevent problems with UC see 1.156 RH ??? + end if; + + -- If the underlying_type is a subtype, we are dealing with + -- the completion of a private type. We need to access + -- the base type and generate a conversion to it. + + if Utyp /= Base_Type (Utyp) then + pragma Assert (Is_Private_Type (Typ)); + Utyp := Base_Type (Utyp); + Cref := Unchecked_Convert_To (Utyp, Cref); + end if; + + -- We do not need to attach to one of the Global Final Lists + -- the objects whose type is Finalize_Storage_Only + + if Finalize_Storage_Only (Typ) + and then (Global_Flist_Ref (Flist_Ref) + or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) + = Standard_True) + then + Attach := Make_Integer_Literal (Loc, 0); + end if; + + -- Generate: + -- Deep_Initialize (Ref, Flist_Ref); + + if Has_Controlled_Component (Utyp) then + Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case)); + + Cref := Convert_View (Proc, Cref, 2); + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => New_List ( + Node1 => Flist_Ref, + Node2 => Cref, + Node3 => Attach))); + + -- Generate: + -- Attach_To_Final_List (Ref, Flist_Ref); + -- Initialize (Ref); + + else -- Is_Controlled (Utyp) + Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case)); + Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Cref); + + Cref := Convert_View (Proc, Cref); + Cref2 := New_Copy_Tree (Cref); + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => New_List (Cref2))); + + Append_To (Res, + Make_Attach_Call (Cref, Flist_Ref, Attach)); + end if; + + return Res; + end Make_Init_Call; + + -------------------------- + -- Make_Transient_Block -- + -------------------------- + + -- If finalization is involved, this function just wraps the instruction + -- into a block whose name is the transient block entity, and then + -- Expand_Cleanup_Actions (called on the expansion of the handled + -- sequence of statements will do the necessary expansions for + -- cleanups). + + function Make_Transient_Block + (Loc : Source_Ptr; + Action : Node_Id) return Node_Id + is + Flist : constant Entity_Id := Finalization_Chain_Entity (Current_Scope); + Decls : constant List_Id := New_List; + Par : constant Node_Id := Parent (Action); + Instrs : constant List_Id := New_List (Action); + Blk : Node_Id; + + begin + -- Case where only secondary stack use is involved + + if Uses_Sec_Stack (Current_Scope) + and then No (Flist) + and then Nkind (Action) /= N_Return_Statement + and then Nkind (Par) /= N_Exception_Handler + then + + declare + S : Entity_Id; + K : Entity_Kind; + begin + S := Scope (Current_Scope); + loop + K := Ekind (S); + + -- At the outer level, no need to release the sec stack + + if S = Standard_Standard then + Set_Uses_Sec_Stack (Current_Scope, False); + exit; + + -- In a function, only release the sec stack if the + -- function does not return on the sec stack otherwise + -- the result may be lost. The caller is responsible for + -- releasing. + + elsif K = E_Function then + Set_Uses_Sec_Stack (Current_Scope, False); + + if not Requires_Transient_Scope (Etype (S)) then + if not Functions_Return_By_DSP_On_Target then + Set_Uses_Sec_Stack (S, True); + Check_Restriction (No_Secondary_Stack, Action); + end if; + end if; + + exit; + + -- In a loop or entry we should install a block encompassing + -- all the construct. For now just release right away. + + elsif K = E_Loop or else K = E_Entry then + exit; + + -- In a procedure or a block, we release on exit of the + -- procedure or block. ??? memory leak can be created by + -- recursive calls. + + elsif K = E_Procedure + or else K = E_Block + then + if not Functions_Return_By_DSP_On_Target then + Set_Uses_Sec_Stack (S, True); + Check_Restriction (No_Secondary_Stack, Action); + end if; + + Set_Uses_Sec_Stack (Current_Scope, False); + exit; + + else + S := Scope (S); + end if; + end loop; + end; + end if; + + -- Insert actions stuck in the transient scopes as well as all + -- freezing nodes needed by those actions + + Insert_Actions_In_Scope_Around (Action); + + declare + Last_Inserted : Node_Id := Prev (Action); + + begin + if Present (Last_Inserted) then + Freeze_All (First_Entity (Current_Scope), Last_Inserted); + end if; + end; + + Blk := + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Current_Scope, Loc), + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs), + Has_Created_Identifier => True); + + -- 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 Blk; + end Make_Transient_Block; + + ------------------------ + -- Node_To_Be_Wrapped -- + ------------------------ + + function Node_To_Be_Wrapped return Node_Id is + begin + return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped; + end Node_To_Be_Wrapped; + + ---------------------------- + -- Set_Node_To_Be_Wrapped -- + ---------------------------- + + procedure Set_Node_To_Be_Wrapped (N : Node_Id) is + begin + Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N; + end Set_Node_To_Be_Wrapped; + + ---------------------------------- + -- Store_After_Actions_In_Scope -- + ---------------------------------- + + procedure Store_After_Actions_In_Scope (L : List_Id) is + SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); + + begin + if Present (SE.Actions_To_Be_Wrapped_After) then + Insert_List_Before_And_Analyze ( + First (SE.Actions_To_Be_Wrapped_After), L); + + else + SE.Actions_To_Be_Wrapped_After := L; + + if Is_List_Member (SE.Node_To_Be_Wrapped) then + Set_Parent (L, Parent (SE.Node_To_Be_Wrapped)); + else + Set_Parent (L, SE.Node_To_Be_Wrapped); + end if; + + Analyze_List (L); + end if; + end Store_After_Actions_In_Scope; + + ----------------------------------- + -- Store_Before_Actions_In_Scope -- + ----------------------------------- + + procedure Store_Before_Actions_In_Scope (L : List_Id) is + SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); + + begin + if Present (SE.Actions_To_Be_Wrapped_Before) then + Insert_List_After_And_Analyze ( + Last (SE.Actions_To_Be_Wrapped_Before), L); + + else + SE.Actions_To_Be_Wrapped_Before := L; + + if Is_List_Member (SE.Node_To_Be_Wrapped) then + Set_Parent (L, Parent (SE.Node_To_Be_Wrapped)); + else + Set_Parent (L, SE.Node_To_Be_Wrapped); + end if; + + Analyze_List (L); + end if; + end Store_Before_Actions_In_Scope; + + -------------------------------- + -- Wrap_Transient_Declaration -- + -------------------------------- + + -- If a transient scope has been established during the processing of the + -- Expression of an Object_Declaration, it is not possible to wrap the + -- declaration into a transient block as usual case, otherwise the object + -- would be itself declared in the wrong scope. Therefore, all entities (if + -- any) defined in the transient block are moved to the proper enclosing + -- scope, furthermore, if they are controlled variables they are finalized + -- right after the declaration. The finalization list of the transient + -- scope is defined as a renaming of the enclosing one so during their + -- initialization they will be attached to the proper finalization + -- list. For instance, the following declaration : + + -- X : Typ := F (G (A), G (B)); + + -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2) + -- is expanded into : + + -- _local_final_list_1 : Finalizable_Ptr; + -- X : Typ := [ complex Expression-Action ]; + -- Finalize_One(_v1); + -- Finalize_One (_v2); + + procedure Wrap_Transient_Declaration (N : Node_Id) is + S : Entity_Id; + LC : Entity_Id := Empty; + Nodes : List_Id; + Loc : constant Source_Ptr := Sloc (N); + Enclosing_S : Entity_Id; + Uses_SS : Boolean; + Next_N : constant Node_Id := Next (N); + + begin + S := Current_Scope; + Enclosing_S := Scope (S); + + -- Insert Actions kept in the Scope stack + + Insert_Actions_In_Scope_Around (N); + + -- If the declaration is consuming some secondary stack, mark the + -- Enclosing scope appropriately. + + Uses_SS := Uses_Sec_Stack (S); + Pop_Scope; + + -- Create a List controller and rename the final list to be its + -- internal final pointer: + -- Lxxx : Simple_List_Controller; + -- Fxxx : Finalizable_Ptr renames Lxxx.F; + + if Present (Finalization_Chain_Entity (S)) then + LC := Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + + Nodes := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => LC, + Object_Definition => + New_Reference_To (RTE (RE_Simple_List_Controller), Loc)), + + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Finalization_Chain_Entity (S), + Subtype_Mark => New_Reference_To (RTE (RE_Finalizable_Ptr), Loc), + Name => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (LC, Loc), + Selector_Name => Make_Identifier (Loc, Name_F)))); + + -- Put the declaration at the beginning of the declaration part + -- to make sure it will be before all other actions that have been + -- inserted before N. + + Insert_List_Before_And_Analyze (First (List_Containing (N)), Nodes); + + -- Generate the Finalization calls by finalizing the list + -- controller right away. It will be re-finalized on scope + -- exit but it doesn't matter. It cannot be done when the + -- call initializes a renaming object though because in this + -- case, the object becomes a pointer to the temporary and thus + -- increases its life span. + + if Nkind (N) = N_Object_Renaming_Declaration + and then Controlled_Type (Etype (Defining_Identifier (N))) + then + null; + + else + Nodes := + Make_Final_Call ( + Ref => New_Reference_To (LC, Loc), + Typ => Etype (LC), + With_Detach => New_Reference_To (Standard_False, Loc)); + if Present (Next_N) then + Insert_List_Before_And_Analyze (Next_N, Nodes); + else + Append_List_To (List_Containing (N), Nodes); + end if; + end if; + end if; + + -- Put the local entities back in the enclosing scope, and set the + -- Is_Public flag appropriately. + + Transfer_Entities (S, Enclosing_S); + + -- Mark the enclosing dynamic scope so that the sec stack will be + -- released upon its exit unless this is a function that returns on + -- the sec stack in which case this will be done by the caller. + + if Uses_SS then + S := Enclosing_Dynamic_Scope (S); + + if Ekind (S) = E_Function + and then Requires_Transient_Scope (Etype (S)) + then + null; + else + Set_Uses_Sec_Stack (S); + Check_Restriction (No_Secondary_Stack, N); + end if; + end if; + end Wrap_Transient_Declaration; + + ------------------------------- + -- Wrap_Transient_Expression -- + ------------------------------- + + -- Insert actions before <Expression>: + + -- (lines marked with <CTRL> are expanded only in presence of Controlled + -- objects needing finalization) + + -- _E : Etyp; + -- declare + -- _M : constant Mark_Id := SS_Mark; + -- Local_Final_List : System.FI.Finalizable_Ptr; <CTRL> + + -- procedure _Clean is + -- begin + -- Abort_Defer; + -- System.FI.Finalize_List (Local_Final_List); <CTRL> + -- SS_Release (M); + -- Abort_Undefer; + -- end _Clean; + + -- begin + -- _E := <Expression>; + -- at end + -- _Clean; + -- end; + + -- then expression is replaced by _E + + procedure Wrap_Transient_Expression (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + E : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Etyp : constant Entity_Id := Etype (N); + + begin + Insert_Actions (N, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => E, + Object_Definition => New_Reference_To (Etyp, Loc)), + + Make_Transient_Block (Loc, + Action => + Make_Assignment_Statement (Loc, + Name => New_Reference_To (E, Loc), + Expression => Relocate_Node (N))))); + + Rewrite (N, New_Reference_To (E, Loc)); + Analyze_And_Resolve (N, Etyp); + end Wrap_Transient_Expression; + + ------------------------------ + -- Wrap_Transient_Statement -- + ------------------------------ + + -- Transform <Instruction> into + + -- (lines marked with <CTRL> are expanded only in presence of Controlled + -- objects needing finalization) + + -- declare + -- _M : Mark_Id := SS_Mark; + -- Local_Final_List : System.FI.Finalizable_Ptr ; <CTRL> + + -- procedure _Clean is + -- begin + -- Abort_Defer; + -- System.FI.Finalize_List (Local_Final_List); <CTRL> + -- SS_Release (_M); + -- Abort_Undefer; + -- end _Clean; + + -- begin + -- <Instr uction>; + -- at end + -- _Clean; + -- end; + + procedure Wrap_Transient_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + New_Statement : constant Node_Id := Relocate_Node (N); + + begin + Rewrite (N, Make_Transient_Block (Loc, New_Statement)); + + -- 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; |