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-2019, 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_Anonymous_Master (Ptr_Typ : Entity_Id); 39 -- Build a finalization master for an anonymous access-to-controlled type 40 -- denoted by Ptr_Typ. The master is inserted in the declarations of the 41 -- current unit. 42 43 procedure Build_Controlling_Procs (Typ : Entity_Id); 44 -- Typ is a record, and array type having controlled components. 45 -- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize 46 -- that take care of finalization management at run-time. 47 48 -- Support of exceptions from user finalization procedures 49 50 -- There is a specific mechanism to handle these exceptions, continue 51 -- finalization and then raise PE. This mechanism is used by this package 52 -- but also by exp_intr for Ada.Unchecked_Deallocation. 53 54 -- There are 3 subprograms to use this mechanism, and the type 55 -- Finalization_Exception_Data carries internal data between these 56 -- subprograms: 57 -- 58 -- 1. Build_Object_Declaration: create the variables for the next two 59 -- subprograms. 60 -- 2. Build_Exception_Handler: create the exception handler for a call 61 -- to a user finalization procedure. 62 -- 3. Build_Raise_Stmt: create code to potentially raise a PE exception 63 -- if an exception was raise in a user finalization procedure. 64 65 type Finalization_Exception_Data is record 66 Loc : Source_Ptr; 67 -- Sloc for the added nodes 68 69 Abort_Id : Entity_Id; 70 -- Boolean variable set to true if the finalization was triggered by 71 -- an abort. 72 73 E_Id : Entity_Id; 74 -- Variable containing the exception occurrence raised by user code 75 76 Raised_Id : Entity_Id; 77 -- Boolean variable set to true if an exception was raised in user code 78 end record; 79 80 function Build_Exception_Handler 81 (Data : Finalization_Exception_Data; 82 For_Library : Boolean := False) return Node_Id; 83 -- Subsidiary to Build_Finalizer, Make_Deep_Array_Body and Make_Deep_Record 84 -- _Body. Create an exception handler of the following form: 85 -- 86 -- when others => 87 -- if not Raised_Id then 88 -- Raised_Id := True; 89 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all); 90 -- end if; 91 -- 92 -- If flag For_Library is set (and not in restricted profile): 93 -- 94 -- when others => 95 -- if not Raised_Id then 96 -- Raised_Id := True; 97 -- Save_Library_Occurrence (Get_Current_Excep.all); 98 -- end if; 99 -- 100 -- E_Id denotes the defining identifier of a local exception occurrence. 101 -- Raised_Id is the entity of a local boolean flag. Flag For_Library is 102 -- used when operating at the library level, when enabled the current 103 -- exception will be saved to a global location. 104 105 procedure Build_Finalization_Master 106 (Typ : Entity_Id; 107 For_Lib_Level : Boolean := False; 108 For_Private : Boolean := False; 109 Context_Scope : Entity_Id := Empty; 110 Insertion_Node : Node_Id := Empty); 111 -- Build a finalization master for an access type. The designated type may 112 -- not necessarily be controlled or need finalization actions depending on 113 -- the context. Flag For_Lib_Level must be set when creating a master for a 114 -- build-in-place function call access result type. Flag For_Private must 115 -- be set when the designated type contains a private component. Parameters 116 -- Context_Scope and Insertion_Node must be used in conjunction with flag 117 -- For_Private. Context_Scope is the scope of the context where the 118 -- finalization master must be analyzed. Insertion_Node is the insertion 119 -- point before which the master is to be inserted. 120 121 procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id); 122 -- Build one controlling procedure when a late body overrides one of the 123 -- controlling operations. 124 125 procedure Build_Object_Declarations 126 (Data : out Finalization_Exception_Data; 127 Decls : List_Id; 128 Loc : Source_Ptr; 129 For_Package : Boolean := False); 130 -- Subsidiary to Make_Deep_Array_Body and Make_Deep_Record_Body. Create the 131 -- list List containing the object declarations of boolean flag Abort_Id, 132 -- the exception occurrence E_Id and boolean flag Raised_Id. 133 -- 134 -- Abort_Id : constant Boolean := 135 -- Exception_Identity (Get_Current_Excep.all) = 136 -- Standard'Abort_Signal'Identity; 137 -- <or> 138 -- Abort_Id : constant Boolean := False; -- no abort or For_Package 139 -- 140 -- E_Id : Exception_Occurrence; 141 -- Raised_Id : Boolean := False; 142 143 function Build_Raise_Statement 144 (Data : Finalization_Exception_Data) return Node_Id; 145 -- Subsidiary to routines Build_Finalizer, Make_Deep_Array_Body and Make_ 146 -- Deep_Record_Body. Generate the following conditional raise statement: 147 -- 148 -- if Raised_Id and then not Abort_Id then 149 -- Raise_From_Controlled_Operation (E_Id); 150 -- end if; 151 -- 152 -- Abort_Id is a local boolean flag which is set when the finalization was 153 -- triggered by an abort, E_Id denotes the defining identifier of a local 154 -- exception occurrence, Raised_Id is the entity of a local boolean flag. 155 156 function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean; 157 -- True if T is a class-wide type, or if it has controlled parts ("part" 158 -- means T or any of its subcomponents). Same as Needs_Finalization, except 159 -- when pragma Restrictions (No_Finalization) applies, in which case we 160 -- know that class-wide objects do not contain controlled parts. 161 162 function Has_New_Controlled_Component (E : Entity_Id) return Boolean; 163 -- E is a type entity. Give the same result as Has_Controlled_Component 164 -- except for tagged extensions where the result is True only if the 165 -- latest extension contains a controlled component. 166 167 function Make_Adjust_Call 168 (Obj_Ref : Node_Id; 169 Typ : Entity_Id; 170 Skip_Self : Boolean := False) return Node_Id; 171 -- Create a call to either Adjust or Deep_Adjust depending on the structure 172 -- of type Typ. Obj_Ref is an expression with no side effects (not required 173 -- to have been previously analyzed) that references the object to be 174 -- adjusted. Typ is the expected type of Obj_Ref. When Skip_Self is set, 175 -- only the components (if any) are adjusted. Return Empty if Adjust or 176 -- Deep_Adjust is not available, possibly due to previous errors. 177 178 function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id; 179 -- Create a call to unhook an object from an arbitrary list. Obj_Ref is the 180 -- object. Generate the following: 181 -- 182 -- Ada.Finalization.Heap_Management.Detach 183 -- (System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref)); 184 185 function Make_Final_Call 186 (Obj_Ref : Node_Id; 187 Typ : Entity_Id; 188 Skip_Self : Boolean := False) return Node_Id; 189 -- Create a call to either Finalize or Deep_Finalize, depending on the 190 -- structure of type Typ. Obj_Ref is an expression (with no side effects 191 -- and is not required to have been previously analyzed) that references 192 -- the object to be finalized. Typ is the expected type of Obj_Ref. When 193 -- Skip_Self is set, only the components (if any) are finalized. Return 194 -- Empty if Finalize or Deep_Finalize is not available, possibly due to 195 -- previous errors. 196 197 procedure Make_Finalize_Address_Body (Typ : Entity_Id); 198 -- Create the body of TSS routine Finalize_Address if Typ is controlled and 199 -- does not have a TSS entry for Finalize_Address. The procedure converts 200 -- an address into a pointer and subsequently calls Deep_Finalize on the 201 -- dereference. 202 203 function Make_Init_Call 204 (Obj_Ref : Node_Id; 205 Typ : Entity_Id) return Node_Id; 206 -- Create a call to either Initialize or Deep_Initialize, depending on the 207 -- structure of type Typ. Obj_Ref is an expression with no side effects 208 -- (not required to have been previously analyzed) that references the 209 -- object to be initialized. Typ is the expected type of Obj_Ref. Return 210 -- Empty if Initialize or Deep_Initialize is not available, possibly due to 211 -- previous errors. 212 213 function Make_Handler_For_Ctrl_Operation (Loc : Source_Ptr) return Node_Id; 214 -- Generate an implicit exception handler with an 'others' choice, 215 -- converting any occurrence to a raise of Program_Error. 216 217 function Make_Local_Deep_Finalize 218 (Typ : Entity_Id; 219 Nam : Entity_Id) return Node_Id; 220 -- Create a special version of Deep_Finalize with identifier Nam. The 221 -- routine has state information and can perform partial finalization. 222 223 function Make_Set_Finalize_Address_Call 224 (Loc : Source_Ptr; 225 Ptr_Typ : Entity_Id) return Node_Id; 226 -- Associate the Finalize_Address primitive of the designated type with the 227 -- finalization master of access type Ptr_Typ. The returned call is: 228 -- 229 -- Set_Finalize_Address 230 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access); 231 232 -------------------------------------------- 233 -- Task and Protected Object finalization -- 234 -------------------------------------------- 235 236 function Cleanup_Array 237 (N : Node_Id; 238 Obj : Node_Id; 239 Typ : Entity_Id) return List_Id; 240 -- Generate loops to finalize any tasks or simple protected objects that 241 -- are subcomponents of an array. 242 243 function Cleanup_Protected_Object 244 (N : Node_Id; 245 Ref : Node_Id) return Node_Id; 246 -- Generate code to finalize a protected object without entries 247 248 function Cleanup_Record 249 (N : Node_Id; 250 Obj : Node_Id; 251 Typ : Entity_Id) return List_Id; 252 -- For each subcomponent of a record that contains tasks or simple 253 -- protected objects, generate the appropriate finalization call. 254 255 function Cleanup_Task 256 (N : Node_Id; 257 Ref : Node_Id) return Node_Id; 258 -- Generate code to finalize a task 259 260 function Has_Simple_Protected_Object (T : Entity_Id) return Boolean; 261 -- Check whether composite type contains a simple protected component 262 263 function Is_Simple_Protected_Type (T : Entity_Id) return Boolean; 264 -- Determine whether T denotes a protected type without entries whose 265 -- _object field is of type System.Tasking.Protected_Objects.Protection. 266 -- Something wrong here, implementation was changed to test Lock_Free 267 -- but this spec does not mention that ??? 268 269 -------------------------------- 270 -- Transient Scope Management -- 271 -------------------------------- 272 273 procedure Expand_Cleanup_Actions (N : Node_Id); 274 -- Expand the necessary stuff into a scope to enable finalization of local 275 -- objects and deallocation of transient data when exiting the scope. N is 276 -- a "scope node" that is to say one of the following: N_Block_Statement, 277 -- N_Subprogram_Body, N_Task_Body, N_Entry_Body. 278 279 procedure Establish_Transient_Scope 280 (N : Node_Id; 281 Manage_Sec_Stack : Boolean); 282 -- Push a new transient scope on the scope stack. N is the node which must 283 -- be serviced by the transient scope. Set Manage_Sec_Stack when the scope 284 -- must mark and release the secondary stack. 285 286 function Node_To_Be_Wrapped return Node_Id; 287 -- Return the node to be wrapped if the current scope is transient 288 289 procedure Store_Before_Actions_In_Scope (L : List_Id); 290 -- Append the list L of actions to the end of the before-actions store in 291 -- the top of the scope stack (also analyzes these actions). 292 293 procedure Store_After_Actions_In_Scope (L : List_Id); 294 -- Prepend the list L of actions to the beginning of the after-actions 295 -- stored in the top of the scope stack (also analyzes these actions). 296 -- 297 -- Note that we are prepending here rather than appending. This means that 298 -- if several calls are made to this procedure for the same scope, the 299 -- actions will be executed in reverse order of the calls (actions for the 300 -- last call executed first). Within the list L for a single call, the 301 -- actions are executed in the order in which they appear in this list. 302 303 procedure Store_Cleanup_Actions_In_Scope (L : List_Id); 304 -- Prepend the list L of actions to the beginning of the cleanup-actions 305 -- store in the top of the scope stack. 306 307 procedure Wrap_Transient_Declaration (N : Node_Id); 308 -- N is an object declaration. Expand the finalization calls after the 309 -- declaration and make the outer scope being the transient one. 310 311 procedure Wrap_Transient_Expression (N : Node_Id); 312 -- N is a sub-expression. Expand a transient block around an expression 313 314 procedure Wrap_Transient_Statement (N : Node_Id); 315 -- N is a statement. Expand a transient block around an instruction 316 317end Exp_Ch7; 318