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-2015, 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 For_Anonymous : Boolean := False; 103 For_Lib_Level : Boolean := False; 104 For_Private : Boolean := False; 105 Context_Scope : Entity_Id := Empty; 106 Insertion_Node : Node_Id := Empty); 107 -- Build a finalization master for an access type. The designated type may 108 -- not necessarely be controlled or need finalization actions depending on 109 -- the context. Flag For_Anonymous must be set when creating a master for 110 -- an anonymous access type. Flag For_Lib_Level must be set when creating 111 -- a master for a build-in-place function call access result type. Flag 112 -- For_Private must be set when the designated type contains a private 113 -- component. Parameters Context_Scope and Insertion_Node must be used in 114 -- conjunction with flags For_Anonymous and For_Private. Context_Scope is 115 -- the scope of the context where the finalization master must be analyzed. 116 -- Insertion_Node is the insertion point before which the master is to be 117 -- inserted. 118 119 procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id); 120 -- Build one controlling procedure when a late body overrides one of 121 -- the controlling operations. 122 123 procedure Build_Object_Declarations 124 (Data : out Finalization_Exception_Data; 125 Decls : List_Id; 126 Loc : Source_Ptr; 127 For_Package : Boolean := False); 128 -- Subsidiary to Make_Deep_Array_Body and Make_Deep_Record_Body. Create the 129 -- list List containing the object declarations of boolean flag Abort_Id, 130 -- the exception occurrence E_Id and boolean flag Raised_Id. 131 -- 132 -- Abort_Id : constant Boolean := 133 -- Exception_Identity (Get_Current_Excep.all) = 134 -- Standard'Abort_Signal'Identity; 135 -- <or> 136 -- Abort_Id : constant Boolean := False; -- no abort or For_Package 137 -- 138 -- E_Id : Exception_Occurrence; 139 -- Raised_Id : Boolean := False; 140 141 function Build_Raise_Statement 142 (Data : Finalization_Exception_Data) return Node_Id; 143 -- Subsidiary to routines Build_Finalizer, Make_Deep_Array_Body and Make_ 144 -- Deep_Record_Body. Generate the following conditional raise statement: 145 -- 146 -- if Raised_Id and then not Abort_Id then 147 -- Raise_From_Controlled_Operation (E_Id); 148 -- end if; 149 -- 150 -- Abort_Id is a local boolean flag which is set when the finalization was 151 -- triggered by an abort, E_Id denotes the defining identifier of a local 152 -- exception occurrence, Raised_Id is the entity of a local boolean flag. 153 154 function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean; 155 -- True if T is a class-wide type, or if it has controlled parts ("part" 156 -- means T or any of its subcomponents). Same as Needs_Finalization, except 157 -- when pragma Restrictions (No_Finalization) applies, in which case we 158 -- know that class-wide objects do not contain controlled parts. 159 160 function Has_New_Controlled_Component (E : Entity_Id) return Boolean; 161 -- E is a type entity. Give the same result as Has_Controlled_Component 162 -- except for tagged extensions where the result is True only if the 163 -- latest extension contains a controlled component. 164 165 function Make_Adjust_Call 166 (Obj_Ref : Node_Id; 167 Typ : Entity_Id; 168 Skip_Self : Boolean := False) return Node_Id; 169 -- Create a call to either Adjust or Deep_Adjust depending on the structure 170 -- of type Typ. Obj_Ref is an expression with no-side effect (not required 171 -- to have been previously analyzed) that references the object to be 172 -- adjusted. Typ is the expected type of Obj_Ref. When Skip_Self is set, 173 -- only the components (if any) are adjusted. 174 175 function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id; 176 -- Create a call to unhook an object from an arbitrary list. Obj_Ref is the 177 -- object. Generate the following: 178 -- 179 -- Ada.Finalization.Heap_Management.Detach 180 -- (System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref)); 181 182 function Make_Final_Call 183 (Obj_Ref : Node_Id; 184 Typ : Entity_Id; 185 Skip_Self : Boolean := False) return Node_Id; 186 -- Create a call to either Finalize or Deep_Finalize depending on the 187 -- structure of type Typ. Obj_Ref is an expression (with no-side effect 188 -- and is not required to have been previously analyzed) that references 189 -- the object to be finalized. Typ is the expected type of Obj_Ref. When 190 -- Skip_Self is set, only the components (if any) are finalized. 191 192 procedure Make_Finalize_Address_Body (Typ : Entity_Id); 193 -- Create the body of TSS routine Finalize_Address if Typ is controlled and 194 -- does not have a TSS entry for Finalize_Address. The procedure converts 195 -- an address into a pointer and subsequently calls Deep_Finalize on the 196 -- dereference. 197 198 function Make_Init_Call 199 (Obj_Ref : Node_Id; 200 Typ : Entity_Id) return Node_Id; 201 -- Obj_Ref is an expression with no-side effect (not required to have been 202 -- previously analyzed) that references the object to be initialized. Typ 203 -- is the expected type of Obj_Ref, which is either a controlled type 204 -- (Is_Controlled) or a type with controlled components (Has_Controlled_ 205 -- Components). 206 207 function Make_Handler_For_Ctrl_Operation (Loc : Source_Ptr) return Node_Id; 208 -- Generate an implicit exception handler with an 'others' choice, 209 -- converting any occurrence to a raise of Program_Error. 210 211 function Make_Local_Deep_Finalize 212 (Typ : Entity_Id; 213 Nam : Entity_Id) return Node_Id; 214 -- Create a special version of Deep_Finalize with identifier Nam. The 215 -- routine has state information and can perform partial finalization. 216 217 function Make_Set_Finalize_Address_Call 218 (Loc : Source_Ptr; 219 Ptr_Typ : Entity_Id) return Node_Id; 220 -- Associate the Finalize_Address primitive of the designated type with the 221 -- finalization master of access type Ptr_Typ. The returned call is: 222 -- 223 -- Set_Finalize_Address 224 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access); 225 226 -------------------------------------------- 227 -- Task and Protected Object finalization -- 228 -------------------------------------------- 229 230 function Cleanup_Array 231 (N : Node_Id; 232 Obj : Node_Id; 233 Typ : Entity_Id) return List_Id; 234 -- Generate loops to finalize any tasks or simple protected objects that 235 -- are subcomponents of an array. 236 237 function Cleanup_Protected_Object 238 (N : Node_Id; 239 Ref : Node_Id) return Node_Id; 240 -- Generate code to finalize a protected object without entries 241 242 function Cleanup_Record 243 (N : Node_Id; 244 Obj : Node_Id; 245 Typ : Entity_Id) return List_Id; 246 -- For each subcomponent of a record that contains tasks or simple 247 -- protected objects, generate the appropriate finalization call. 248 249 function Cleanup_Task 250 (N : Node_Id; 251 Ref : Node_Id) return Node_Id; 252 -- Generate code to finalize a task 253 254 function Has_Simple_Protected_Object (T : Entity_Id) return Boolean; 255 -- Check whether composite type contains a simple protected component 256 257 function Is_Simple_Protected_Type (T : Entity_Id) return Boolean; 258 -- Determine whether T denotes a protected type without entries whose 259 -- _object field is of type System.Tasking.Protected_Objects.Protection. 260 -- Something wrong here, implementation was changed to test Lock_Free 261 -- but this spec does not mention that ??? 262 263 -------------------------------- 264 -- Transient Scope Management -- 265 -------------------------------- 266 267 procedure Expand_Cleanup_Actions (N : Node_Id); 268 -- Expand the necessary stuff into a scope to enable finalization of local 269 -- objects and deallocation of transient data when exiting the scope. N is 270 -- a "scope node" that is to say one of the following: N_Block_Statement, 271 -- N_Subprogram_Body, N_Task_Body, N_Entry_Body. 272 273 procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean); 274 -- Push a new transient scope on the scope stack. N is the node responsible 275 -- for the need of a transient scope. If Sec_Stack is True then the 276 -- secondary stack is brought in, otherwise it isn't. 277 278 function Node_To_Be_Wrapped return Node_Id; 279 -- Return the node to be wrapped if the current scope is transient 280 281 procedure Store_Before_Actions_In_Scope (L : List_Id); 282 -- Append the list L of actions to the end of the before-actions store in 283 -- the top of the scope stack (also analyzes these actions). 284 285 procedure Store_After_Actions_In_Scope (L : List_Id); 286 -- Prepend the list L of actions to the beginning of the after-actions 287 -- stored in the top of the scope stack (also analyzes these actions). 288 -- 289 -- Note that we are prepending here rather than appending. This means that 290 -- if several calls are made to this procedure for the same scope, the 291 -- actions will be executed in reverse order of the calls (actions for the 292 -- last call executed first). Within the list L for a single call, the 293 -- actions are executed in the order in which they appear in this list. 294 295 procedure Store_Cleanup_Actions_In_Scope (L : List_Id); 296 -- Prepend the list L of actions to the beginning of the cleanup-actions 297 -- store in the top of the scope stack. 298 299 procedure Wrap_Transient_Declaration (N : Node_Id); 300 -- N is an object declaration. Expand the finalization calls after the 301 -- declaration and make the outer scope being the transient one. 302 303 procedure Wrap_Transient_Expression (N : Node_Id); 304 -- N is a sub-expression. Expand a transient block around an expression 305 306 procedure Wrap_Transient_Statement (N : Node_Id); 307 -- N is a statement. Expand a transient block around an instruction 308 309end Exp_Ch7; 310