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-2020, 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_Final_Call 179 (Obj_Ref : Node_Id; 180 Typ : Entity_Id; 181 Skip_Self : Boolean := False) return Node_Id; 182 -- Create a call to either Finalize or Deep_Finalize, depending on the 183 -- structure of type Typ. Obj_Ref is an expression (with no side effects 184 -- and is not required to have been previously analyzed) that references 185 -- the object to be finalized. Typ is the expected type of Obj_Ref. When 186 -- Skip_Self is set, only the components (if any) are finalized. Return 187 -- Empty if Finalize or Deep_Finalize is not available, possibly due to 188 -- previous errors. 189 190 procedure Make_Finalize_Address_Body (Typ : Entity_Id); 191 -- Create the body of TSS routine Finalize_Address if Typ is controlled and 192 -- does not have a TSS entry for Finalize_Address. The procedure converts 193 -- an address into a pointer and subsequently calls Deep_Finalize on the 194 -- dereference. 195 196 function Make_Init_Call 197 (Obj_Ref : Node_Id; 198 Typ : Entity_Id) return Node_Id; 199 -- Create a call to either Initialize or Deep_Initialize, depending on the 200 -- structure of type Typ. Obj_Ref is an expression with no side effects 201 -- (not required to have been previously analyzed) that references the 202 -- object to be initialized. Typ is the expected type of Obj_Ref. Return 203 -- Empty if Initialize or Deep_Initialize is not available, possibly due to 204 -- previous errors. 205 206 function Make_Handler_For_Ctrl_Operation (Loc : Source_Ptr) return Node_Id; 207 -- Generate an implicit exception handler with an 'others' choice, 208 -- converting any occurrence to a raise of Program_Error. 209 210 function Make_Local_Deep_Finalize 211 (Typ : Entity_Id; 212 Nam : Entity_Id) return Node_Id; 213 -- Create a special version of Deep_Finalize with identifier Nam. The 214 -- routine has state information and can perform partial finalization. 215 216 function Make_Set_Finalize_Address_Call 217 (Loc : Source_Ptr; 218 Ptr_Typ : Entity_Id) return Node_Id; 219 -- Associate the Finalize_Address primitive of the designated type with the 220 -- finalization master of access type Ptr_Typ. The returned call is: 221 -- 222 -- Set_Finalize_Address 223 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access); 224 225 -------------------------------------------- 226 -- Task and Protected Object finalization -- 227 -------------------------------------------- 228 229 function Cleanup_Array 230 (N : Node_Id; 231 Obj : Node_Id; 232 Typ : Entity_Id) return List_Id; 233 -- Generate loops to finalize any tasks or simple protected objects that 234 -- are subcomponents of an array. 235 236 function Cleanup_Protected_Object 237 (N : Node_Id; 238 Ref : Node_Id) return Node_Id; 239 -- Generate code to finalize a protected object without entries 240 241 function Cleanup_Record 242 (N : Node_Id; 243 Obj : Node_Id; 244 Typ : Entity_Id) return List_Id; 245 -- For each subcomponent of a record that contains tasks or simple 246 -- protected objects, generate the appropriate finalization call. 247 248 function Cleanup_Task 249 (N : Node_Id; 250 Ref : Node_Id) return Node_Id; 251 -- Generate code to finalize a task 252 253 function Has_Simple_Protected_Object (T : Entity_Id) return Boolean; 254 -- Check whether composite type contains a simple protected component 255 256 function Is_Simple_Protected_Type (T : Entity_Id) return Boolean; 257 -- Determine whether T denotes a protected type without entries whose 258 -- _object field is of type System.Tasking.Protected_Objects.Protection. 259 -- Something wrong here, implementation was changed to test Lock_Free 260 -- but this spec does not mention that ??? 261 262 -------------------------------- 263 -- Transient Scope Management -- 264 -------------------------------- 265 266 procedure Expand_Cleanup_Actions (N : Node_Id); 267 -- Expand the necessary stuff into a scope to enable finalization of local 268 -- objects and deallocation of transient data when exiting the scope. N is 269 -- a "scope node" that is to say one of the following: N_Block_Statement, 270 -- N_Subprogram_Body, N_Task_Body, N_Entry_Body. 271 272 procedure Establish_Transient_Scope 273 (N : Node_Id; 274 Manage_Sec_Stack : Boolean); 275 -- Push a new transient scope on the scope stack. N is the node which must 276 -- be serviced by the transient scope. Set Manage_Sec_Stack when the scope 277 -- must mark and release the secondary stack. 278 279 function Node_To_Be_Wrapped return Node_Id; 280 -- Return the node to be wrapped if the current scope is transient 281 282 procedure Store_Before_Actions_In_Scope (L : List_Id); 283 -- Append the list L of actions to the end of the before-actions store in 284 -- the top of the scope stack (also analyzes these actions). 285 286 procedure Store_After_Actions_In_Scope (L : List_Id); 287 -- Prepend the list L of actions to the beginning of the after-actions 288 -- stored in the top of the scope stack (also analyzes these actions). 289 -- 290 -- Note that we are prepending here rather than appending. This means that 291 -- if several calls are made to this procedure for the same scope, the 292 -- actions will be executed in reverse order of the calls (actions for the 293 -- last call executed first). Within the list L for a single call, the 294 -- actions are executed in the order in which they appear in this list. 295 296 procedure Store_Cleanup_Actions_In_Scope (L : List_Id); 297 -- Prepend the list L of actions to the beginning of the cleanup-actions 298 -- store in the top of the scope stack. 299 300 procedure Wrap_Transient_Declaration (N : Node_Id); 301 -- N is an object declaration. Expand the finalization calls after the 302 -- declaration and make the outer scope being the transient one. 303 304 procedure Wrap_Transient_Expression (N : Node_Id); 305 -- N is a sub-expression. Expand a transient block around an expression 306 307 procedure Wrap_Transient_Statement (N : Node_Id); 308 -- N is a statement. Expand a transient block around an instruction 309 310end Exp_Ch7; 311