1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ C H 7 -- 6-- -- 7-- S p e c -- 8-- -- 9-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Namet; use Namet; 27with Types; use Types; 28 29package Exp_Ch7 is 30 31 procedure Expand_N_Package_Body (N : Node_Id); 32 procedure Expand_N_Package_Declaration (N : Node_Id); 33 34 ----------------------------- 35 -- Finalization Management -- 36 ----------------------------- 37 38 procedure Build_Controlling_Procs (Typ : Entity_Id); 39 -- Typ is a record, and array type having controlled components. 40 -- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize 41 -- that take care of finalization management at run-time. 42 43 -- Support of exceptions from user finalization procedures 44 45 -- There is a specific mechanism to handle these exceptions, continue 46 -- finalization and then raise PE. This mechanism is used by this package 47 -- but also by exp_intr for Ada.Unchecked_Deallocation. 48 49 -- There are 3 subprograms to use this mechanism, and the type 50 -- Finalization_Exception_Data carries internal data between these 51 -- subprograms: 52 -- 53 -- 1. Build_Object_Declaration: create the variables for the next two 54 -- subprograms. 55 -- 2. Build_Exception_Handler: create the exception handler for a call 56 -- to a user finalization procedure. 57 -- 3. Build_Raise_Stmt: create code to potentially raise a PE exception 58 -- if an exception was raise in a user finalization procedure. 59 60 type Finalization_Exception_Data is record 61 Loc : Source_Ptr; 62 -- Sloc for the added nodes 63 64 Abort_Id : Entity_Id; 65 -- Boolean variable set to true if the finalization was triggered by 66 -- an abort. 67 68 E_Id : Entity_Id; 69 -- Variable containing the exception occurrence raised by user code 70 71 Raised_Id : Entity_Id; 72 -- Boolean variable set to true if an exception was raised in user code 73 end record; 74 75 function Build_Exception_Handler 76 (Data : Finalization_Exception_Data; 77 For_Library : Boolean := False) return Node_Id; 78 -- Subsidiary to Build_Finalizer, Make_Deep_Array_Body and Make_Deep_Record 79 -- _Body. Create an exception handler of the following form: 80 -- 81 -- when others => 82 -- if not Raised_Id then 83 -- Raised_Id := True; 84 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all); 85 -- end if; 86 -- 87 -- If flag For_Library is set (and not in restricted profile): 88 -- 89 -- when others => 90 -- if not Raised_Id then 91 -- Raised_Id := True; 92 -- Save_Library_Occurrence (Get_Current_Excep.all); 93 -- end if; 94 -- 95 -- E_Id denotes the defining identifier of a local exception occurrence. 96 -- Raised_Id is the entity of a local boolean flag. Flag For_Library is 97 -- used when operating at the library level, when enabled the current 98 -- exception will be saved to a global location. 99 100 procedure Build_Finalization_Master 101 (Typ : Entity_Id; 102 Ins_Node : Node_Id := Empty; 103 Encl_Scope : Entity_Id := Empty); 104 -- Build a finalization master for an access type. The designated type may 105 -- not necessarely be controlled or need finalization actions. The routine 106 -- creates a wrapper around a user-defined storage pool or the general 107 -- storage pool for access types. Ins_Nod and Encl_Scope are used in 108 -- conjunction with anonymous access types. Ins_Node designates the 109 -- insertion point before which the collection should be added. Encl_Scope 110 -- is the scope of the context, either the enclosing record or the scope 111 -- of the related function. 112 113 procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id); 114 -- Build one controlling procedure when a late body overrides one of 115 -- the controlling operations. 116 117 procedure Build_Object_Declarations 118 (Data : out Finalization_Exception_Data; 119 Decls : List_Id; 120 Loc : Source_Ptr; 121 For_Package : Boolean := False); 122 -- Subsidiary to Make_Deep_Array_Body and Make_Deep_Record_Body. Create the 123 -- list List containing the object declarations of boolean flag Abort_Id, 124 -- the exception occurrence E_Id and boolean flag Raised_Id. 125 -- 126 -- Abort_Id : constant Boolean := 127 -- Exception_Identity (Get_Current_Excep.all) = 128 -- Standard'Abort_Signal'Identity; 129 -- <or> 130 -- Abort_Id : constant Boolean := False; -- no abort or For_Package 131 -- 132 -- E_Id : Exception_Occurrence; 133 -- Raised_Id : Boolean := False; 134 135 function Build_Raise_Statement 136 (Data : Finalization_Exception_Data) return Node_Id; 137 -- Subsidiary to routines Build_Finalizer, Make_Deep_Array_Body and Make_ 138 -- Deep_Record_Body. Generate the following conditional raise statement: 139 -- 140 -- if Raised_Id and then not Abort_Id then 141 -- Raise_From_Controlled_Operation (E_Id); 142 -- end if; 143 -- 144 -- Abort_Id is a local boolean flag which is set when the finalization was 145 -- triggered by an abort, E_Id denotes the defining identifier of a local 146 -- exception occurrence, Raised_Id is the entity of a local boolean flag. 147 148 function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean; 149 -- True if T is a class-wide type, or if it has controlled parts ("part" 150 -- means T or any of its subcomponents). Same as Needs_Finalization, except 151 -- when pragma Restrictions (No_Finalization) applies, in which case we 152 -- know that class-wide objects do not contain controlled parts. 153 154 function Get_Global_Pool_For_Access_Type (T : Entity_Id) return Entity_Id; 155 -- Return the pool id for access type T. This is generally the node 156 -- corresponding to System.Global_Pool.Global_Pool_Object except on 157 -- VMS if the access size is 32. 158 159 function Has_New_Controlled_Component (E : Entity_Id) return Boolean; 160 -- E is a type entity. Give the same result as Has_Controlled_Component 161 -- except for tagged extensions where the result is True only if the 162 -- latest extension contains a controlled component. 163 164 function Make_Adjust_Call 165 (Obj_Ref : Node_Id; 166 Typ : Entity_Id; 167 For_Parent : Boolean := False) return Node_Id; 168 -- Create a call to either Adjust or Deep_Adjust depending on the structure 169 -- of type Typ. Obj_Ref is an expression with no-side effect (not required 170 -- to have been previously analyzed) that references the object to be 171 -- adjusted. Typ is the expected type of Obj_Ref. Flag For_Parent must be 172 -- set when an adjustment call is being created for field _parent. 173 174 function Make_Attach_Call 175 (Obj_Ref : Node_Id; 176 Ptr_Typ : Entity_Id) return Node_Id; 177 -- Create a call to prepend an object to a finalization collection. Obj_Ref 178 -- is the object, Ptr_Typ is the access type that owns the collection. This 179 -- is used only for .NET/JVM, that is, when VM_Target /= No_VM. 180 -- Generate the following: 181 -- 182 -- Ada.Finalization.Heap_Management.Attach 183 -- (<Ptr_Typ>FC, 184 -- System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref)); 185 186 function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id; 187 -- Create a call to unhook an object from an arbitrary list. Obj_Ref is the 188 -- object. Generate the following: 189 -- 190 -- Ada.Finalization.Heap_Management.Detach 191 -- (System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref)); 192 193 function Make_Final_Call 194 (Obj_Ref : Node_Id; 195 Typ : Entity_Id; 196 For_Parent : Boolean := False) return Node_Id; 197 -- Create a call to either Finalize or Deep_Finalize depending on the 198 -- structure of type Typ. Obj_Ref is an expression (with no-side effect and 199 -- is not required to have been previously analyzed) that references the 200 -- object to be finalized. Typ is the expected type of Obj_Ref. Flag For_ 201 -- Parent must be set when a finalization call is being created for field 202 -- _parent. 203 204 procedure Make_Finalize_Address_Body (Typ : Entity_Id); 205 -- Create the body of TSS routine Finalize_Address if Typ is controlled and 206 -- does not have a TSS entry for Finalize_Address. The procedure converts 207 -- an address into a pointer and subsequently calls Deep_Finalize on the 208 -- dereference. 209 210 function Make_Init_Call 211 (Obj_Ref : Node_Id; 212 Typ : Entity_Id) return Node_Id; 213 -- Obj_Ref is an expression with no-side effect (not required to have been 214 -- previously analyzed) that references the object to be initialized. Typ 215 -- is the expected type of Obj_Ref, which is either a controlled type 216 -- (Is_Controlled) or a type with controlled components (Has_Controlled_ 217 -- Components). 218 219 function Make_Handler_For_Ctrl_Operation (Loc : Source_Ptr) return Node_Id; 220 -- Generate an implicit exception handler with an 'others' choice, 221 -- converting any occurrence to a raise of Program_Error. 222 223 function Make_Local_Deep_Finalize 224 (Typ : Entity_Id; 225 Nam : Entity_Id) return Node_Id; 226 -- Create a special version of Deep_Finalize with identifier Nam. The 227 -- routine has state information and can parform partial finalization. 228 229 function Make_Set_Finalize_Address_Call 230 (Loc : Source_Ptr; 231 Typ : Entity_Id; 232 Ptr_Typ : Entity_Id) return Node_Id; 233 -- Generate the following call: 234 -- 235 -- Set_Finalize_Address (<Ptr_Typ>FM, <Typ>FD'Unrestricted_Access); 236 -- 237 -- where Finalize_Address is the corresponding TSS primitive of type Typ 238 -- and Ptr_Typ is the access type of the related allocation. Loc is the 239 -- source location of the related allocator. 240 241 -------------------------------------------- 242 -- Task and Protected Object finalization -- 243 -------------------------------------------- 244 245 function Cleanup_Array 246 (N : Node_Id; 247 Obj : Node_Id; 248 Typ : Entity_Id) return List_Id; 249 -- Generate loops to finalize any tasks or simple protected objects that 250 -- are subcomponents of an array. 251 252 function Cleanup_Protected_Object 253 (N : Node_Id; 254 Ref : Node_Id) return Node_Id; 255 -- Generate code to finalize a protected object without entries 256 257 function Cleanup_Record 258 (N : Node_Id; 259 Obj : Node_Id; 260 Typ : Entity_Id) return List_Id; 261 -- For each subcomponent of a record that contains tasks or simple 262 -- protected objects, generate the appropriate finalization call. 263 264 function Cleanup_Task 265 (N : Node_Id; 266 Ref : Node_Id) return Node_Id; 267 -- Generate code to finalize a task 268 269 function Has_Simple_Protected_Object (T : Entity_Id) return Boolean; 270 -- Check whether composite type contains a simple protected component 271 272 function Is_Simple_Protected_Type (T : Entity_Id) return Boolean; 273 -- Determine whether T denotes a protected type without entires whose 274 -- _object field is of type System.Tasking.Protected_Objects.Protection. 275 -- Something wrong here, implementation was changed to test Lock_Free 276 -- but this spec does not mention that ??? 277 278 -------------------------------- 279 -- Transient Scope Management -- 280 -------------------------------- 281 282 procedure Expand_Cleanup_Actions (N : Node_Id); 283 -- Expand the necessary stuff into a scope to enable finalization of local 284 -- objects and deallocation of transient data when exiting the scope. N is 285 -- a "scope node" that is to say one of the following: N_Block_Statement, 286 -- N_Subprogram_Body, N_Task_Body, N_Entry_Body. 287 288 procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean); 289 -- Push a new transient scope on the scope stack. N is the node responsible 290 -- for the need of a transient scope. If Sec_Stack is True then the 291 -- secondary stack is brought in, otherwise it isn't. 292 293 function Node_To_Be_Wrapped return Node_Id; 294 -- Return the node to be wrapped if the current scope is transient 295 296 procedure Store_Before_Actions_In_Scope (L : List_Id); 297 -- Append the list L of actions to the end of the before-actions store in 298 -- the top of the scope stack. 299 300 procedure Store_After_Actions_In_Scope (L : List_Id); 301 -- Append the list L of actions to the beginning of the after-actions store 302 -- in the top of the scope stack. 303 304 procedure Wrap_Transient_Declaration (N : Node_Id); 305 -- N is an object declaration. Expand the finalization calls after the 306 -- declaration and make the outer scope being the transient one. 307 308 procedure Wrap_Transient_Expression (N : Node_Id); 309 -- N is a sub-expression. Expand a transient block around an expression 310 311 procedure Wrap_Transient_Statement (N : Node_Id); 312 -- N is a statement. Expand a transient block around an instruction 313 314end Exp_Ch7; 315