Geek Gadgets 1

home *** CD-ROM | disk | FTP | other *** search

/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / exp_ch7.adb < prev next >

Wrap

Text File | 1996-09-28 | 67KB | 1,925 lines

----------------------------------------------------------------------------- -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 7 -- -- -- -- B o d y -- -- -- -- $Revision: 1.96 $ -- -- -- -- Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved -- -- -- -- 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, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- 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 Expander; use Expander; with Exp_Ch9; use Exp_Ch9; with Exp_TSS; use Exp_TSS; with Exp_Util; use Exp_Util; with Nlists; use Nlists; with Nmake; use Nmake; with Output; use Output; with Rtsfind; use Rtsfind; with Sinfo; use Sinfo; with Sem; use Sem; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Exp_Ch7 is --------------------------- -- Expand_N_Package_Body -- --------------------------- -- Add call to Activate_Tasks if body is an activator (actual -- processing is in chapter 9). procedure Expand_N_Package_Body (N : Node_Id) is begin if Ekind (Corresponding_Spec (N)) = E_Package then New_Scope (Corresponding_Spec (N)); Build_Task_Activation_Call (N); Pop_Scope; end if; end Expand_N_Package_Body; ---------------------------------- -- Expand_N_Package_Declaration -- ---------------------------------- -- Add call to Activate_Tasks if there are tasks declared and the -- package has no body. Note that in 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 Present (Activation_Chain_Entity (N)) then New_Scope (Defining_Unit_Simple_Name (Specification (N))); Build_Task_Activation_Call (N); Pop_Scope; end if; end Expand_N_Package_Declaration; -------------------------------------------------- -- 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 (Clean : Entity_Id; Mark : Entity_Id; Flist : Entity_Id; Is_Task : Boolean; Is_Master : Boolean) return Node_Id; -- Expand a the clean-up procedure for controlled and/or transient -- block, and/or task master or task body. 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_Scope_Is_Transient (V : Boolean := True); -- Set the flag Is_Transient of the current scope 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_Before (N : Node_Id); -- Insert the actions kept in the scope stack after N, which must -- be a member of a list. function Make_Transient_Block (Loc : Source_Ptr; Instruction : 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 instruction -- is Instruction. 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 Name_Id := (Initialize_Case => Name_uDeep_Initialize, Adjust_Case => Name_uDeep_Adjust, Finalize_Case => Name_uDeep_Finalize); procedure Build_Record_Deep_Procs (Typ : Entity_Id); -- Build the deep Initialize/Adjust/Finalize for a record Typ that -- Has_Controlled components 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 that -- Has_Controlled components 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. ----------------------------- -- Finalization Management -- ----------------------------- -- This part describe how Initialization/Adjusment/Finalization -- procedures are generated and called. 2 cases must be considered, type -- that are Controlled (Is_Controlled) and composite types that contain -- controlled components (Has_Controlled). 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 'HAS_Controlled' records a hidden 'controller' component is -- inserted. This controller component contains its own finalization -- list on which every 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 change 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 'HAS_Controlled' -- Arrays. So deep procedures are generated that call -- initialize/adjust/finalize + attachment or detachment on the -- finalization list for all component. -- Initizalize 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) the must not and in -- case (1) this is not important since we are exiting the scope -- anyway. -- 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; -- Initialize (X); -- Attach_To_Final_List (_L, Finalizable (X)); -- Y : Controlled := Init; -- Adjust (Y); -- Attach_To_Final_List (_L, Finalizable (Y)); -- -- type R is record -- _C : Record_Controller; -- C : Controlled; -- end record; -- W : R; -- Deep_Initialize (W, _L, True); -- Z : R := (C => X); -- Deep_Adjust (Z, _L, True); -- begin -- Finalize (X); -- X := Y; -- Adjust (X); -- Deep_Finalize (W, _L, False); -- W := Z; -- Deep_Adjust (W, _L, False); -- at end -- _Clean; -- end; ------------------------------------ -- In_Finalization_Implementation -- ------------------------------------ -- 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 acheive by such a test. function In_Finalization_Implementation (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_Implementation and then Scope (Scope (S)) = Standard_Standard; end In_Finalization_Implementation; --------------------- -- Controlled_Type -- --------------------- function Controlled_Type (T : Entity_Id) return Boolean is begin -- Class-wide types are considered controlled because they may contain -- an extension that has controlled components return (Is_Class_Wide_Type (T) and then not In_Finalization_Implementation (T)) or else Is_Controlled (T) or else Has_Controlled (T) or else (Is_Concurrent_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 := Typ; Comp : Entity_Id; 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; Comp := First_Entity (T); while Present (Comp) loop if Chars (Comp) = Name_uController then return Comp; end if; Comp := Next_Entity (Comp); end loop; -- If we fall through the loop, there is no controller component return Empty; end Controller_Component; ----------------------------- -- Build_Controlling_Procs -- ----------------------------- procedure Build_Controlling_Procs (Typ : Entity_Id) is begin if Is_Array_Type (Typ) then Build_Array_Deep_Procs (Typ); elsif Is_Record_Type (Typ) then Build_Record_Deep_Procs (Typ); else pragma Assert (False); null; end if; end Build_Controlling_Procs; -------------------- -- Make_Init_Call -- -------------------- function Make_Init_Call (Ref : Node_Id; Typ : Entity_Id; Flist_Ref : Node_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Ref); Res : constant List_Id := New_List; Proc : Entity_Id; Utyp : Entity_Id; Cref : Node_Id; begin if 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); -- Generate: -- Deep_Initialize (Ref, Flist_Ref); if Has_Controlled (Utyp) then Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case)); Append_To (Res, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (Proc, Loc), Parameter_Associations => New_List ( Node1 => Flist_Ref, Node2 => Cref, Node3 => New_Reference_To (Standard_True, Loc)))); -- Generate: -- Initialize (Ref); -- Attach_To_Final_List (Ref, Flist_Ref); else -- Is_Controlled (Utyp) Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case)); Append_To (Res, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (Proc, Loc), Parameter_Associations => New_List (Cref))); Append_To (Res, Make_Attach_Call (New_Copy_Tree (Cref), Flist_Ref)); end if; return Res; end Make_Init_Call; ----------------------- -- Make_Adjust_Call -- ----------------------- function Make_Adjust_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); Res : constant List_Id := New_List; Utyp : Entity_Id; Proc : Entity_Id; 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 (Ref); -- Generate: -- Deep_Adjust (Flist_Ref, Ref, With_Attach); if Has_Controlled (Utyp) or else Is_Class_Wide_Type (Typ) then if Is_Tagged_Type (Utyp) then Proc := Find_Prim_Op (Utyp, Deep_Name_Of (Adjust_Case)); else Proc := TSS (Utyp, Deep_Name_Of (Adjust_Case)); end if; Append_To (Res, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (Proc, Loc), Parameter_Associations => New_List (Flist_Ref, Ref, With_Attach))); -- Generate: -- Adjust (Ref); -- if With_Attach then -- Attach_To_Final_List (Ref, Flist_Ref); -- end if; else -- Is_Controlled (Utyp) Proc := Find_Prim_Op (Utyp, Name_Of (Adjust_Case)); Append_To (Res, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (Proc, Loc), Parameter_Associations => New_List (Ref))); if Chars (With_Attach) = Chars (Standard_True) then Append_To (Res, Make_Attach_Call (New_Copy_Tree (Ref), Flist_Ref)); elsif Chars (With_Attach) /= Chars (Standard_False) then Append_To (Res, Make_If_Statement (Loc, Condition => With_Attach, Then_Statements => New_List ( Make_Attach_Call (New_Copy_Tree (Ref), Flist_Ref)))); end if; end if; return Res; end Make_Adjust_Call; ---------------------- -- Make_Final_Call -- ---------------------- function Make_Final_Call (Ref : Node_Id; Typ : Entity_Id; Flist_Ref : Node_Id; With_Detach : Node_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Ref); Res : constant List_Id := New_List; Cref : Node_Id; Proc : Entity_Id; Utyp : Entity_Id; True_Case : Node_Id; False_Case : Node_Id; begin if Is_Class_Wide_Type (Typ) then Utyp := Underlying_Type (Base_Type (Root_Type (Typ))); Cref := Ref; elsif Is_Concurrent_Type (Typ) then Utyp := Underlying_Type (Base_Type (Corresponding_Record_Type (Typ))); Cref := Convert_Concurrent (Ref, Typ); else Utyp := Underlying_Type (Base_Type (Typ)); Cref := Ref; end if; Set_Assignment_OK (Ref); -- Generate: -- Deep_Finalize (Flist_Ref, Ref, With_Detach); if Has_Controlled (Utyp) or else Is_Class_Wide_Type (Typ) then if Is_Tagged_Type (Utyp) then Proc := Find_Prim_Op (Utyp, Deep_Name_Of (Finalize_Case)); else Proc := TSS (Utyp, Deep_Name_Of (Finalize_Case)); end if; Append_To (Res, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (Proc, Loc), Parameter_Associations => New_List (Flist_Ref, Cref, With_Detach))); -- Generate: -- if With_Detach then -- Finalize_One (Flist_Ref, Ref); -- else -- Finalize (Ref); -- end if; else True_Case := Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Finalize_One), Loc), Parameter_Associations => New_List ( Node1 => Flist_Ref, Node2 => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (RTE (RE_Finalizable), Loc), Expression => Ref))); False_Case := Make_Procedure_Call_Statement (Loc, Name => New_Reference_To ( Find_Prim_Op (Utyp, Name_Of (Finalize_Case)), Loc), Parameter_Associations => New_List (Ref)); if Chars (With_Detach) = Chars (Standard_True) then Append_To (Res, True_Case); elsif Chars (With_Detach) = Chars (Standard_False) then Append_To (Res, False_Case); else Append_To (Res, Make_If_Statement (Loc, Condition => With_Detach, Then_Statements => New_List (True_Case), Else_Statements => New_List (False_Case))); end if; end if; return Res; end Make_Final_Call; ------------------------------- -- Expand_Ctrl_Function_Call -- ------------------------------- -- Transform F(x) into: -- [_V : Finalizable_Ptr; -- _V := Finalizable_Ptr (F (x)'Ref); -- Attach_To_Final_List ("Final_List_Of_Current_Scope", _V.all); -- Type_Of_F!(_V.all)] procedure Expand_Ctrl_Function_Call (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Act : constant List_Id := New_List; Rtype : constant Entity_Id := Etype (N); Utype : constant Entity_Id := Underlying_Type (Rtype); V : Multi_Use.Exp_Id; Ref : Node_Id; begin Multi_Use.New_Exp_Id (N, Act, V); Ref := Multi_Use.New_Ref (V); if not Is_Record_Type (Utype) then return; end if; if Has_Controlled (Rtype) then if Rtype /= Utype then Ref := Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Utype, Loc), Expression => Ref); end if; Ref := Make_Selected_Component (Loc, Prefix => Ref, Selector_Name => Make_Identifier (Loc, Name_uController)); end if; if Has_Controlled (Rtype) or else Is_Controlled (Rtype) then Append_To (Act, Make_Attach_Call (Ref, Find_Final_List (Current_Scope))); else -- This is a class-wide type (potentially controlled) -- We cannot attach him since it may not have a Final pointer -- ??? for now do nothing. The proper fix is to pass the final -- chain to the called function as an implicit parameter null; end if; Rewrite_Substitute_Tree (N, Make_Expression_Actions (Loc, Actions => Act, Expression => Multi_Use.New_Ref (V))); Analyze (N); Resolve (N, Rtype); end Expand_Ctrl_Function_Call; --------------------- -- Make_Deep_Proc -- --------------------- -- Generate: -- procedure DEEP_<prim> -- (L : IN OUT Finalisable_Ptr; -- V : IN OUT <typ>; -- B : IN Boolean) 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; Subp_Body : Node_Id; begin 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)), 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)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_B), Parameter_Type => New_Reference_To (Standard_Boolean, 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_Statement (Loc, New_Reference_To (Standard_Program_Error, Loc))))); end if; Proc_Name := Make_Defining_Identifier (Loc, Deep_Name_Of (Prim)); Subp_Body := 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_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); L_Ref : constant Node_Id := Make_Identifier (Loc, Name_L); B_Ref : constant Node_Id := Make_Identifier (Loc, Name_B); begin case Prim is when Initialize_Case => return Make_Init_Call (Comp_Ref, Comp_Typ, L_Ref); when Adjust_Case => return Make_Adjust_Call (Comp_Ref, Comp_Typ, L_Ref, B_Ref); when Finalize_Case => return Make_Final_Call (Comp_Ref, Comp_Typ, L_Ref, B_Ref); 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_Loop_Statement (Loc, 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, UI_From_Int (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_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)); L_Ref : constant Node_Id := Make_Identifier (Loc, Name_L); B_Ref : constant Node_Id := Make_Identifier (Loc, Name_B); begin if Is_Limited_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 => declare Res : constant List_Id := New_List; begin Append_List_To (Res, Make_Init_Call (Controller_Ref, Controller_Typ, L_Ref)); -- When the type is also a controlled type by itself, -- Initialize it and attach it at the end of the internal -- 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 (New_Copy_Tree (Obj_Ref), Make_Selected_Component (Loc, Prefix => New_Copy_Tree (Controller_Ref), Selector_Name => Make_Identifier (Loc, Name_F)))); end if; return Res; end; when Adjust_Case => return Make_Adjust_Call (Controller_Ref, Controller_Typ, L_Ref, B_Ref); when Finalize_Case => return Make_Final_Call (Controller_Ref, Controller_Typ, L_Ref, B_Ref); end case; end Make_Deep_Record_Body; ---------------------------- -- Build_Array_Deep_Procs -- ---------------------------- procedure Build_Array_Deep_Procs (Typ : Entity_Id) is begin Set_TSS (Typ, Make_Deep_Proc ( Prim => Initialize_Case, Typ => Typ, Stmts => Make_Deep_Array_Body (Initialize_Case, Typ))); if not Is_Limited_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_Record_Deep_Procs -- ----------------------------- procedure Build_Record_Deep_Procs (Typ : Entity_Id) is begin Set_TSS (Typ, Make_Deep_Proc ( Prim => Initialize_Case, Typ => Typ, Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); if not Is_Limited_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; ---------------------- -- Make_Attach_Call -- ---------------------- -- Generate: -- System.FI.Attach_To_Final_List (Flist, Ref) function Make_Attach_Call (Obj_Ref, Flist_Ref : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Obj_Ref); begin return Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Attach_To_Final_List), Loc), Parameter_Associations => New_List ( Flist_Ref, Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (RTE (RE_Finalizable), Loc), Expression => Obj_Ref))); end Make_Attach_Call; ---------------------- -- Make_Detach_Call -- ---------------------- -- Generate: -- System.FI.Detach_From_Final_List (Flist, Ref) function Make_Detach_Call (Obj_Ref, Flist_Ref : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Obj_Ref); begin return Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Detach_From_Final_List), Loc), Parameter_Associations => New_List ( Flist_Ref, Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (RTE (RE_Finalizable), Loc), Expression => Obj_Ref))); end Make_Detach_Call; ---------------------- -- 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 => pragma Assert (False); null; 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) elsif Is_Access_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 S := Enclosing_Dynamic_Scope (E); 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; -------------------------------- -- 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, ...). In this case this expression -- is wrapped into an Expression_Action containing a transient block. -- (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 ------------------------------ -- Requires_Transient_Scope -- ------------------------------ -- A transient scope is required when temporaries are allocated in the -- primary or secondary stack, or when finalization actions must be -- generated before the next instruction function Requires_Transient_Scope (T : Entity_Id) return Boolean is Typ : Entity_Id := Underlying_Type (T); begin if No (Typ) then -- This is a private type which is not completed yet. This can only -- happen in a default expression (of a formal parameter or of a -- record component). Do not expand transient scope in this case return False; -- The back-end has trouble to allocate variable-size temporaries so -- we generate them in the front-end and need a transient scope to -- reclaim them properly elsif not Size_Known_At_Compile_Time (Typ) then return True; -- functions returning tagged types may dispatch on result so their -- returned value is allocated on the secondary stack. Controlled -- type temporaries need finalization. elsif Is_Tagged_Type (Typ) or else Has_Controlled (Typ) then return True; -- Unconstrained types are returned on the secondary stack elsif Is_Array_Type (Typ) then return not Is_Constrained (Typ); end if; return False; end Requires_Transient_Scope; ------------------------------- -- 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) is Loc : constant Source_Ptr := Sloc (N); Wrap_Node : Node_Id; begin -- Only create a new transient scope if the current one is not if not Scope_Is_Transient then 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; -- Transient scope is required else New_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B')); Set_Scope_Is_Transient; Set_Uses_Sec_Stack (Current_Scope); Set_Node_To_Be_Wrapped (Wrap_Node); if Debug_Flag_W then Write_Str (" <Transient>"); Write_Eol; end if; end if; end if; end Establish_Transient_Scope; ------------------------ -- 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; ------------------------ -- Scope_Is_Transient -- ------------------------ function Scope_Is_Transient return Boolean is begin return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; end Scope_Is_Transient; ---------------------------- -- Expand_Cleanup_Actions -- ---------------------------- procedure Expand_Cleanup_Actions (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); S : constant Entity_Id := Current_Scope; Flist : constant Entity_Id := Finalization_Chain_Entity (S); Is_Task : constant Boolean := (Nkind (N) = N_Task_Body); Is_Master : constant Boolean := Nkind (N) /= N_Entry_Body and then Is_Task_Master (N); Clean : Entity_Id; Mark : Entity_Id := Empty; New_Decls : List_Id := New_List; Blok : Node_Id; Wrapped : Boolean := False; begin -- There are cleanup actions only if the secondary stack needs -- releasing or some finalizations are needed or in the context of -- tasking if not Uses_Sec_Stack (Current_Scope) and then No (Flist) and then not Is_Master and then not Is_Task then return; end if; if No (Declarations (N)) then Set_Declarations (N, New_List); end if; Build_Task_Activation_Call (N); if Is_Master then Establish_Task_Master (N); end if; -- If secondary stack is in use, expand: -- _Mxx : constant Mark_Id := SS_Mark; if Uses_Sec_Stack (Current_Scope) 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); Append_To (New_Decls, Make_Clean (Clean, Mark, Flist, Is_Task, Is_Master)); -- 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 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))); Wrapped := True; 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 -- wierd 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 not Wrapped then Set_First_Real_Statement (Handled_Statement_Sequence (N), First (Statements (Handled_Statement_Sequence (N)))); 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)); -- ??? The actual mechanism of executing AT_END calls uses the -- setjmp/longjmp mechanism that destroys some of the data that -- could be uses by finalization actions. The proper fix is to -- execute all enclosing AT_END calls before longjumping to the next -- handler. This requires a new mechanism that is not in place -- yet. Meanwhile, a temporary kludge consists of generating a -- protection buffer that can be 'safely' garbled by the AT_END -- call. A very empirical test shows that a 64 byte buffer seems -- sufficient on all tested targets Protection_Buffer_Kludge : declare First_Node : constant Node_Id := First (Declarations (N)); Size_Obj : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S')); Buff_Obj : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('B')); begin -- Generates: -- Vxx : Integer := 64; -- Sxx : String (1 .. Vxx); Insert_List_Before_And_Analyze (First_Node, New_List ( Make_Object_Declaration (Loc, Defining_Identifier => Size_Obj, Object_Definition => New_Reference_To (Standard_Integer, Loc), Expression => Make_Integer_Literal (Loc, Intval => Uint_64)), Make_Object_Declaration (Loc, Defining_Identifier => Buff_Obj, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To (Standard_String, Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( Make_Range (Loc, Low_Bound => Make_Integer_Literal (Loc, Uint_1), High_Bound => New_Reference_To (Size_Obj, Loc)))))))); end Protection_Buffer_Kludge; -- 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 Set_Identifier (Handled_Statement_Sequence (N), New_Occurrence_Of (Clean, Loc)); end Expand_Cleanup_Actions; -------------------------------- -- 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 : -- 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; Ent : Entity_Id; Node : Node_Id; Loc : constant Source_Ptr := Sloc (N); Enclosing_S : Entity_Id; Uses_SS : Boolean; begin S := Current_Scope; Enclosing_S := Scope (S); -- Renaming declaration to point to the right finalization chain if Present (Finalization_Chain_Entity (S)) then Node := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Finalization_Chain_Entity (S), Subtype_Mark => New_Reference_To (RTE (RE_Finalizable_Ptr), Loc), Name => Find_Final_List (Enclosing_S)); -- Put the declaration at the beginning of the declaration part -- to make sur it will be before all other actions that have been -- inserted before N Insert_Before (First (List_Containing (N)), Node); Analyze (Node); end if; -- Insert Actions kept in the Scope stack Insert_Actions_In_Scope_Before (N); Ent := First_Entity (S); while Present (Ent) loop -- Generate the Finalization calls if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant) and then Is_Access_Type (Etype (Ent)) and then Controlled_Type (Designated_Type (Etype (Ent))) then Insert_List_After (N, Make_Final_Call ( Ref => Make_Explicit_Dereference (Loc, New_Reference_To (Ent, Loc)), Typ => Designated_Type (Etype (Ent)), Flist_Ref => Find_Final_List (Enclosing_S), With_Detach => New_Reference_To (Standard_True, Loc))); end if; Ent := Next_Entity (Ent); end loop; -- Expand the node before leaving the transient scope Set_Scope_Is_Transient (False); Expand (N); -- If the declaration is consuming some secondary stack, mark the -- Enclosing scope appropriately Uses_SS := Uses_Sec_Stack (Current_Scope); Pop_Scope; -- Put the local entities back in the enclosing scope, and set the -- Is_Public flag appropriately. Transfer_Entities (S, Enclosing_S); if Uses_SS then Set_Uses_Sec_Stack (Current_Scope); end if; end Wrap_Transient_Declaration; ------------------------------- -- Wrap_Transient_Expression -- ------------------------------- -- Transform <Expression> into -- (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; -- _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); New_Exp : constant Node_Id := Relocate_Node (N); begin Replace_Substitute_Tree (N, Make_Expression_Actions (Loc, Actions => New_List ( Make_Object_Declaration (Loc, Defining_Identifier => E, Object_Definition => New_Reference_To (Etyp, Loc)), Make_Transient_Block (Loc, Instruction => Make_Assignment_Statement (Loc, Name => New_Reference_To (E, Loc), Expression => New_Exp))), Expression => New_Reference_To (E, Loc))); -- Expand the node before leaving the transient scope Set_Scope_Is_Transient (False); Expand (New_Exp); Pop_Scope; Analyze (N); 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 -- <Instruction>; -- at end -- _Clean; -- end; procedure Wrap_Transient_Statement (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Block : Node_Id; New_Statement : constant Node_Id := Relocate_Node (N); begin Block := Make_Transient_Block (Loc, New_Statement); Replace_Substitute_Tree (N, Block); -- Expand the node before leaving the transient scope Set_Scope_Is_Transient (False); Expand (New_Statement); -- 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; -- 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; ---------------------------- -- Set_Scope_Is_Transient -- ---------------------------- procedure Set_Scope_Is_Transient (V : Boolean := True) is begin Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V; end Set_Scope_Is_Transient; ---------------------------- -- 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_Actions_In_Scope -- ---------------------------- procedure Store_Actions_In_Scope (L : List_Id) is SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); Acts : constant List_Id := SE.Actions_To_Be_Wrapped; begin if Present (SE.Actions_To_Be_Wrapped) then Insert_List_After_And_Analyze (Last (SE.Actions_To_Be_Wrapped), L); else SE.Actions_To_Be_Wrapped := L; Set_Parent (L, SE.Node_To_Be_Wrapped); Analyze_List (L); end if; end Store_Actions_In_Scope; ------------------------------------ -- Insert_Actions_In_Scope_Before -- ------------------------------------ procedure Insert_Actions_In_Scope_Before (N : Node_Id) is SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); begin if Present (SE.Actions_To_Be_Wrapped) then Insert_List_Before (N, SE.Actions_To_Be_Wrapped); SE.Actions_To_Be_Wrapped := No_List; end if; end Insert_Actions_In_Scope_Before; ----------------------------- -- 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 statements are ideal nodes to be wrapped when N_Assignment_Statement | N_Procedure_Call_Statement | N_Entry_Call_Statement => return The_Parent; -- 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; -- ??? No scheme yet for "for I in Expression'Range loop" -- ??? the current scheme for Expression wrapping doesn't apply -- ??? because a RANGE is NOT an expression. Tricky problem... -- ??? while this problem is no solved we have a potential for -- ??? leak and unfinalized intermediate objects here. when N_Loop_Parameter_Specification => return Empty; -- 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 expression of a 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 P; end if; -- If we leave a scope without having been able to find a node to -- wrap, something is going wrong when N_Subprogram_Body | N_Package_Declaration | N_Package_Body | N_Block_Statement => pragma Assert (False); null; -- otherwise continue the search when others => null; end case; end loop; end Find_Node_To_Be_Wrapped; -------------------------- -- Make_Transient_Block -- -------------------------- -- if finalization is involved, this function just wrap the instruction -- into a block whose name is the transient block entity, -- Expand_Cleanup_Actions (called on the expansion of the handled -- sequence of statements wil do the necessary expansions for -- cleanups). If it is just a matter of releasing the secondary stack -- we don't use the cleanup mechanism which is to costly but rather -- expand the release online, there is a potential of leak in the -- exceptional case but the sec-stack release mechanism will sooner or -- later catchup the leak. Here is the expansion for the latter case: -- declare -- _M : Mark_Id := SS_Mark; -- begin -- <Instruction>; -- SS_Release (M); -- end; function Make_Transient_Block (Loc : Source_Ptr; Instruction : Node_Id) return Node_Id is Flist : constant Entity_Id := Finalization_Chain_Entity (Current_Scope); Decls : constant List_Id := New_List; Instrs : constant List_Id := New_List (Instruction); Mark : Entity_Id := Empty; begin if Uses_Sec_Stack (Current_Scope) and then No (Flist) then Mark := Make_Defining_Identifier (Loc, Name_uM); Append_To (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)))); Append_To (Instrs, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_SS_Release), Loc), Parameter_Associations => New_List ( New_Reference_To (Mark, Loc)))); Set_Uses_Sec_Stack (Current_Scope, False); end if; Insert_Actions_In_Scope_Before (First (Instrs)); return 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); end Make_Transient_Block; ---------------- -- Make_Clean -- ---------------- function Make_Clean (Clean : Entity_Id; Mark : Entity_Id; Flist : Entity_Id; Is_Task : Boolean; Is_Master : Boolean) return Node_Id is Loc : constant Source_Ptr := Sloc (Clean); Stmt : List_Id := New_List; Sbody : Node_Id; begin if Is_Task then Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Task)); elsif Is_Master then Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Master)); 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; return Sbody; end Make_Clean; end Exp_Ch7;