1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ C H 7 -- 6-- -- 7-- B o d y -- 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 26-- This package contains virtually all expansion mechanisms related to 27-- - controlled types 28-- - transient scopes 29 30with Atree; use Atree; 31with Contracts; use Contracts; 32with Debug; use Debug; 33with Einfo; use Einfo; 34with Elists; use Elists; 35with Errout; use Errout; 36with Exp_Ch6; use Exp_Ch6; 37with Exp_Ch9; use Exp_Ch9; 38with Exp_Ch11; use Exp_Ch11; 39with Exp_Dbug; use Exp_Dbug; 40with Exp_Dist; use Exp_Dist; 41with Exp_Disp; use Exp_Disp; 42with Exp_Prag; use Exp_Prag; 43with Exp_Tss; use Exp_Tss; 44with Exp_Util; use Exp_Util; 45with Freeze; use Freeze; 46with Lib; use Lib; 47with Nlists; use Nlists; 48with Nmake; use Nmake; 49with Opt; use Opt; 50with Output; use Output; 51with Restrict; use Restrict; 52with Rident; use Rident; 53with Rtsfind; use Rtsfind; 54with Sinfo; use Sinfo; 55with Sem; use Sem; 56with Sem_Aux; use Sem_Aux; 57with Sem_Ch3; use Sem_Ch3; 58with Sem_Ch7; use Sem_Ch7; 59with Sem_Ch8; use Sem_Ch8; 60with Sem_Res; use Sem_Res; 61with Sem_Util; use Sem_Util; 62with Snames; use Snames; 63with Stand; use Stand; 64with Tbuild; use Tbuild; 65with Ttypes; use Ttypes; 66with Uintp; use Uintp; 67 68package body Exp_Ch7 is 69 70 -------------------------------- 71 -- Transient Scope Management -- 72 -------------------------------- 73 74 -- A transient scope is created when temporary objects are created by the 75 -- compiler. These temporary objects are allocated on the secondary stack 76 -- and the transient scope is responsible for finalizing the object when 77 -- appropriate and reclaiming the memory at the right time. The temporary 78 -- objects are generally the objects allocated to store the result of a 79 -- function returning an unconstrained or a tagged value. Expressions 80 -- needing to be wrapped in a transient scope (functions calls returning 81 -- unconstrained or tagged values) may appear in 3 different contexts which 82 -- lead to 3 different kinds of transient scope expansion: 83 84 -- 1. In a simple statement (procedure call, assignment, ...). In this 85 -- case the instruction is wrapped into a transient block. See 86 -- Wrap_Transient_Statement for details. 87 88 -- 2. In an expression of a control structure (test in a IF statement, 89 -- expression in a CASE statement, ...). See Wrap_Transient_Expression 90 -- for details. 91 92 -- 3. In a expression of an object_declaration. No wrapping is possible 93 -- here, so the finalization actions, if any, are done right after the 94 -- declaration and the secondary stack deallocation is done in the 95 -- proper enclosing scope. See Wrap_Transient_Declaration for details. 96 97 -- Note about functions returning tagged types: it has been decided to 98 -- always allocate their result in the secondary stack, even though is not 99 -- absolutely mandatory when the tagged type is constrained because the 100 -- caller knows the size of the returned object and thus could allocate the 101 -- result in the primary stack. An exception to this is when the function 102 -- builds its result in place, as is done for functions with inherently 103 -- limited result types for Ada 2005. In that case, certain callers may 104 -- pass the address of a constrained object as the target object for the 105 -- function result. 106 107 -- By allocating tagged results in the secondary stack a number of 108 -- implementation difficulties are avoided: 109 110 -- - If it is a dispatching function call, the computation of the size of 111 -- the result is possible but complex from the outside. 112 113 -- - If the returned type is controlled, the assignment of the returned 114 -- value to the anonymous object involves an Adjust, and we have no 115 -- easy way to access the anonymous object created by the back end. 116 117 -- - If the returned type is class-wide, this is an unconstrained type 118 -- anyway. 119 120 -- Furthermore, the small loss in efficiency which is the result of this 121 -- decision is not such a big deal because functions returning tagged types 122 -- are not as common in practice compared to functions returning access to 123 -- a tagged type. 124 125 -------------------------------------------------- 126 -- Transient Blocks and Finalization Management -- 127 -------------------------------------------------- 128 129 function Find_Transient_Context (N : Node_Id) return Node_Id; 130 -- Locate a suitable context for arbitrary node N which may need to be 131 -- serviced by a transient scope. Return Empty if no suitable context is 132 -- available. 133 134 procedure Insert_Actions_In_Scope_Around 135 (N : Node_Id; 136 Clean : Boolean; 137 Manage_SS : Boolean); 138 -- Insert the before-actions kept in the scope stack before N, and the 139 -- after-actions after N, which must be a member of a list. If flag Clean 140 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert 141 -- calls to mark and release the secondary stack. 142 143 function Make_Transient_Block 144 (Loc : Source_Ptr; 145 Action : Node_Id; 146 Par : Node_Id) return Node_Id; 147 -- Action is a single statement or object declaration. Par is the proper 148 -- parent of the generated block. Create a transient block whose name is 149 -- the current scope and the only handled statement is Action. If Action 150 -- involves controlled objects or secondary stack usage, the corresponding 151 -- cleanup actions are performed at the end of the block. 152 153 procedure Set_Node_To_Be_Wrapped (N : Node_Id); 154 -- Set the field Node_To_Be_Wrapped of the current scope 155 156 -- ??? The entire comment needs to be rewritten 157 -- ??? which entire comment? 158 159 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id); 160 -- Shared processing for Store_xxx_Actions_In_Scope 161 162 ----------------------------- 163 -- Finalization Management -- 164 ----------------------------- 165 166 -- This part describe how Initialization/Adjustment/Finalization procedures 167 -- are generated and called. Two cases must be considered, types that are 168 -- Controlled (Is_Controlled flag set) and composite types that contain 169 -- controlled components (Has_Controlled_Component flag set). In the first 170 -- case the procedures to call are the user-defined primitive operations 171 -- Initialize/Adjust/Finalize. In the second case, GNAT generates 172 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge 173 -- of calling the former procedures on the controlled components. 174 175 -- For records with Has_Controlled_Component set, a hidden "controller" 176 -- component is inserted. This controller component contains its own 177 -- finalization list on which all controlled components are attached 178 -- creating an indirection on the upper-level Finalization list. This 179 -- technique facilitates the management of objects whose number of 180 -- controlled components changes during execution. This controller 181 -- component is itself controlled and is attached to the upper-level 182 -- finalization chain. Its adjust primitive is in charge of calling adjust 183 -- on the components and adjusting the finalization pointer to match their 184 -- new location (see a-finali.adb). 185 186 -- It is not possible to use a similar technique for arrays that have 187 -- Has_Controlled_Component set. In this case, deep procedures are 188 -- generated that call initialize/adjust/finalize + attachment or 189 -- detachment on the finalization list for all component. 190 191 -- Initialize calls: they are generated for declarations or dynamic 192 -- allocations of Controlled objects with no initial value. They are always 193 -- followed by an attachment to the current Finalization Chain. For the 194 -- dynamic allocation case this the chain attached to the scope of the 195 -- access type definition otherwise, this is the chain of the current 196 -- scope. 197 198 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations 199 -- or dynamic allocations of Controlled objects with an initial value. 200 -- (2) after an assignment. In the first case they are followed by an 201 -- attachment to the final chain, in the second case they are not. 202 203 -- Finalization Calls: They are generated on (1) scope exit, (2) 204 -- assignments, (3) unchecked deallocations. In case (3) they have to 205 -- be detached from the final chain, in case (2) they must not and in 206 -- case (1) this is not important since we are exiting the scope anyway. 207 208 -- Other details: 209 210 -- Type extensions will have a new record controller at each derivation 211 -- level containing controlled components. The record controller for 212 -- the parent/ancestor is attached to the finalization list of the 213 -- extension's record controller (i.e. the parent is like a component 214 -- of the extension). 215 216 -- For types that are both Is_Controlled and Has_Controlled_Components, 217 -- the record controller and the object itself are handled separately. 218 -- It could seem simpler to attach the object at the end of its record 219 -- controller but this would not tackle view conversions properly. 220 221 -- A classwide type can always potentially have controlled components 222 -- but the record controller of the corresponding actual type may not 223 -- be known at compile time so the dispatch table contains a special 224 -- field that allows computation of the offset of the record controller 225 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset. 226 227 -- Here is a simple example of the expansion of a controlled block : 228 229 -- declare 230 -- X : Controlled; 231 -- Y : Controlled := Init; 232 -- 233 -- type R is record 234 -- C : Controlled; 235 -- end record; 236 -- W : R; 237 -- Z : R := (C => X); 238 239 -- begin 240 -- X := Y; 241 -- W := Z; 242 -- end; 243 -- 244 -- is expanded into 245 -- 246 -- declare 247 -- _L : System.FI.Finalizable_Ptr; 248 249 -- procedure _Clean is 250 -- begin 251 -- Abort_Defer; 252 -- System.FI.Finalize_List (_L); 253 -- Abort_Undefer; 254 -- end _Clean; 255 256 -- X : Controlled; 257 -- begin 258 -- Abort_Defer; 259 -- Initialize (X); 260 -- Attach_To_Final_List (_L, Finalizable (X), 1); 261 -- at end: Abort_Undefer; 262 -- Y : Controlled := Init; 263 -- Adjust (Y); 264 -- Attach_To_Final_List (_L, Finalizable (Y), 1); 265 -- 266 -- type R is record 267 -- C : Controlled; 268 -- end record; 269 -- W : R; 270 -- begin 271 -- Abort_Defer; 272 -- Deep_Initialize (W, _L, 1); 273 -- at end: Abort_Under; 274 -- Z : R := (C => X); 275 -- Deep_Adjust (Z, _L, 1); 276 277 -- begin 278 -- _Assign (X, Y); 279 -- Deep_Finalize (W, False); 280 -- <save W's final pointers> 281 -- W := Z; 282 -- <restore W's final pointers> 283 -- Deep_Adjust (W, _L, 0); 284 -- at end 285 -- _Clean; 286 -- end; 287 288 type Final_Primitives is 289 (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case); 290 -- This enumeration type is defined in order to ease sharing code for 291 -- building finalization procedures for composite types. 292 293 Name_Of : constant array (Final_Primitives) of Name_Id := 294 (Initialize_Case => Name_Initialize, 295 Adjust_Case => Name_Adjust, 296 Finalize_Case => Name_Finalize, 297 Address_Case => Name_Finalize_Address); 298 Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type := 299 (Initialize_Case => TSS_Deep_Initialize, 300 Adjust_Case => TSS_Deep_Adjust, 301 Finalize_Case => TSS_Deep_Finalize, 302 Address_Case => TSS_Finalize_Address); 303 304 function Allows_Finalization_Master (Typ : Entity_Id) return Boolean; 305 -- Determine whether access type Typ may have a finalization master 306 307 procedure Build_Array_Deep_Procs (Typ : Entity_Id); 308 -- Build the deep Initialize/Adjust/Finalize for a record Typ with 309 -- Has_Controlled_Component set and store them using the TSS mechanism. 310 311 function Build_Cleanup_Statements 312 (N : Node_Id; 313 Additional_Cleanup : List_Id) return List_Id; 314 -- Create the cleanup calls for an asynchronous call block, task master, 315 -- protected subprogram body, task allocation block or task body, or 316 -- additional cleanup actions parked on a transient block. If the context 317 -- does not contain the above constructs, the routine returns an empty 318 -- list. 319 320 procedure Build_Finalizer 321 (N : Node_Id; 322 Clean_Stmts : List_Id; 323 Mark_Id : Entity_Id; 324 Top_Decls : List_Id; 325 Defer_Abort : Boolean; 326 Fin_Id : out Entity_Id); 327 -- N may denote an accept statement, block, entry body, package body, 328 -- package spec, protected body, subprogram body, or a task body. Create 329 -- a procedure which contains finalization calls for all controlled objects 330 -- declared in the declarative or statement region of N. The calls are 331 -- built in reverse order relative to the original declarations. In the 332 -- case of a task body, the routine delays the creation of the finalizer 333 -- until all statements have been moved to the task body procedure. 334 -- Clean_Stmts may contain additional context-dependent code used to abort 335 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements). 336 -- Mark_Id is the secondary stack used in the current context or Empty if 337 -- missing. Top_Decls is the list on which the declaration of the finalizer 338 -- is attached in the non-package case. Defer_Abort indicates that the 339 -- statements passed in perform actions that require abort to be deferred, 340 -- such as for task termination. Fin_Id is the finalizer declaration 341 -- entity. 342 343 procedure Build_Finalizer_Helper 344 (N : Node_Id; 345 Clean_Stmts : List_Id; 346 Mark_Id : Entity_Id; 347 Top_Decls : List_Id; 348 Defer_Abort : Boolean; 349 Fin_Id : out Entity_Id; 350 Finalize_Old_Only : Boolean); 351 -- An internal routine which does all of the heavy lifting on behalf of 352 -- Build_Finalizer. 353 354 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id); 355 -- N is a construct which contains a handled sequence of statements, Fin_Id 356 -- is the entity of a finalizer. Create an At_End handler which covers the 357 -- statements of N and calls Fin_Id. If the handled statement sequence has 358 -- an exception handler, the statements will be wrapped in a block to avoid 359 -- unwanted interaction with the new At_End handler. 360 361 procedure Build_Record_Deep_Procs (Typ : Entity_Id); 362 -- Build the deep Initialize/Adjust/Finalize for a record Typ with 363 -- Has_Component_Component set and store them using the TSS mechanism. 364 365 ------------------------------------------- 366 -- Unnesting procedures for CCG and LLVM -- 367 ------------------------------------------- 368 369 -- Expansion generates subprograms for controlled types management that 370 -- may appear in declarative lists in package declarations and bodies. 371 -- These subprograms appear within generated blocks that contain local 372 -- declarations and a call to finalization procedures. To ensure that 373 -- such subprograms get activation records when needed, we transform the 374 -- block into a procedure body, followed by a call to it in the same 375 -- declarative list. 376 377 procedure Check_Unnesting_Elaboration_Code (N : Node_Id); 378 -- The statement part of a package body that is a compilation unit may 379 -- contain blocks that declare local subprograms. In Subprogram_Unnesting_ 380 -- Mode such subprograms must be handled as nested inside the (implicit) 381 -- elaboration procedure that executes that statement part. To handle 382 -- properly uplevel references we construct that subprogram explicitly, 383 -- to contain blocks and inner subprograms, the statement part becomes 384 -- a call to this subprogram. This is only done if blocks are present 385 -- in the statement list of the body. (It would be nice to unify this 386 -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since 387 -- they're doing very similar work, but are structured differently. ???) 388 389 procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id); 390 -- Similarly, the declarations or statements in library-level packages may 391 -- have created blocks with nested subprograms. Such a block must be 392 -- transformed into a procedure followed by a call to it, so that unnesting 393 -- can handle uplevel references within these nested subprograms (typically 394 -- subprograms that handle finalization actions). This also applies to 395 -- nested packages, including instantiations, in which case it must 396 -- recursively process inner bodies. 397 398 procedure Check_Unnesting_In_Handlers (N : Node_Id); 399 -- Similarly, check for blocks with nested subprograms occurring within 400 -- a set of exception handlers associated with a package body N. 401 402 procedure Unnest_Block (Decl : Node_Id); 403 -- Blocks that contain nested subprograms with up-level references need to 404 -- create activation records for them. We do this by rewriting the block as 405 -- a procedure, followed by a call to it in the same declarative list, to 406 -- replicate the semantics of the original block. 407 -- 408 -- A common source for such block is a transient block created for a 409 -- construct (declaration, assignment, etc.) that involves controlled 410 -- actions or secondary-stack management, in which case the nested 411 -- subprogram is a finalizer. 412 413 procedure Unnest_If_Statement (If_Stmt : Node_Id); 414 -- The separate statement lists associated with an if-statement (then part, 415 -- elsif parts, else part) may require unnesting if they directly contain 416 -- a subprogram body that references up-level objects. Each statement list 417 -- is traversed to locate such subprogram bodies, and if a part's statement 418 -- list contains a body, then the list is replaced with a new procedure 419 -- containing the part's statements followed by a call to the procedure. 420 -- Furthermore, any nested blocks, loops, or if statements will also be 421 -- traversed to determine the need for further unnesting transformations. 422 423 procedure Unnest_Statement_List (Stmts : in out List_Id); 424 -- A list of statements that directly contains a subprogram at its outer 425 -- level, that may reference objects declared in that same statement list, 426 -- is rewritten as a procedure containing the statement list Stmts (which 427 -- includes any such objects as well as the nested subprogram), followed by 428 -- a call to the new procedure, and Stmts becomes the list containing the 429 -- procedure and the call. This ensures that Unnest_Subprogram will later 430 -- properly handle up-level references from the nested subprogram to 431 -- objects declared earlier in statement list, by creating an activation 432 -- record and passing it to the nested subprogram. This procedure also 433 -- resets the Scope of objects declared in the statement list, as well as 434 -- the Scope of the nested subprogram, to refer to the new procedure. 435 -- Also, the new procedure is marked Has_Nested_Subprogram, so this should 436 -- only be called when known that the statement list contains a subprogram. 437 438 procedure Unnest_Loop (Loop_Stmt : Node_Id); 439 -- Top-level Loops that contain nested subprograms with up-level references 440 -- need to have activation records. We do this by rewriting the loop as a 441 -- procedure containing the loop, followed by a call to the procedure in 442 -- the same library-level declarative list, to replicate the semantics of 443 -- the original loop. Such loops can occur due to aggregate expansions and 444 -- other constructs. 445 446 procedure Check_Visibly_Controlled 447 (Prim : Final_Primitives; 448 Typ : Entity_Id; 449 E : in out Entity_Id; 450 Cref : in out Node_Id); 451 -- The controlled operation declared for a derived type may not be 452 -- overriding, if the controlled operations of the parent type are hidden, 453 -- for example when the parent is a private type whose full view is 454 -- controlled. For other primitive operations we modify the name of the 455 -- operation to indicate that it is not overriding, but this is not 456 -- possible for Initialize, etc. because they have to be retrievable by 457 -- name. Before generating the proper call to one of these operations we 458 -- check whether Typ is known to be controlled at the point of definition. 459 -- If it is not then we must retrieve the hidden operation of the parent 460 -- and use it instead. This is one case that might be solved more cleanly 461 -- once Overriding pragmas or declarations are in place. 462 463 function Contains_Subprogram (Blk : Entity_Id) return Boolean; 464 -- Check recursively whether a loop or block contains a subprogram that 465 -- may need an activation record. 466 467 function Convert_View 468 (Proc : Entity_Id; 469 Arg : Node_Id; 470 Ind : Pos := 1) return Node_Id; 471 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the 472 -- argument being passed to it. Ind indicates which formal of procedure 473 -- Proc we are trying to match. This function will, if necessary, generate 474 -- a conversion between the partial and full view of Arg to match the type 475 -- of the formal of Proc, or force a conversion to the class-wide type in 476 -- the case where the operation is abstract. 477 478 function Enclosing_Function (E : Entity_Id) return Entity_Id; 479 -- Given an arbitrary entity, traverse the scope chain looking for the 480 -- first enclosing function. Return Empty if no function was found. 481 482 function Make_Call 483 (Loc : Source_Ptr; 484 Proc_Id : Entity_Id; 485 Param : Node_Id; 486 Skip_Self : Boolean := False) return Node_Id; 487 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of 488 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create 489 -- an adjust or finalization call. Wnen flag Skip_Self is set, the related 490 -- action has an effect on the components only (if any). 491 492 function Make_Deep_Proc 493 (Prim : Final_Primitives; 494 Typ : Entity_Id; 495 Stmts : List_Id) return Node_Id; 496 -- This function generates the tree for Deep_Initialize, Deep_Adjust or 497 -- Deep_Finalize procedures according to the first parameter, these 498 -- procedures operate on the type Typ. The Stmts parameter gives the body 499 -- of the procedure. 500 501 function Make_Deep_Array_Body 502 (Prim : Final_Primitives; 503 Typ : Entity_Id) return List_Id; 504 -- This function generates the list of statements for implementing 505 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to 506 -- the first parameter, these procedures operate on the array type Typ. 507 508 function Make_Deep_Record_Body 509 (Prim : Final_Primitives; 510 Typ : Entity_Id; 511 Is_Local : Boolean := False) return List_Id; 512 -- This function generates the list of statements for implementing 513 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to 514 -- the first parameter, these procedures operate on the record type Typ. 515 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate 516 -- whether the inner logic should be dictated by state counters. 517 518 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id; 519 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and 520 -- Make_Deep_Record_Body. Generate the following statements: 521 -- 522 -- declare 523 -- type Acc_Typ is access all Typ; 524 -- for Acc_Typ'Storage_Size use 0; 525 -- begin 526 -- [Deep_]Finalize (Acc_Typ (V).all); 527 -- end; 528 529 -------------------------------- 530 -- Allows_Finalization_Master -- 531 -------------------------------- 532 533 function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is 534 function In_Deallocation_Instance (E : Entity_Id) return Boolean; 535 -- Determine whether entity E is inside a wrapper package created for 536 -- an instance of Ada.Unchecked_Deallocation. 537 538 ------------------------------ 539 -- In_Deallocation_Instance -- 540 ------------------------------ 541 542 function In_Deallocation_Instance (E : Entity_Id) return Boolean is 543 Pkg : constant Entity_Id := Scope (E); 544 Par : Node_Id := Empty; 545 546 begin 547 if Ekind (Pkg) = E_Package 548 and then Present (Related_Instance (Pkg)) 549 and then Ekind (Related_Instance (Pkg)) = E_Procedure 550 then 551 Par := Generic_Parent (Parent (Related_Instance (Pkg))); 552 553 return 554 Present (Par) 555 and then Chars (Par) = Name_Unchecked_Deallocation 556 and then Chars (Scope (Par)) = Name_Ada 557 and then Scope (Scope (Par)) = Standard_Standard; 558 end if; 559 560 return False; 561 end In_Deallocation_Instance; 562 563 -- Local variables 564 565 Desig_Typ : constant Entity_Id := Designated_Type (Typ); 566 Ptr_Typ : constant Entity_Id := 567 Root_Type_Of_Full_View (Base_Type (Typ)); 568 569 -- Start of processing for Allows_Finalization_Master 570 571 begin 572 -- Certain run-time configurations and targets do not provide support 573 -- for controlled types and therefore do not need masters. 574 575 if Restriction_Active (No_Finalization) then 576 return False; 577 578 -- Do not consider C and C++ types since it is assumed that the non-Ada 579 -- side will handle their cleanup. 580 581 elsif Convention (Desig_Typ) = Convention_C 582 or else Convention (Desig_Typ) = Convention_CPP 583 then 584 return False; 585 586 -- Do not consider an access type that returns on the secondary stack 587 588 elsif Present (Associated_Storage_Pool (Ptr_Typ)) 589 and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool) 590 then 591 return False; 592 593 -- Do not consider an access type that can never allocate an object 594 595 elsif No_Pool_Assigned (Ptr_Typ) then 596 return False; 597 598 -- Do not consider an access type coming from an Unchecked_Deallocation 599 -- instance. Even though the designated type may be controlled, the 600 -- access type will never participate in any allocations. 601 602 elsif In_Deallocation_Instance (Ptr_Typ) then 603 return False; 604 605 -- Do not consider a non-library access type when No_Nested_Finalization 606 -- is in effect since finalization masters are controlled objects and if 607 -- created will violate the restriction. 608 609 elsif Restriction_Active (No_Nested_Finalization) 610 and then not Is_Library_Level_Entity (Ptr_Typ) 611 then 612 return False; 613 614 -- Do not consider an access type subject to pragma No_Heap_Finalization 615 -- because objects allocated through such a type are not to be finalized 616 -- when the access type goes out of scope. 617 618 elsif No_Heap_Finalization (Ptr_Typ) then 619 return False; 620 621 -- Do not create finalization masters in GNATprove mode because this 622 -- causes unwanted extra expansion. A compilation in this mode must 623 -- keep the tree as close as possible to the original sources. 624 625 elsif GNATprove_Mode then 626 return False; 627 628 -- Otherwise the access type may use a finalization master 629 630 else 631 return True; 632 end if; 633 end Allows_Finalization_Master; 634 635 ---------------------------- 636 -- Build_Anonymous_Master -- 637 ---------------------------- 638 639 procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is 640 function Create_Anonymous_Master 641 (Desig_Typ : Entity_Id; 642 Unit_Id : Entity_Id; 643 Unit_Decl : Node_Id) return Entity_Id; 644 -- Create a new anonymous master for access type Ptr_Typ with designated 645 -- type Desig_Typ. The declaration of the master and its initialization 646 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is 647 -- the entity of Unit_Decl. 648 649 function Current_Anonymous_Master 650 (Desig_Typ : Entity_Id; 651 Unit_Id : Entity_Id) return Entity_Id; 652 -- Find an anonymous master declared within unit Unit_Id which services 653 -- designated type Desig_Typ. If there is no such master, return Empty. 654 655 ----------------------------- 656 -- Create_Anonymous_Master -- 657 ----------------------------- 658 659 function Create_Anonymous_Master 660 (Desig_Typ : Entity_Id; 661 Unit_Id : Entity_Id; 662 Unit_Decl : Node_Id) return Entity_Id 663 is 664 Loc : constant Source_Ptr := Sloc (Unit_Id); 665 666 All_FMs : Elist_Id; 667 Decls : List_Id; 668 FM_Decl : Node_Id; 669 FM_Id : Entity_Id; 670 FM_Init : Node_Id; 671 Unit_Spec : Node_Id; 672 673 begin 674 -- Generate: 675 -- <FM_Id> : Finalization_Master; 676 677 FM_Id := Make_Temporary (Loc, 'A'); 678 679 FM_Decl := 680 Make_Object_Declaration (Loc, 681 Defining_Identifier => FM_Id, 682 Object_Definition => 683 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)); 684 685 -- Generate: 686 -- Set_Base_Pool 687 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access); 688 689 FM_Init := 690 Make_Procedure_Call_Statement (Loc, 691 Name => 692 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), 693 Parameter_Associations => New_List ( 694 New_Occurrence_Of (FM_Id, Loc), 695 Make_Attribute_Reference (Loc, 696 Prefix => 697 New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc), 698 Attribute_Name => Name_Unrestricted_Access))); 699 700 -- Find the declarative list of the unit 701 702 if Nkind (Unit_Decl) = N_Package_Declaration then 703 Unit_Spec := Specification (Unit_Decl); 704 Decls := Visible_Declarations (Unit_Spec); 705 706 if No (Decls) then 707 Decls := New_List; 708 Set_Visible_Declarations (Unit_Spec, Decls); 709 end if; 710 711 -- Package body or subprogram case 712 713 -- ??? A subprogram spec or body that acts as a compilation unit may 714 -- contain a formal parameter of an anonymous access-to-controlled 715 -- type initialized by an allocator. 716 717 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl); 718 719 -- There is no suitable place to create the master as the subprogram 720 -- is not in a declarative list. 721 722 else 723 Decls := Declarations (Unit_Decl); 724 725 if No (Decls) then 726 Decls := New_List; 727 Set_Declarations (Unit_Decl, Decls); 728 end if; 729 end if; 730 731 Prepend_To (Decls, FM_Init); 732 Prepend_To (Decls, FM_Decl); 733 734 -- Use the scope of the unit when analyzing the declaration of the 735 -- master and its initialization actions. 736 737 Push_Scope (Unit_Id); 738 Analyze (FM_Decl); 739 Analyze (FM_Init); 740 Pop_Scope; 741 742 -- Mark the master as servicing this specific designated type 743 744 Set_Anonymous_Designated_Type (FM_Id, Desig_Typ); 745 746 -- Include the anonymous master in the list of existing masters which 747 -- appear in this unit. This effectively creates a mapping between a 748 -- master and a designated type which in turn allows for the reuse of 749 -- masters on a per-unit basis. 750 751 All_FMs := Anonymous_Masters (Unit_Id); 752 753 if No (All_FMs) then 754 All_FMs := New_Elmt_List; 755 Set_Anonymous_Masters (Unit_Id, All_FMs); 756 end if; 757 758 Prepend_Elmt (FM_Id, All_FMs); 759 760 return FM_Id; 761 end Create_Anonymous_Master; 762 763 ------------------------------ 764 -- Current_Anonymous_Master -- 765 ------------------------------ 766 767 function Current_Anonymous_Master 768 (Desig_Typ : Entity_Id; 769 Unit_Id : Entity_Id) return Entity_Id 770 is 771 All_FMs : constant Elist_Id := Anonymous_Masters (Unit_Id); 772 FM_Elmt : Elmt_Id; 773 FM_Id : Entity_Id; 774 775 begin 776 -- Inspect the list of anonymous masters declared within the unit 777 -- looking for an existing master which services the same designated 778 -- type. 779 780 if Present (All_FMs) then 781 FM_Elmt := First_Elmt (All_FMs); 782 while Present (FM_Elmt) loop 783 FM_Id := Node (FM_Elmt); 784 785 -- The currect master services the same designated type. As a 786 -- result the master can be reused and associated with another 787 -- anonymous access-to-controlled type. 788 789 if Anonymous_Designated_Type (FM_Id) = Desig_Typ then 790 return FM_Id; 791 end if; 792 793 Next_Elmt (FM_Elmt); 794 end loop; 795 end if; 796 797 return Empty; 798 end Current_Anonymous_Master; 799 800 -- Local variables 801 802 Desig_Typ : Entity_Id; 803 FM_Id : Entity_Id; 804 Priv_View : Entity_Id; 805 Unit_Decl : Node_Id; 806 Unit_Id : Entity_Id; 807 808 -- Start of processing for Build_Anonymous_Master 809 810 begin 811 -- Nothing to do if the circumstances do not allow for a finalization 812 -- master. 813 814 if not Allows_Finalization_Master (Ptr_Typ) then 815 return; 816 end if; 817 818 Unit_Decl := Unit (Cunit (Current_Sem_Unit)); 819 Unit_Id := Unique_Defining_Entity (Unit_Decl); 820 821 -- The compilation unit is a package instantiation. In this case the 822 -- anonymous master is associated with the package spec as both the 823 -- spec and body appear at the same level. 824 825 if Nkind (Unit_Decl) = N_Package_Body 826 and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation 827 then 828 Unit_Id := Corresponding_Spec (Unit_Decl); 829 Unit_Decl := Unit_Declaration_Node (Unit_Id); 830 end if; 831 832 -- Use the initial declaration of the designated type when it denotes 833 -- the full view of an incomplete or private type. This ensures that 834 -- types with one and two views are treated the same. 835 836 Desig_Typ := Directly_Designated_Type (Ptr_Typ); 837 Priv_View := Incomplete_Or_Partial_View (Desig_Typ); 838 839 if Present (Priv_View) then 840 Desig_Typ := Priv_View; 841 end if; 842 843 -- Determine whether the current semantic unit already has an anonymous 844 -- master which services the designated type. 845 846 FM_Id := Current_Anonymous_Master (Desig_Typ, Unit_Id); 847 848 -- If this is not the case, create a new master 849 850 if No (FM_Id) then 851 FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl); 852 end if; 853 854 Set_Finalization_Master (Ptr_Typ, FM_Id); 855 end Build_Anonymous_Master; 856 857 ---------------------------- 858 -- Build_Array_Deep_Procs -- 859 ---------------------------- 860 861 procedure Build_Array_Deep_Procs (Typ : Entity_Id) is 862 begin 863 Set_TSS (Typ, 864 Make_Deep_Proc 865 (Prim => Initialize_Case, 866 Typ => Typ, 867 Stmts => Make_Deep_Array_Body (Initialize_Case, Typ))); 868 869 if not Is_Limited_View (Typ) then 870 Set_TSS (Typ, 871 Make_Deep_Proc 872 (Prim => Adjust_Case, 873 Typ => Typ, 874 Stmts => Make_Deep_Array_Body (Adjust_Case, Typ))); 875 end if; 876 877 -- Do not generate Deep_Finalize and Finalize_Address if finalization is 878 -- suppressed since these routine will not be used. 879 880 if not Restriction_Active (No_Finalization) then 881 Set_TSS (Typ, 882 Make_Deep_Proc 883 (Prim => Finalize_Case, 884 Typ => Typ, 885 Stmts => Make_Deep_Array_Body (Finalize_Case, Typ))); 886 887 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode) 888 889 if not CodePeer_Mode then 890 Set_TSS (Typ, 891 Make_Deep_Proc 892 (Prim => Address_Case, 893 Typ => Typ, 894 Stmts => Make_Deep_Array_Body (Address_Case, Typ))); 895 end if; 896 end if; 897 end Build_Array_Deep_Procs; 898 899 ------------------------------ 900 -- Build_Cleanup_Statements -- 901 ------------------------------ 902 903 function Build_Cleanup_Statements 904 (N : Node_Id; 905 Additional_Cleanup : List_Id) return List_Id 906 is 907 Is_Asynchronous_Call : constant Boolean := 908 Nkind (N) = N_Block_Statement 909 and then Is_Asynchronous_Call_Block (N); 910 Is_Master : constant Boolean := 911 Nkind (N) /= N_Entry_Body 912 and then Is_Task_Master (N); 913 Is_Protected_Body : constant Boolean := 914 Nkind (N) = N_Subprogram_Body 915 and then Is_Protected_Subprogram_Body (N); 916 Is_Task_Allocation : constant Boolean := 917 Nkind (N) = N_Block_Statement 918 and then Is_Task_Allocation_Block (N); 919 Is_Task_Body : constant Boolean := 920 Nkind (Original_Node (N)) = N_Task_Body; 921 922 Loc : constant Source_Ptr := Sloc (N); 923 Stmts : constant List_Id := New_List; 924 925 begin 926 if Is_Task_Body then 927 if Restricted_Profile then 928 Append_To (Stmts, 929 Build_Runtime_Call (Loc, RE_Complete_Restricted_Task)); 930 else 931 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task)); 932 end if; 933 934 elsif Is_Master then 935 if Restriction_Active (No_Task_Hierarchy) = False then 936 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master)); 937 end if; 938 939 -- Add statements to unlock the protected object parameter and to 940 -- undefer abort. If the context is a protected procedure and the object 941 -- has entries, call the entry service routine. 942 943 -- NOTE: The generated code references _object, a parameter to the 944 -- procedure. 945 946 elsif Is_Protected_Body then 947 declare 948 Spec : constant Node_Id := Parent (Corresponding_Spec (N)); 949 Conc_Typ : Entity_Id := Empty; 950 Param : Node_Id; 951 Param_Typ : Entity_Id; 952 953 begin 954 -- Find the _object parameter representing the protected object 955 956 Param := First (Parameter_Specifications (Spec)); 957 loop 958 Param_Typ := Etype (Parameter_Type (Param)); 959 960 if Ekind (Param_Typ) = E_Record_Type then 961 Conc_Typ := Corresponding_Concurrent_Type (Param_Typ); 962 end if; 963 964 exit when No (Param) or else Present (Conc_Typ); 965 Next (Param); 966 end loop; 967 968 pragma Assert (Present (Param)); 969 pragma Assert (Present (Conc_Typ)); 970 971 -- Historical note: In earlier versions of GNAT, there was code 972 -- at this point to generate stuff to service entry queues. It is 973 -- now abstracted in Build_Protected_Subprogram_Call_Cleanup. 974 975 Build_Protected_Subprogram_Call_Cleanup 976 (Specification (N), Conc_Typ, Loc, Stmts); 977 end; 978 979 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated 980 -- tasks. Other unactivated tasks are completed by Complete_Task or 981 -- Complete_Master. 982 983 -- NOTE: The generated code references _chain, a local object 984 985 elsif Is_Task_Allocation then 986 987 -- Generate: 988 -- Expunge_Unactivated_Tasks (_chain); 989 990 -- where _chain is the list of tasks created by the allocator but not 991 -- yet activated. This list will be empty unless the block completes 992 -- abnormally. 993 994 Append_To (Stmts, 995 Make_Procedure_Call_Statement (Loc, 996 Name => 997 New_Occurrence_Of 998 (RTE (RE_Expunge_Unactivated_Tasks), Loc), 999 Parameter_Associations => New_List ( 1000 New_Occurrence_Of (Activation_Chain_Entity (N), Loc)))); 1001 1002 -- Attempt to cancel an asynchronous entry call whenever the block which 1003 -- contains the abortable part is exited. 1004 1005 -- NOTE: The generated code references Cnn, a local object 1006 1007 elsif Is_Asynchronous_Call then 1008 declare 1009 Cancel_Param : constant Entity_Id := 1010 Entry_Cancel_Parameter (Entity (Identifier (N))); 1011 1012 begin 1013 -- If it is of type Communication_Block, this must be a protected 1014 -- entry call. Generate: 1015 1016 -- if Enqueued (Cancel_Param) then 1017 -- Cancel_Protected_Entry_Call (Cancel_Param); 1018 -- end if; 1019 1020 if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then 1021 Append_To (Stmts, 1022 Make_If_Statement (Loc, 1023 Condition => 1024 Make_Function_Call (Loc, 1025 Name => 1026 New_Occurrence_Of (RTE (RE_Enqueued), Loc), 1027 Parameter_Associations => New_List ( 1028 New_Occurrence_Of (Cancel_Param, Loc))), 1029 1030 Then_Statements => New_List ( 1031 Make_Procedure_Call_Statement (Loc, 1032 Name => 1033 New_Occurrence_Of 1034 (RTE (RE_Cancel_Protected_Entry_Call), Loc), 1035 Parameter_Associations => New_List ( 1036 New_Occurrence_Of (Cancel_Param, Loc)))))); 1037 1038 -- Asynchronous delay, generate: 1039 -- Cancel_Async_Delay (Cancel_Param); 1040 1041 elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then 1042 Append_To (Stmts, 1043 Make_Procedure_Call_Statement (Loc, 1044 Name => 1045 New_Occurrence_Of (RTE (RE_Cancel_Async_Delay), Loc), 1046 Parameter_Associations => New_List ( 1047 Make_Attribute_Reference (Loc, 1048 Prefix => 1049 New_Occurrence_Of (Cancel_Param, Loc), 1050 Attribute_Name => Name_Unchecked_Access)))); 1051 1052 -- Task entry call, generate: 1053 -- Cancel_Task_Entry_Call (Cancel_Param); 1054 1055 else 1056 Append_To (Stmts, 1057 Make_Procedure_Call_Statement (Loc, 1058 Name => 1059 New_Occurrence_Of (RTE (RE_Cancel_Task_Entry_Call), Loc), 1060 Parameter_Associations => New_List ( 1061 New_Occurrence_Of (Cancel_Param, Loc)))); 1062 end if; 1063 end; 1064 end if; 1065 1066 Append_List_To (Stmts, Additional_Cleanup); 1067 return Stmts; 1068 end Build_Cleanup_Statements; 1069 1070 ----------------------------- 1071 -- Build_Controlling_Procs -- 1072 ----------------------------- 1073 1074 procedure Build_Controlling_Procs (Typ : Entity_Id) is 1075 begin 1076 if Is_Array_Type (Typ) then 1077 Build_Array_Deep_Procs (Typ); 1078 else pragma Assert (Is_Record_Type (Typ)); 1079 Build_Record_Deep_Procs (Typ); 1080 end if; 1081 end Build_Controlling_Procs; 1082 1083 ----------------------------- 1084 -- Build_Exception_Handler -- 1085 ----------------------------- 1086 1087 function Build_Exception_Handler 1088 (Data : Finalization_Exception_Data; 1089 For_Library : Boolean := False) return Node_Id 1090 is 1091 Actuals : List_Id; 1092 Proc_To_Call : Entity_Id; 1093 Except : Node_Id; 1094 Stmts : List_Id; 1095 1096 begin 1097 pragma Assert (Present (Data.Raised_Id)); 1098 1099 if Exception_Extra_Info 1100 or else (For_Library and not Restricted_Profile) 1101 then 1102 if Exception_Extra_Info then 1103 1104 -- Generate: 1105 1106 -- Get_Current_Excep.all 1107 1108 Except := 1109 Make_Function_Call (Data.Loc, 1110 Name => 1111 Make_Explicit_Dereference (Data.Loc, 1112 Prefix => 1113 New_Occurrence_Of 1114 (RTE (RE_Get_Current_Excep), Data.Loc))); 1115 1116 else 1117 -- Generate: 1118 1119 -- null 1120 1121 Except := Make_Null (Data.Loc); 1122 end if; 1123 1124 if For_Library and then not Restricted_Profile then 1125 Proc_To_Call := RTE (RE_Save_Library_Occurrence); 1126 Actuals := New_List (Except); 1127 1128 else 1129 Proc_To_Call := RTE (RE_Save_Occurrence); 1130 1131 -- The dereference occurs only when Exception_Extra_Info is true, 1132 -- and therefore Except is not null. 1133 1134 Actuals := 1135 New_List ( 1136 New_Occurrence_Of (Data.E_Id, Data.Loc), 1137 Make_Explicit_Dereference (Data.Loc, Except)); 1138 end if; 1139 1140 -- Generate: 1141 1142 -- when others => 1143 -- if not Raised_Id then 1144 -- Raised_Id := True; 1145 1146 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all); 1147 -- or 1148 -- Save_Library_Occurrence (Get_Current_Excep.all); 1149 -- end if; 1150 1151 Stmts := 1152 New_List ( 1153 Make_If_Statement (Data.Loc, 1154 Condition => 1155 Make_Op_Not (Data.Loc, 1156 Right_Opnd => New_Occurrence_Of (Data.Raised_Id, Data.Loc)), 1157 1158 Then_Statements => New_List ( 1159 Make_Assignment_Statement (Data.Loc, 1160 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc), 1161 Expression => New_Occurrence_Of (Standard_True, Data.Loc)), 1162 1163 Make_Procedure_Call_Statement (Data.Loc, 1164 Name => 1165 New_Occurrence_Of (Proc_To_Call, Data.Loc), 1166 Parameter_Associations => Actuals)))); 1167 1168 else 1169 -- Generate: 1170 1171 -- Raised_Id := True; 1172 1173 Stmts := New_List ( 1174 Make_Assignment_Statement (Data.Loc, 1175 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc), 1176 Expression => New_Occurrence_Of (Standard_True, Data.Loc))); 1177 end if; 1178 1179 -- Generate: 1180 1181 -- when others => 1182 1183 return 1184 Make_Exception_Handler (Data.Loc, 1185 Exception_Choices => New_List (Make_Others_Choice (Data.Loc)), 1186 Statements => Stmts); 1187 end Build_Exception_Handler; 1188 1189 ------------------------------- 1190 -- Build_Finalization_Master -- 1191 ------------------------------- 1192 1193 procedure Build_Finalization_Master 1194 (Typ : Entity_Id; 1195 For_Lib_Level : Boolean := False; 1196 For_Private : Boolean := False; 1197 Context_Scope : Entity_Id := Empty; 1198 Insertion_Node : Node_Id := Empty) 1199 is 1200 procedure Add_Pending_Access_Type 1201 (Typ : Entity_Id; 1202 Ptr_Typ : Entity_Id); 1203 -- Add access type Ptr_Typ to the pending access type list for type Typ 1204 1205 ----------------------------- 1206 -- Add_Pending_Access_Type -- 1207 ----------------------------- 1208 1209 procedure Add_Pending_Access_Type 1210 (Typ : Entity_Id; 1211 Ptr_Typ : Entity_Id) 1212 is 1213 List : Elist_Id; 1214 1215 begin 1216 if Present (Pending_Access_Types (Typ)) then 1217 List := Pending_Access_Types (Typ); 1218 else 1219 List := New_Elmt_List; 1220 Set_Pending_Access_Types (Typ, List); 1221 end if; 1222 1223 Prepend_Elmt (Ptr_Typ, List); 1224 end Add_Pending_Access_Type; 1225 1226 -- Local variables 1227 1228 Desig_Typ : constant Entity_Id := Designated_Type (Typ); 1229 1230 Ptr_Typ : constant Entity_Id := Root_Type_Of_Full_View (Base_Type (Typ)); 1231 -- A finalization master created for a named access type is associated 1232 -- with the full view (if applicable) as a consequence of freezing. The 1233 -- full view criteria does not apply to anonymous access types because 1234 -- those cannot have a private and a full view. 1235 1236 -- Start of processing for Build_Finalization_Master 1237 1238 begin 1239 -- Nothing to do if the circumstances do not allow for a finalization 1240 -- master. 1241 1242 if not Allows_Finalization_Master (Typ) then 1243 return; 1244 1245 -- Various machinery such as freezing may have already created a 1246 -- finalization master. 1247 1248 elsif Present (Finalization_Master (Ptr_Typ)) then 1249 return; 1250 end if; 1251 1252 declare 1253 Actions : constant List_Id := New_List; 1254 Loc : constant Source_Ptr := Sloc (Ptr_Typ); 1255 Fin_Mas_Id : Entity_Id; 1256 Pool_Id : Entity_Id; 1257 1258 begin 1259 -- Source access types use fixed master names since the master is 1260 -- inserted in the same source unit only once. The only exception to 1261 -- this are instances using the same access type as generic actual. 1262 1263 if Comes_From_Source (Ptr_Typ) and then not Inside_A_Generic then 1264 Fin_Mas_Id := 1265 Make_Defining_Identifier (Loc, 1266 Chars => New_External_Name (Chars (Ptr_Typ), "FM")); 1267 1268 -- Internally generated access types use temporaries as their names 1269 -- due to possible collision with identical names coming from other 1270 -- packages. 1271 1272 else 1273 Fin_Mas_Id := Make_Temporary (Loc, 'F'); 1274 end if; 1275 1276 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); 1277 1278 -- Generate: 1279 -- <Ptr_Typ>FM : aliased Finalization_Master; 1280 1281 Append_To (Actions, 1282 Make_Object_Declaration (Loc, 1283 Defining_Identifier => Fin_Mas_Id, 1284 Aliased_Present => True, 1285 Object_Definition => 1286 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc))); 1287 1288 if Debug_Generated_Code then 1289 Set_Debug_Info_Needed (Fin_Mas_Id); 1290 end if; 1291 1292 -- Set the associated pool and primitive Finalize_Address of the new 1293 -- finalization master. 1294 1295 -- The access type has a user-defined storage pool, use it 1296 1297 if Present (Associated_Storage_Pool (Ptr_Typ)) then 1298 Pool_Id := Associated_Storage_Pool (Ptr_Typ); 1299 1300 -- Otherwise the default choice is the global storage pool 1301 1302 else 1303 Pool_Id := RTE (RE_Global_Pool_Object); 1304 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); 1305 end if; 1306 1307 -- Generate: 1308 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access); 1309 1310 Append_To (Actions, 1311 Make_Procedure_Call_Statement (Loc, 1312 Name => 1313 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), 1314 Parameter_Associations => New_List ( 1315 New_Occurrence_Of (Fin_Mas_Id, Loc), 1316 Make_Attribute_Reference (Loc, 1317 Prefix => New_Occurrence_Of (Pool_Id, Loc), 1318 Attribute_Name => Name_Unrestricted_Access)))); 1319 1320 -- Finalize_Address is not generated in CodePeer mode because the 1321 -- body contains address arithmetic. Skip this step. 1322 1323 if CodePeer_Mode then 1324 null; 1325 1326 -- Associate the Finalize_Address primitive of the designated type 1327 -- with the finalization master of the access type. The designated 1328 -- type must be forzen as Finalize_Address is generated when the 1329 -- freeze node is expanded. 1330 1331 elsif Is_Frozen (Desig_Typ) 1332 and then Present (Finalize_Address (Desig_Typ)) 1333 1334 -- The finalization master of an anonymous access type may need 1335 -- to be inserted in a specific place in the tree. For instance: 1336 1337 -- type Comp_Typ; 1338 1339 -- <finalization master of "access Comp_Typ"> 1340 1341 -- type Rec_Typ is record 1342 -- Comp : access Comp_Typ; 1343 -- end record; 1344 1345 -- <freeze node for Comp_Typ> 1346 -- <freeze node for Rec_Typ> 1347 1348 -- Due to this oddity, the anonymous access type is stored for 1349 -- later processing (see below). 1350 1351 and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type 1352 then 1353 -- Generate: 1354 -- Set_Finalize_Address 1355 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access); 1356 1357 Append_To (Actions, 1358 Make_Set_Finalize_Address_Call 1359 (Loc => Loc, 1360 Ptr_Typ => Ptr_Typ)); 1361 1362 -- Otherwise the designated type is either anonymous access or a 1363 -- Taft-amendment type and has not been frozen. Store the access 1364 -- type for later processing (see Freeze_Type). 1365 1366 else 1367 Add_Pending_Access_Type (Desig_Typ, Ptr_Typ); 1368 end if; 1369 1370 -- A finalization master created for an access designating a type 1371 -- with private components is inserted before a context-dependent 1372 -- node. 1373 1374 if For_Private then 1375 1376 -- At this point both the scope of the context and the insertion 1377 -- mode must be known. 1378 1379 pragma Assert (Present (Context_Scope)); 1380 pragma Assert (Present (Insertion_Node)); 1381 1382 Push_Scope (Context_Scope); 1383 1384 -- Treat use clauses as declarations and insert directly in front 1385 -- of them. 1386 1387 if Nkind (Insertion_Node) in 1388 N_Use_Package_Clause | N_Use_Type_Clause 1389 then 1390 Insert_List_Before_And_Analyze (Insertion_Node, Actions); 1391 else 1392 Insert_Actions (Insertion_Node, Actions); 1393 end if; 1394 1395 Pop_Scope; 1396 1397 -- The finalization master belongs to an access result type related 1398 -- to a build-in-place function call used to initialize a library 1399 -- level object. The master must be inserted in front of the access 1400 -- result type declaration denoted by Insertion_Node. 1401 1402 elsif For_Lib_Level then 1403 pragma Assert (Present (Insertion_Node)); 1404 Insert_Actions (Insertion_Node, Actions); 1405 1406 -- Otherwise the finalization master and its initialization become a 1407 -- part of the freeze node. 1408 1409 else 1410 Append_Freeze_Actions (Ptr_Typ, Actions); 1411 end if; 1412 1413 Analyze_List (Actions); 1414 1415 -- When the type the finalization master is being generated for was 1416 -- created to store a 'Old object, then mark it as such so its 1417 -- finalization can be delayed until after postconditions have been 1418 -- checked. 1419 1420 if Stores_Attribute_Old_Prefix (Ptr_Typ) then 1421 Set_Stores_Attribute_Old_Prefix (Fin_Mas_Id); 1422 end if; 1423 end; 1424 end Build_Finalization_Master; 1425 1426 ---------------------------- 1427 -- Build_Finalizer_Helper -- 1428 ---------------------------- 1429 1430 procedure Build_Finalizer_Helper 1431 (N : Node_Id; 1432 Clean_Stmts : List_Id; 1433 Mark_Id : Entity_Id; 1434 Top_Decls : List_Id; 1435 Defer_Abort : Boolean; 1436 Fin_Id : out Entity_Id; 1437 Finalize_Old_Only : Boolean) 1438 is 1439 Acts_As_Clean : constant Boolean := 1440 Present (Mark_Id) 1441 or else 1442 (Present (Clean_Stmts) 1443 and then Is_Non_Empty_List (Clean_Stmts)); 1444 1445 For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body; 1446 For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration; 1447 For_Package : constant Boolean := 1448 For_Package_Body or else For_Package_Spec; 1449 Loc : constant Source_Ptr := Sloc (N); 1450 1451 -- NOTE: Local variable declarations are conservative and do not create 1452 -- structures right from the start. Entities and lists are created once 1453 -- it has been established that N has at least one controlled object. 1454 1455 Components_Built : Boolean := False; 1456 -- A flag used to avoid double initialization of entities and lists. If 1457 -- the flag is set then the following variables have been initialized: 1458 -- Counter_Id 1459 -- Finalizer_Decls 1460 -- Finalizer_Stmts 1461 -- Jump_Alts 1462 1463 Counter_Id : Entity_Id := Empty; 1464 Counter_Val : Nat := 0; 1465 -- Name and value of the state counter 1466 1467 Decls : List_Id := No_List; 1468 -- Declarative region of N (if available). If N is a package declaration 1469 -- Decls denotes the visible declarations. 1470 1471 Finalizer_Data : Finalization_Exception_Data; 1472 -- Data for the exception 1473 1474 Finalizer_Decls : List_Id := No_List; 1475 -- Local variable declarations. This list holds the label declarations 1476 -- of all jump block alternatives as well as the declaration of the 1477 -- local exception occurrence and the raised flag: 1478 -- E : Exception_Occurrence; 1479 -- Raised : Boolean := False; 1480 -- L<counter value> : label; 1481 1482 Finalizer_Insert_Nod : Node_Id := Empty; 1483 -- Insertion point for the finalizer body. Depending on the context 1484 -- (Nkind of N) and the individual grouping of controlled objects, this 1485 -- node may denote a package declaration or body, package instantiation, 1486 -- block statement or a counter update statement. 1487 1488 Finalizer_Stmts : List_Id := No_List; 1489 -- The statement list of the finalizer body. It contains the following: 1490 -- 1491 -- Abort_Defer; -- Added if abort is allowed 1492 -- <call to Prev_At_End> -- Added if exists 1493 -- <cleanup statements> -- Added if Acts_As_Clean 1494 -- <jump block> -- Added if Has_Ctrl_Objs 1495 -- <finalization statements> -- Added if Has_Ctrl_Objs 1496 -- <stack release> -- Added if Mark_Id exists 1497 -- Abort_Undefer; -- Added if abort is allowed 1498 1499 Has_Ctrl_Objs : Boolean := False; 1500 -- A general flag which denotes whether N has at least one controlled 1501 -- object. 1502 1503 Has_Tagged_Types : Boolean := False; 1504 -- A general flag which indicates whether N has at least one library- 1505 -- level tagged type declaration. 1506 1507 HSS : Node_Id := Empty; 1508 -- The sequence of statements of N (if available) 1509 1510 Jump_Alts : List_Id := No_List; 1511 -- Jump block alternatives. Depending on the value of the state counter, 1512 -- the control flow jumps to a sequence of finalization statements. This 1513 -- list contains the following: 1514 -- 1515 -- when <counter value> => 1516 -- goto L<counter value>; 1517 1518 Jump_Block_Insert_Nod : Node_Id := Empty; 1519 -- Specific point in the finalizer statements where the jump block is 1520 -- inserted. 1521 1522 Last_Top_Level_Ctrl_Construct : Node_Id := Empty; 1523 -- The last controlled construct encountered when processing the top 1524 -- level lists of N. This can be a nested package, an instantiation or 1525 -- an object declaration. 1526 1527 Prev_At_End : Entity_Id := Empty; 1528 -- The previous at end procedure of the handled statements block of N 1529 1530 Priv_Decls : List_Id := No_List; 1531 -- The private declarations of N if N is a package declaration 1532 1533 Spec_Id : Entity_Id := Empty; 1534 Spec_Decls : List_Id := Top_Decls; 1535 Stmts : List_Id := No_List; 1536 1537 Tagged_Type_Stmts : List_Id := No_List; 1538 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level 1539 -- tagged types found in N. 1540 1541 ----------------------- 1542 -- Local subprograms -- 1543 ----------------------- 1544 1545 procedure Build_Components; 1546 -- Create all entites and initialize all lists used in the creation of 1547 -- the finalizer. 1548 1549 procedure Create_Finalizer; 1550 -- Create the spec and body of the finalizer and insert them in the 1551 -- proper place in the tree depending on the context. 1552 1553 procedure Process_Declarations 1554 (Decls : List_Id; 1555 Preprocess : Boolean := False; 1556 Top_Level : Boolean := False); 1557 -- Inspect a list of declarations or statements which may contain 1558 -- objects that need finalization. When flag Preprocess is set, the 1559 -- routine will simply count the total number of controlled objects in 1560 -- Decls. Flag Top_Level denotes whether the processing is done for 1561 -- objects in nested package declarations or instances. 1562 1563 procedure Process_Object_Declaration 1564 (Decl : Node_Id; 1565 Has_No_Init : Boolean := False; 1566 Is_Protected : Boolean := False); 1567 -- Generate all the machinery associated with the finalization of a 1568 -- single object. Flag Has_No_Init is used to denote certain contexts 1569 -- where Decl does not have initialization call(s). Flag Is_Protected 1570 -- is set when Decl denotes a simple protected object. 1571 1572 procedure Process_Tagged_Type_Declaration (Decl : Node_Id); 1573 -- Generate all the code necessary to unregister the external tag of a 1574 -- tagged type. 1575 1576 ---------------------- 1577 -- Build_Components -- 1578 ---------------------- 1579 1580 procedure Build_Components is 1581 Counter_Decl : Node_Id; 1582 Counter_Typ : Entity_Id; 1583 Counter_Typ_Decl : Node_Id; 1584 1585 begin 1586 pragma Assert (Present (Decls)); 1587 1588 -- This routine might be invoked several times when dealing with 1589 -- constructs that have two lists (either two declarative regions 1590 -- or declarations and statements). Avoid double initialization. 1591 1592 if Components_Built then 1593 return; 1594 end if; 1595 1596 Components_Built := True; 1597 1598 if Has_Ctrl_Objs then 1599 1600 -- Create entities for the counter, its type, the local exception 1601 -- and the raised flag. 1602 1603 Counter_Id := Make_Temporary (Loc, 'C'); 1604 Counter_Typ := Make_Temporary (Loc, 'T'); 1605 1606 Finalizer_Decls := New_List; 1607 1608 Build_Object_Declarations 1609 (Finalizer_Data, Finalizer_Decls, Loc, For_Package); 1610 1611 -- Since the total number of controlled objects is always known, 1612 -- build a subtype of Natural with precise bounds. This allows 1613 -- the backend to optimize the case statement. Generate: 1614 -- 1615 -- subtype Tnn is Natural range 0 .. Counter_Val; 1616 1617 Counter_Typ_Decl := 1618 Make_Subtype_Declaration (Loc, 1619 Defining_Identifier => Counter_Typ, 1620 Subtype_Indication => 1621 Make_Subtype_Indication (Loc, 1622 Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc), 1623 Constraint => 1624 Make_Range_Constraint (Loc, 1625 Range_Expression => 1626 Make_Range (Loc, 1627 Low_Bound => 1628 Make_Integer_Literal (Loc, Uint_0), 1629 High_Bound => 1630 Make_Integer_Literal (Loc, Counter_Val))))); 1631 1632 -- Generate the declaration of the counter itself: 1633 -- 1634 -- Counter : Integer := 0; 1635 1636 Counter_Decl := 1637 Make_Object_Declaration (Loc, 1638 Defining_Identifier => Counter_Id, 1639 Object_Definition => New_Occurrence_Of (Counter_Typ, Loc), 1640 Expression => Make_Integer_Literal (Loc, 0)); 1641 1642 -- Set the type of the counter explicitly to prevent errors when 1643 -- examining object declarations later on. 1644 1645 Set_Etype (Counter_Id, Counter_Typ); 1646 1647 if Debug_Generated_Code then 1648 Set_Debug_Info_Needed (Counter_Id); 1649 end if; 1650 1651 -- The counter and its type are inserted before the source 1652 -- declarations of N. 1653 1654 Prepend_To (Decls, Counter_Decl); 1655 Prepend_To (Decls, Counter_Typ_Decl); 1656 1657 -- The counter and its associated type must be manually analyzed 1658 -- since N has already been analyzed. Use the scope of the spec 1659 -- when inserting in a package. 1660 1661 if For_Package then 1662 Push_Scope (Spec_Id); 1663 Analyze (Counter_Typ_Decl); 1664 Analyze (Counter_Decl); 1665 Pop_Scope; 1666 1667 else 1668 Analyze (Counter_Typ_Decl); 1669 Analyze (Counter_Decl); 1670 end if; 1671 1672 Jump_Alts := New_List; 1673 end if; 1674 1675 -- If the context requires additional cleanup, the finalization 1676 -- machinery is added after the cleanup code. 1677 1678 if Acts_As_Clean then 1679 Finalizer_Stmts := Clean_Stmts; 1680 Jump_Block_Insert_Nod := Last (Finalizer_Stmts); 1681 else 1682 Finalizer_Stmts := New_List; 1683 end if; 1684 1685 if Has_Tagged_Types then 1686 Tagged_Type_Stmts := New_List; 1687 end if; 1688 end Build_Components; 1689 1690 ---------------------- 1691 -- Create_Finalizer -- 1692 ---------------------- 1693 1694 procedure Create_Finalizer is 1695 function New_Finalizer_Name return Name_Id; 1696 -- Create a fully qualified name of a package spec or body finalizer. 1697 -- The generated name is of the form: xx__yy__finalize_[spec|body]. 1698 1699 ------------------------ 1700 -- New_Finalizer_Name -- 1701 ------------------------ 1702 1703 function New_Finalizer_Name return Name_Id is 1704 procedure New_Finalizer_Name (Id : Entity_Id); 1705 -- Place "__<name-of-Id>" in the name buffer. If the identifier 1706 -- has a non-standard scope, process the scope first. 1707 1708 ------------------------ 1709 -- New_Finalizer_Name -- 1710 ------------------------ 1711 1712 procedure New_Finalizer_Name (Id : Entity_Id) is 1713 begin 1714 if Scope (Id) = Standard_Standard then 1715 Get_Name_String (Chars (Id)); 1716 1717 else 1718 New_Finalizer_Name (Scope (Id)); 1719 Add_Str_To_Name_Buffer ("__"); 1720 Add_Str_To_Name_Buffer (Get_Name_String (Chars (Id))); 1721 end if; 1722 end New_Finalizer_Name; 1723 1724 -- Start of processing for New_Finalizer_Name 1725 1726 begin 1727 -- Create the fully qualified name of the enclosing scope 1728 1729 New_Finalizer_Name (Spec_Id); 1730 1731 -- Generate: 1732 -- __finalize_[spec|body] 1733 1734 Add_Str_To_Name_Buffer ("__finalize_"); 1735 1736 if For_Package_Spec then 1737 Add_Str_To_Name_Buffer ("spec"); 1738 else 1739 Add_Str_To_Name_Buffer ("body"); 1740 end if; 1741 1742 return Name_Find; 1743 end New_Finalizer_Name; 1744 1745 -- Local variables 1746 1747 Body_Id : Entity_Id; 1748 Fin_Body : Node_Id; 1749 Fin_Spec : Node_Id; 1750 Jump_Block : Node_Id; 1751 Label : Node_Id; 1752 Label_Id : Entity_Id; 1753 1754 -- Start of processing for Create_Finalizer 1755 1756 begin 1757 -- Step 1: Creation of the finalizer name 1758 1759 -- Packages must use a distinct name for their finalizers since the 1760 -- binder will have to generate calls to them by name. The name is 1761 -- of the following form: 1762 1763 -- xx__yy__finalize_[spec|body] 1764 1765 if For_Package then 1766 Fin_Id := Make_Defining_Identifier (Loc, New_Finalizer_Name); 1767 Set_Has_Qualified_Name (Fin_Id); 1768 Set_Has_Fully_Qualified_Name (Fin_Id); 1769 1770 -- The default name is _finalizer 1771 1772 else 1773 -- Generation of a finalization procedure exclusively for 'Old 1774 -- interally generated constants requires different name since 1775 -- there will need to be multiple finalization routines in the 1776 -- same scope. See Build_Finalizer for details. 1777 1778 if Finalize_Old_Only then 1779 Fin_Id := 1780 Make_Defining_Identifier (Loc, 1781 Chars => New_External_Name (Name_uFinalizer_Old)); 1782 else 1783 Fin_Id := 1784 Make_Defining_Identifier (Loc, 1785 Chars => New_External_Name (Name_uFinalizer)); 1786 end if; 1787 1788 -- The visibility semantics of AT_END handlers force a strange 1789 -- separation of spec and body for stack-related finalizers: 1790 1791 -- declare : Enclosing_Scope 1792 -- procedure _finalizer; 1793 -- begin 1794 -- <controlled objects> 1795 -- procedure _finalizer is 1796 -- ... 1797 -- at end 1798 -- _finalizer; 1799 -- end; 1800 1801 -- Both spec and body are within the same construct and scope, but 1802 -- the body is part of the handled sequence of statements. This 1803 -- placement confuses the elaboration mechanism on targets where 1804 -- AT_END handlers are expanded into "when all others" handlers: 1805 1806 -- exception 1807 -- when all others => 1808 -- _finalizer; -- appears to require elab checks 1809 -- at end 1810 -- _finalizer; 1811 -- end; 1812 1813 -- Since the compiler guarantees that the body of a _finalizer is 1814 -- always inserted in the same construct where the AT_END handler 1815 -- resides, there is no need for elaboration checks. 1816 1817 Set_Kill_Elaboration_Checks (Fin_Id); 1818 1819 -- Inlining the finalizer produces a substantial speedup at -O2. 1820 -- It is inlined by default at -O3. Either way, it is called 1821 -- exactly twice (once on the normal path, and once for 1822 -- exceptions/abort), so this won't bloat the code too much. 1823 1824 Set_Is_Inlined (Fin_Id); 1825 end if; 1826 1827 if Debug_Generated_Code then 1828 Set_Debug_Info_Needed (Fin_Id); 1829 end if; 1830 1831 -- Step 2: Creation of the finalizer specification 1832 1833 -- Generate: 1834 -- procedure Fin_Id; 1835 1836 Fin_Spec := 1837 Make_Subprogram_Declaration (Loc, 1838 Specification => 1839 Make_Procedure_Specification (Loc, 1840 Defining_Unit_Name => Fin_Id)); 1841 1842 -- Step 3: Creation of the finalizer body 1843 1844 if Has_Ctrl_Objs then 1845 1846 -- Add L0, the default destination to the jump block 1847 1848 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0)); 1849 Set_Entity (Label_Id, 1850 Make_Defining_Identifier (Loc, Chars (Label_Id))); 1851 Label := Make_Label (Loc, Label_Id); 1852 1853 -- Generate: 1854 -- L0 : label; 1855 1856 Prepend_To (Finalizer_Decls, 1857 Make_Implicit_Label_Declaration (Loc, 1858 Defining_Identifier => Entity (Label_Id), 1859 Label_Construct => Label)); 1860 1861 -- Generate: 1862 -- when others => 1863 -- goto L0; 1864 1865 Append_To (Jump_Alts, 1866 Make_Case_Statement_Alternative (Loc, 1867 Discrete_Choices => New_List (Make_Others_Choice (Loc)), 1868 Statements => New_List ( 1869 Make_Goto_Statement (Loc, 1870 Name => New_Occurrence_Of (Entity (Label_Id), Loc))))); 1871 1872 -- Generate: 1873 -- <<L0>> 1874 1875 Append_To (Finalizer_Stmts, Label); 1876 1877 -- Create the jump block which controls the finalization flow 1878 -- depending on the value of the state counter. 1879 1880 Jump_Block := 1881 Make_Case_Statement (Loc, 1882 Expression => Make_Identifier (Loc, Chars (Counter_Id)), 1883 Alternatives => Jump_Alts); 1884 1885 if Acts_As_Clean and then Present (Jump_Block_Insert_Nod) then 1886 Insert_After (Jump_Block_Insert_Nod, Jump_Block); 1887 else 1888 Prepend_To (Finalizer_Stmts, Jump_Block); 1889 end if; 1890 end if; 1891 1892 -- Add the library-level tagged type unregistration machinery before 1893 -- the jump block circuitry. This ensures that external tags will be 1894 -- removed even if a finalization exception occurs at some point. 1895 1896 if Has_Tagged_Types then 1897 Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts); 1898 end if; 1899 1900 -- Add a call to the previous At_End handler if it exists. The call 1901 -- must always precede the jump block. 1902 1903 if Present (Prev_At_End) then 1904 Prepend_To (Finalizer_Stmts, 1905 Make_Procedure_Call_Statement (Loc, Prev_At_End)); 1906 1907 -- Clear the At_End handler since we have already generated the 1908 -- proper replacement call for it. 1909 1910 Set_At_End_Proc (HSS, Empty); 1911 end if; 1912 1913 -- Release the secondary stack 1914 1915 if Present (Mark_Id) then 1916 declare 1917 Release : Node_Id := Build_SS_Release_Call (Loc, Mark_Id); 1918 1919 begin 1920 -- If the context is a build-in-place function, the secondary 1921 -- stack must be released, unless the build-in-place function 1922 -- itself is returning on the secondary stack. Generate: 1923 -- 1924 -- if BIP_Alloc_Form /= Secondary_Stack then 1925 -- SS_Release (Mark_Id); 1926 -- end if; 1927 -- 1928 -- Note that if the function returns on the secondary stack, 1929 -- then the responsibility of reclaiming the space is always 1930 -- left to the caller (recursively if needed). 1931 1932 if Nkind (N) = N_Subprogram_Body then 1933 declare 1934 Spec_Id : constant Entity_Id := 1935 Unique_Defining_Entity (N); 1936 BIP_SS : constant Boolean := 1937 Is_Build_In_Place_Function (Spec_Id) 1938 and then Needs_BIP_Alloc_Form (Spec_Id); 1939 begin 1940 if BIP_SS then 1941 Release := 1942 Make_If_Statement (Loc, 1943 Condition => 1944 Make_Op_Ne (Loc, 1945 Left_Opnd => 1946 New_Occurrence_Of 1947 (Build_In_Place_Formal 1948 (Spec_Id, BIP_Alloc_Form), Loc), 1949 Right_Opnd => 1950 Make_Integer_Literal (Loc, 1951 UI_From_Int 1952 (BIP_Allocation_Form'Pos 1953 (Secondary_Stack)))), 1954 1955 Then_Statements => New_List (Release)); 1956 end if; 1957 end; 1958 end if; 1959 1960 Append_To (Finalizer_Stmts, Release); 1961 end; 1962 end if; 1963 1964 -- Protect the statements with abort defer/undefer. This is only when 1965 -- aborts are allowed and the cleanup statements require deferral or 1966 -- there are controlled objects to be finalized. Note that the abort 1967 -- defer/undefer pair does not require an extra block because each 1968 -- finalization exception is caught in its corresponding finalization 1969 -- block. As a result, the call to Abort_Defer always takes place. 1970 1971 if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then 1972 Prepend_To (Finalizer_Stmts, 1973 Build_Runtime_Call (Loc, RE_Abort_Defer)); 1974 1975 Append_To (Finalizer_Stmts, 1976 Build_Runtime_Call (Loc, RE_Abort_Undefer)); 1977 end if; 1978 1979 -- The local exception does not need to be reraised for library-level 1980 -- finalizers. Note that this action must be carried out after object 1981 -- cleanup, secondary stack release, and abort undeferral. Generate: 1982 1983 -- if Raised and then not Abort then 1984 -- Raise_From_Controlled_Operation (E); 1985 -- end if; 1986 1987 if Has_Ctrl_Objs and Exceptions_OK and not For_Package then 1988 Append_To (Finalizer_Stmts, 1989 Build_Raise_Statement (Finalizer_Data)); 1990 end if; 1991 1992 -- Generate: 1993 -- procedure Fin_Id is 1994 -- Abort : constant Boolean := Triggered_By_Abort; 1995 -- <or> 1996 -- Abort : constant Boolean := False; -- no abort 1997 1998 -- E : Exception_Occurrence; -- All added if flag 1999 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set 2000 -- L0 : label; 2001 -- ... 2002 -- Lnn : label; 2003 2004 -- begin 2005 -- Abort_Defer; -- Added if abort is allowed 2006 -- <call to Prev_At_End> -- Added if exists 2007 -- <cleanup statements> -- Added if Acts_As_Clean 2008 -- <jump block> -- Added if Has_Ctrl_Objs 2009 -- <finalization statements> -- Added if Has_Ctrl_Objs 2010 -- <stack release> -- Added if Mark_Id exists 2011 -- Abort_Undefer; -- Added if abort is allowed 2012 -- <exception propagation> -- Added if Has_Ctrl_Objs 2013 -- end Fin_Id; 2014 2015 -- Create the body of the finalizer 2016 2017 Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id)); 2018 2019 if Debug_Generated_Code then 2020 Set_Debug_Info_Needed (Body_Id); 2021 end if; 2022 2023 if For_Package then 2024 Set_Has_Qualified_Name (Body_Id); 2025 Set_Has_Fully_Qualified_Name (Body_Id); 2026 end if; 2027 2028 Fin_Body := 2029 Make_Subprogram_Body (Loc, 2030 Specification => 2031 Make_Procedure_Specification (Loc, 2032 Defining_Unit_Name => Body_Id), 2033 Declarations => Finalizer_Decls, 2034 Handled_Statement_Sequence => 2035 Make_Handled_Sequence_Of_Statements (Loc, 2036 Statements => Finalizer_Stmts)); 2037 2038 -- Step 4: Spec and body insertion, analysis 2039 2040 if For_Package then 2041 2042 -- If the package spec has private declarations, the finalizer 2043 -- body must be added to the end of the list in order to have 2044 -- visibility of all private controlled objects. 2045 2046 if For_Package_Spec then 2047 if Present (Priv_Decls) then 2048 Append_To (Priv_Decls, Fin_Spec); 2049 Append_To (Priv_Decls, Fin_Body); 2050 else 2051 Append_To (Decls, Fin_Spec); 2052 Append_To (Decls, Fin_Body); 2053 end if; 2054 2055 -- For package bodies, both the finalizer spec and body are 2056 -- inserted at the end of the package declarations. 2057 2058 else 2059 Append_To (Decls, Fin_Spec); 2060 Append_To (Decls, Fin_Body); 2061 end if; 2062 2063 -- Push the name of the package 2064 2065 Push_Scope (Spec_Id); 2066 Analyze (Fin_Spec); 2067 Analyze (Fin_Body); 2068 Pop_Scope; 2069 2070 -- Non-package case 2071 2072 else 2073 -- Create the spec for the finalizer. The At_End handler must be 2074 -- able to call the body which resides in a nested structure. 2075 2076 -- Generate: 2077 -- declare 2078 -- procedure Fin_Id; -- Spec 2079 -- begin 2080 -- <objects and possibly statements> 2081 -- procedure Fin_Id is ... -- Body 2082 -- <statements> 2083 -- at end 2084 -- Fin_Id; -- At_End handler 2085 -- end; 2086 2087 pragma Assert (Present (Spec_Decls)); 2088 2089 -- It maybe possible that we are finalizing 'Old objects which 2090 -- exist in the spec declarations. When this is the case the 2091 -- Finalizer_Insert_Node will come before the end of the 2092 -- Spec_Decls. So, to mitigate this, we insert the finalizer spec 2093 -- earlier at the Finalizer_Insert_Nod instead of appending to the 2094 -- end of Spec_Decls to prevent its body appearing before its 2095 -- corresponding spec. 2096 2097 if Present (Finalizer_Insert_Nod) 2098 and then List_Containing (Finalizer_Insert_Nod) = Spec_Decls 2099 then 2100 Insert_After_And_Analyze (Finalizer_Insert_Nod, Fin_Spec); 2101 Finalizer_Insert_Nod := Fin_Spec; 2102 2103 -- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls 2104 2105 else 2106 Append_To (Spec_Decls, Fin_Spec); 2107 Analyze (Fin_Spec); 2108 end if; 2109 2110 -- When the finalizer acts solely as a cleanup routine, the body 2111 -- is inserted right after the spec. 2112 2113 if Acts_As_Clean and not Has_Ctrl_Objs then 2114 Insert_After (Fin_Spec, Fin_Body); 2115 2116 -- In all other cases the body is inserted after either: 2117 -- 2118 -- 1) The counter update statement of the last controlled object 2119 -- 2) The last top level nested controlled package 2120 -- 3) The last top level controlled instantiation 2121 2122 else 2123 -- Manually freeze the spec. This is somewhat of a hack because 2124 -- a subprogram is frozen when its body is seen and the freeze 2125 -- node appears right before the body. However, in this case, 2126 -- the spec must be frozen earlier since the At_End handler 2127 -- must be able to call it. 2128 -- 2129 -- declare 2130 -- procedure Fin_Id; -- Spec 2131 -- [Fin_Id] -- Freeze node 2132 -- begin 2133 -- ... 2134 -- at end 2135 -- Fin_Id; -- At_End handler 2136 -- end; 2137 2138 Ensure_Freeze_Node (Fin_Id); 2139 Insert_After (Fin_Spec, Freeze_Node (Fin_Id)); 2140 Set_Is_Frozen (Fin_Id); 2141 2142 -- In the case where the last construct to contain a controlled 2143 -- object is either a nested package, an instantiation or a 2144 -- freeze node, the body must be inserted directly after the 2145 -- construct. 2146 2147 if Nkind (Last_Top_Level_Ctrl_Construct) in 2148 N_Freeze_Entity | N_Package_Declaration | N_Package_Body 2149 then 2150 Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct; 2151 end if; 2152 2153 Insert_After (Finalizer_Insert_Nod, Fin_Body); 2154 end if; 2155 2156 Analyze (Fin_Body, Suppress => All_Checks); 2157 end if; 2158 2159 -- Never consider that the finalizer procedure is enabled Ghost, even 2160 -- when the corresponding unit is Ghost, as this would lead to an 2161 -- an external name with a ___ghost_ prefix that the binder cannot 2162 -- generate, as it has no knowledge of the Ghost status of units. 2163 2164 Set_Is_Checked_Ghost_Entity (Fin_Id, False); 2165 end Create_Finalizer; 2166 2167 -------------------------- 2168 -- Process_Declarations -- 2169 -------------------------- 2170 2171 procedure Process_Declarations 2172 (Decls : List_Id; 2173 Preprocess : Boolean := False; 2174 Top_Level : Boolean := False) 2175 is 2176 Decl : Node_Id; 2177 Expr : Node_Id; 2178 Obj_Id : Entity_Id; 2179 Obj_Typ : Entity_Id; 2180 Pack_Id : Entity_Id; 2181 Spec : Node_Id; 2182 Typ : Entity_Id; 2183 2184 Old_Counter_Val : Nat; 2185 -- This variable is used to determine whether a nested package or 2186 -- instance contains at least one controlled object. 2187 2188 procedure Processing_Actions 2189 (Has_No_Init : Boolean := False; 2190 Is_Protected : Boolean := False); 2191 -- Depending on the mode of operation of Process_Declarations, either 2192 -- increment the controlled object counter, set the controlled object 2193 -- flag and store the last top level construct or process the current 2194 -- declaration. Flag Has_No_Init is used to propagate scenarios where 2195 -- the current declaration may not have initialization proc(s). Flag 2196 -- Is_Protected should be set when the current declaration denotes a 2197 -- simple protected object. 2198 2199 ------------------------ 2200 -- Processing_Actions -- 2201 ------------------------ 2202 2203 procedure Processing_Actions 2204 (Has_No_Init : Boolean := False; 2205 Is_Protected : Boolean := False) 2206 is 2207 begin 2208 -- Library-level tagged type 2209 2210 if Nkind (Decl) = N_Full_Type_Declaration then 2211 if Preprocess then 2212 Has_Tagged_Types := True; 2213 2214 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then 2215 Last_Top_Level_Ctrl_Construct := Decl; 2216 end if; 2217 2218 else 2219 Process_Tagged_Type_Declaration (Decl); 2220 end if; 2221 2222 -- Controlled object declaration 2223 2224 else 2225 if Preprocess then 2226 Counter_Val := Counter_Val + 1; 2227 Has_Ctrl_Objs := True; 2228 2229 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then 2230 Last_Top_Level_Ctrl_Construct := Decl; 2231 end if; 2232 2233 else 2234 Process_Object_Declaration (Decl, Has_No_Init, Is_Protected); 2235 end if; 2236 end if; 2237 end Processing_Actions; 2238 2239 -- Start of processing for Process_Declarations 2240 2241 begin 2242 if No (Decls) or else Is_Empty_List (Decls) then 2243 return; 2244 end if; 2245 2246 -- Process all declarations in reverse order 2247 2248 Decl := Last_Non_Pragma (Decls); 2249 while Present (Decl) loop 2250 -- Depending on the value of flag Finalize_Old_Only we determine 2251 -- which objects get finalized as part of the current finalizer 2252 -- being built. 2253 2254 -- When True, only temporaries capturing the value of attribute 2255 -- 'Old are finalized and all other cases are ignored. 2256 2257 -- When False, temporary objects used to capture the value of 'Old 2258 -- are ignored and all others are considered. 2259 2260 if Finalize_Old_Only 2261 xor (Nkind (Decl) = N_Object_Declaration 2262 and then Stores_Attribute_Old_Prefix 2263 (Defining_Identifier (Decl))) 2264 then 2265 null; 2266 2267 -- Library-level tagged types 2268 2269 elsif Nkind (Decl) = N_Full_Type_Declaration then 2270 Typ := Defining_Identifier (Decl); 2271 2272 -- Ignored Ghost types do not need any cleanup actions because 2273 -- they will not appear in the final tree. 2274 2275 if Is_Ignored_Ghost_Entity (Typ) then 2276 null; 2277 2278 elsif Is_Tagged_Type (Typ) 2279 and then Is_Library_Level_Entity (Typ) 2280 and then Convention (Typ) = Convention_Ada 2281 and then Present (Access_Disp_Table (Typ)) 2282 and then RTE_Available (RE_Register_Tag) 2283 and then not Is_Abstract_Type (Typ) 2284 and then not No_Run_Time_Mode 2285 then 2286 Processing_Actions; 2287 end if; 2288 2289 -- Regular object declarations 2290 2291 elsif Nkind (Decl) = N_Object_Declaration then 2292 Obj_Id := Defining_Identifier (Decl); 2293 Obj_Typ := Base_Type (Etype (Obj_Id)); 2294 Expr := Expression (Decl); 2295 2296 -- Bypass any form of processing for objects which have their 2297 -- finalization disabled. This applies only to objects at the 2298 -- library level. 2299 2300 if For_Package and then Finalize_Storage_Only (Obj_Typ) then 2301 null; 2302 2303 -- Finalization of transient objects are treated separately in 2304 -- order to handle sensitive cases. These include: 2305 2306 -- * Aggregate expansion 2307 -- * If, case, and expression with actions expansion 2308 -- * Transient scopes 2309 2310 -- If one of those contexts has marked the transient object as 2311 -- ignored, do not generate finalization actions for it. 2312 2313 elsif Is_Finalized_Transient (Obj_Id) 2314 or else Is_Ignored_Transient (Obj_Id) 2315 then 2316 null; 2317 2318 -- Ignored Ghost objects do not need any cleanup actions 2319 -- because they will not appear in the final tree. 2320 2321 elsif Is_Ignored_Ghost_Entity (Obj_Id) then 2322 null; 2323 2324 -- The object is of the form: 2325 -- Obj : [constant] Typ [:= Expr]; 2326 2327 -- Do not process tag-to-class-wide conversions because they do 2328 -- not yield an object. Do not process the incomplete view of a 2329 -- deferred constant. Note that an object initialized by means 2330 -- of a build-in-place function call may appear as a deferred 2331 -- constant after expansion activities. These kinds of objects 2332 -- must be finalized. 2333 2334 elsif not Is_Imported (Obj_Id) 2335 and then Needs_Finalization (Obj_Typ) 2336 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id) 2337 and then not (Ekind (Obj_Id) = E_Constant 2338 and then not Has_Completion (Obj_Id) 2339 and then No (BIP_Initialization_Call (Obj_Id))) 2340 then 2341 Processing_Actions; 2342 2343 -- The object is of the form: 2344 -- Obj : Access_Typ := Non_BIP_Function_Call'reference; 2345 2346 -- Obj : Access_Typ := 2347 -- BIP_Function_Call (BIPalloc => 2, ...)'reference; 2348 2349 elsif Is_Access_Type (Obj_Typ) 2350 and then Needs_Finalization 2351 (Available_View (Designated_Type (Obj_Typ))) 2352 and then Present (Expr) 2353 and then 2354 (Is_Secondary_Stack_BIP_Func_Call (Expr) 2355 or else 2356 (Is_Non_BIP_Func_Call (Expr) 2357 and then not Is_Related_To_Func_Return (Obj_Id))) 2358 then 2359 Processing_Actions (Has_No_Init => True); 2360 2361 -- Processing for "hook" objects generated for transient 2362 -- objects declared inside an Expression_With_Actions. 2363 2364 elsif Is_Access_Type (Obj_Typ) 2365 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) 2366 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = 2367 N_Object_Declaration 2368 then 2369 Processing_Actions (Has_No_Init => True); 2370 2371 -- Process intermediate results of an if expression with one 2372 -- of the alternatives using a controlled function call. 2373 2374 elsif Is_Access_Type (Obj_Typ) 2375 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) 2376 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = 2377 N_Defining_Identifier 2378 and then Present (Expr) 2379 and then Nkind (Expr) = N_Null 2380 then 2381 Processing_Actions (Has_No_Init => True); 2382 2383 -- Simple protected objects which use type System.Tasking. 2384 -- Protected_Objects.Protection to manage their locks should 2385 -- be treated as controlled since they require manual cleanup. 2386 -- The only exception is illustrated in the following example: 2387 2388 -- package Pkg is 2389 -- type Ctrl is new Controlled ... 2390 -- procedure Finalize (Obj : in out Ctrl); 2391 -- Lib_Obj : Ctrl; 2392 -- end Pkg; 2393 2394 -- package body Pkg is 2395 -- protected Prot is 2396 -- procedure Do_Something (Obj : in out Ctrl); 2397 -- end Prot; 2398 2399 -- protected body Prot is 2400 -- procedure Do_Something (Obj : in out Ctrl) is ... 2401 -- end Prot; 2402 2403 -- procedure Finalize (Obj : in out Ctrl) is 2404 -- begin 2405 -- Prot.Do_Something (Obj); 2406 -- end Finalize; 2407 -- end Pkg; 2408 2409 -- Since for the most part entities in package bodies depend on 2410 -- those in package specs, Prot's lock should be cleaned up 2411 -- first. The subsequent cleanup of the spec finalizes Lib_Obj. 2412 -- This act however attempts to invoke Do_Something and fails 2413 -- because the lock has disappeared. 2414 2415 elsif Ekind (Obj_Id) = E_Variable 2416 and then not In_Library_Level_Package_Body (Obj_Id) 2417 and then (Is_Simple_Protected_Type (Obj_Typ) 2418 or else Has_Simple_Protected_Object (Obj_Typ)) 2419 then 2420 Processing_Actions (Is_Protected => True); 2421 end if; 2422 2423 -- Specific cases of object renamings 2424 2425 elsif Nkind (Decl) = N_Object_Renaming_Declaration then 2426 Obj_Id := Defining_Identifier (Decl); 2427 Obj_Typ := Base_Type (Etype (Obj_Id)); 2428 2429 -- Bypass any form of processing for objects which have their 2430 -- finalization disabled. This applies only to objects at the 2431 -- library level. 2432 2433 if For_Package and then Finalize_Storage_Only (Obj_Typ) then 2434 null; 2435 2436 -- Ignored Ghost object renamings do not need any cleanup 2437 -- actions because they will not appear in the final tree. 2438 2439 elsif Is_Ignored_Ghost_Entity (Obj_Id) then 2440 null; 2441 2442 -- Return object of a build-in-place function. This case is 2443 -- recognized and marked by the expansion of an extended return 2444 -- statement (see Expand_N_Extended_Return_Statement). 2445 2446 elsif Needs_Finalization (Obj_Typ) 2447 and then Is_Return_Object (Obj_Id) 2448 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) 2449 then 2450 Processing_Actions (Has_No_Init => True); 2451 2452 -- Detect a case where a source object has been initialized by 2453 -- a controlled function call or another object which was later 2454 -- rewritten as a class-wide conversion of Ada.Tags.Displace. 2455 2456 -- Obj1 : CW_Type := Src_Obj; 2457 -- Obj2 : CW_Type := Function_Call (...); 2458 2459 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj)); 2460 -- Tmp : ... := Function_Call (...)'reference; 2461 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp)); 2462 2463 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then 2464 Processing_Actions (Has_No_Init => True); 2465 end if; 2466 2467 -- Inspect the freeze node of an access-to-controlled type and 2468 -- look for a delayed finalization master. This case arises when 2469 -- the freeze actions are inserted at a later time than the 2470 -- expansion of the context. Since Build_Finalizer is never called 2471 -- on a single construct twice, the master will be ultimately 2472 -- left out and never finalized. This is also needed for freeze 2473 -- actions of designated types themselves, since in some cases the 2474 -- finalization master is associated with a designated type's 2475 -- freeze node rather than that of the access type (see handling 2476 -- for freeze actions in Build_Finalization_Master). 2477 2478 elsif Nkind (Decl) = N_Freeze_Entity 2479 and then Present (Actions (Decl)) 2480 then 2481 Typ := Entity (Decl); 2482 2483 -- Freeze nodes for ignored Ghost types do not need cleanup 2484 -- actions because they will never appear in the final tree. 2485 2486 if Is_Ignored_Ghost_Entity (Typ) then 2487 null; 2488 2489 elsif (Is_Access_Object_Type (Typ) 2490 and then Needs_Finalization 2491 (Available_View (Designated_Type (Typ)))) 2492 or else (Is_Type (Typ) and then Needs_Finalization (Typ)) 2493 then 2494 Old_Counter_Val := Counter_Val; 2495 2496 -- Freeze nodes are considered to be identical to packages 2497 -- and blocks in terms of nesting. The difference is that 2498 -- a finalization master created inside the freeze node is 2499 -- at the same nesting level as the node itself. 2500 2501 Process_Declarations (Actions (Decl), Preprocess); 2502 2503 -- The freeze node contains a finalization master 2504 2505 if Preprocess 2506 and then Top_Level 2507 and then No (Last_Top_Level_Ctrl_Construct) 2508 and then Counter_Val > Old_Counter_Val 2509 then 2510 Last_Top_Level_Ctrl_Construct := Decl; 2511 end if; 2512 end if; 2513 2514 -- Nested package declarations, avoid generics 2515 2516 elsif Nkind (Decl) = N_Package_Declaration then 2517 Pack_Id := Defining_Entity (Decl); 2518 Spec := Specification (Decl); 2519 2520 -- Do not inspect an ignored Ghost package because all code 2521 -- found within will not appear in the final tree. 2522 2523 if Is_Ignored_Ghost_Entity (Pack_Id) then 2524 null; 2525 2526 elsif Ekind (Pack_Id) /= E_Generic_Package then 2527 Old_Counter_Val := Counter_Val; 2528 Process_Declarations 2529 (Private_Declarations (Spec), Preprocess); 2530 Process_Declarations 2531 (Visible_Declarations (Spec), Preprocess); 2532 2533 -- Either the visible or the private declarations contain a 2534 -- controlled object. The nested package declaration is the 2535 -- last such construct. 2536 2537 if Preprocess 2538 and then Top_Level 2539 and then No (Last_Top_Level_Ctrl_Construct) 2540 and then Counter_Val > Old_Counter_Val 2541 then 2542 Last_Top_Level_Ctrl_Construct := Decl; 2543 end if; 2544 end if; 2545 2546 -- Nested package bodies, avoid generics 2547 2548 elsif Nkind (Decl) = N_Package_Body then 2549 2550 -- Do not inspect an ignored Ghost package body because all 2551 -- code found within will not appear in the final tree. 2552 2553 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then 2554 null; 2555 2556 elsif Ekind (Corresponding_Spec (Decl)) /= 2557 E_Generic_Package 2558 then 2559 Old_Counter_Val := Counter_Val; 2560 Process_Declarations (Declarations (Decl), Preprocess); 2561 2562 -- The nested package body is the last construct to contain 2563 -- a controlled object. 2564 2565 if Preprocess 2566 and then Top_Level 2567 and then No (Last_Top_Level_Ctrl_Construct) 2568 and then Counter_Val > Old_Counter_Val 2569 then 2570 Last_Top_Level_Ctrl_Construct := Decl; 2571 end if; 2572 end if; 2573 2574 -- Handle a rare case caused by a controlled transient object 2575 -- created as part of a record init proc. The variable is wrapped 2576 -- in a block, but the block is not associated with a transient 2577 -- scope. 2578 2579 elsif Nkind (Decl) = N_Block_Statement 2580 and then Inside_Init_Proc 2581 then 2582 Old_Counter_Val := Counter_Val; 2583 2584 if Present (Handled_Statement_Sequence (Decl)) then 2585 Process_Declarations 2586 (Statements (Handled_Statement_Sequence (Decl)), 2587 Preprocess); 2588 end if; 2589 2590 Process_Declarations (Declarations (Decl), Preprocess); 2591 2592 -- Either the declaration or statement list of the block has a 2593 -- controlled object. 2594 2595 if Preprocess 2596 and then Top_Level 2597 and then No (Last_Top_Level_Ctrl_Construct) 2598 and then Counter_Val > Old_Counter_Val 2599 then 2600 Last_Top_Level_Ctrl_Construct := Decl; 2601 end if; 2602 2603 -- Handle the case where the original context has been wrapped in 2604 -- a block to avoid interference between exception handlers and 2605 -- At_End handlers. Treat the block as transparent and process its 2606 -- contents. 2607 2608 elsif Nkind (Decl) = N_Block_Statement 2609 and then Is_Finalization_Wrapper (Decl) 2610 then 2611 if Present (Handled_Statement_Sequence (Decl)) then 2612 Process_Declarations 2613 (Statements (Handled_Statement_Sequence (Decl)), 2614 Preprocess); 2615 end if; 2616 2617 Process_Declarations (Declarations (Decl), Preprocess); 2618 end if; 2619 2620 Prev_Non_Pragma (Decl); 2621 end loop; 2622 end Process_Declarations; 2623 2624 -------------------------------- 2625 -- Process_Object_Declaration -- 2626 -------------------------------- 2627 2628 procedure Process_Object_Declaration 2629 (Decl : Node_Id; 2630 Has_No_Init : Boolean := False; 2631 Is_Protected : Boolean := False) 2632 is 2633 Loc : constant Source_Ptr := Sloc (Decl); 2634 Obj_Id : constant Entity_Id := Defining_Identifier (Decl); 2635 2636 Init_Typ : Entity_Id; 2637 -- The initialization type of the related object declaration. Note 2638 -- that this is not necessarily the same type as Obj_Typ because of 2639 -- possible type derivations. 2640 2641 Obj_Typ : Entity_Id; 2642 -- The type of the related object declaration 2643 2644 function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id; 2645 -- Func_Id denotes a build-in-place function. Generate the following 2646 -- cleanup code: 2647 -- 2648 -- if BIPallocfrom > Secondary_Stack'Pos 2649 -- and then BIPfinalizationmaster /= null 2650 -- then 2651 -- declare 2652 -- type Ptr_Typ is access Obj_Typ; 2653 -- for Ptr_Typ'Storage_Pool 2654 -- use Base_Pool (BIPfinalizationmaster); 2655 -- begin 2656 -- Free (Ptr_Typ (Temp)); 2657 -- end; 2658 -- end if; 2659 -- 2660 -- Obj_Typ is the type of the current object, Temp is the original 2661 -- allocation which Obj_Id renames. 2662 2663 procedure Find_Last_Init 2664 (Last_Init : out Node_Id; 2665 Body_Insert : out Node_Id); 2666 -- Find the last initialization call related to object declaration 2667 -- Decl. Last_Init denotes the last initialization call which follows 2668 -- Decl. Body_Insert denotes a node where the finalizer body could be 2669 -- potentially inserted after (if blocks are involved). 2670 2671 ----------------------------- 2672 -- Build_BIP_Cleanup_Stmts -- 2673 ----------------------------- 2674 2675 function Build_BIP_Cleanup_Stmts 2676 (Func_Id : Entity_Id) return Node_Id 2677 is 2678 Decls : constant List_Id := New_List; 2679 Fin_Mas_Id : constant Entity_Id := 2680 Build_In_Place_Formal 2681 (Func_Id, BIP_Finalization_Master); 2682 Func_Typ : constant Entity_Id := Etype (Func_Id); 2683 Temp_Id : constant Entity_Id := 2684 Entity (Prefix (Name (Parent (Obj_Id)))); 2685 2686 Cond : Node_Id; 2687 Free_Blk : Node_Id; 2688 Free_Stmt : Node_Id; 2689 Pool_Id : Entity_Id; 2690 Ptr_Typ : Entity_Id; 2691 2692 begin 2693 -- Generate: 2694 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all; 2695 2696 Pool_Id := Make_Temporary (Loc, 'P'); 2697 2698 Append_To (Decls, 2699 Make_Object_Renaming_Declaration (Loc, 2700 Defining_Identifier => Pool_Id, 2701 Subtype_Mark => 2702 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc), 2703 Name => 2704 Make_Explicit_Dereference (Loc, 2705 Prefix => 2706 Make_Function_Call (Loc, 2707 Name => 2708 New_Occurrence_Of (RTE (RE_Base_Pool), Loc), 2709 Parameter_Associations => New_List ( 2710 Make_Explicit_Dereference (Loc, 2711 Prefix => 2712 New_Occurrence_Of (Fin_Mas_Id, Loc))))))); 2713 2714 -- Create an access type which uses the storage pool of the 2715 -- caller's finalization master. 2716 2717 -- Generate: 2718 -- type Ptr_Typ is access Func_Typ; 2719 2720 Ptr_Typ := Make_Temporary (Loc, 'P'); 2721 2722 Append_To (Decls, 2723 Make_Full_Type_Declaration (Loc, 2724 Defining_Identifier => Ptr_Typ, 2725 Type_Definition => 2726 Make_Access_To_Object_Definition (Loc, 2727 Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc)))); 2728 2729 -- Perform minor decoration in order to set the master and the 2730 -- storage pool attributes. 2731 2732 Set_Ekind (Ptr_Typ, E_Access_Type); 2733 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); 2734 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); 2735 2736 if Debug_Generated_Code then 2737 Set_Debug_Info_Needed (Pool_Id); 2738 end if; 2739 2740 -- Create an explicit free statement. Note that the free uses the 2741 -- caller's pool expressed as a renaming. 2742 2743 Free_Stmt := 2744 Make_Free_Statement (Loc, 2745 Expression => 2746 Unchecked_Convert_To (Ptr_Typ, 2747 New_Occurrence_Of (Temp_Id, Loc))); 2748 2749 Set_Storage_Pool (Free_Stmt, Pool_Id); 2750 2751 -- Create a block to house the dummy type and the instantiation as 2752 -- well as to perform the cleanup the temporary. 2753 2754 -- Generate: 2755 -- declare 2756 -- <Decls> 2757 -- begin 2758 -- Free (Ptr_Typ (Temp_Id)); 2759 -- end; 2760 2761 Free_Blk := 2762 Make_Block_Statement (Loc, 2763 Declarations => Decls, 2764 Handled_Statement_Sequence => 2765 Make_Handled_Sequence_Of_Statements (Loc, 2766 Statements => New_List (Free_Stmt))); 2767 2768 -- Generate: 2769 -- if BIPfinalizationmaster /= null then 2770 2771 Cond := 2772 Make_Op_Ne (Loc, 2773 Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc), 2774 Right_Opnd => Make_Null (Loc)); 2775 2776 -- For constrained or tagged results escalate the condition to 2777 -- include the allocation format. Generate: 2778 2779 -- if BIPallocform > Secondary_Stack'Pos 2780 -- and then BIPfinalizationmaster /= null 2781 -- then 2782 2783 if not Is_Constrained (Func_Typ) 2784 or else Is_Tagged_Type (Func_Typ) 2785 then 2786 declare 2787 Alloc : constant Entity_Id := 2788 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); 2789 begin 2790 Cond := 2791 Make_And_Then (Loc, 2792 Left_Opnd => 2793 Make_Op_Gt (Loc, 2794 Left_Opnd => New_Occurrence_Of (Alloc, Loc), 2795 Right_Opnd => 2796 Make_Integer_Literal (Loc, 2797 UI_From_Int 2798 (BIP_Allocation_Form'Pos (Secondary_Stack)))), 2799 2800 Right_Opnd => Cond); 2801 end; 2802 end if; 2803 2804 -- Generate: 2805 -- if <Cond> then 2806 -- <Free_Blk> 2807 -- end if; 2808 2809 return 2810 Make_If_Statement (Loc, 2811 Condition => Cond, 2812 Then_Statements => New_List (Free_Blk)); 2813 end Build_BIP_Cleanup_Stmts; 2814 2815 -------------------- 2816 -- Find_Last_Init -- 2817 -------------------- 2818 2819 procedure Find_Last_Init 2820 (Last_Init : out Node_Id; 2821 Body_Insert : out Node_Id) 2822 is 2823 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id; 2824 -- Find the last initialization call within the statements of 2825 -- block Blk. 2826 2827 function Is_Init_Call (N : Node_Id) return Boolean; 2828 -- Determine whether node N denotes one of the initialization 2829 -- procedures of types Init_Typ or Obj_Typ. 2830 2831 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id; 2832 -- Obtain the next statement which follows list member Stmt while 2833 -- ignoring artifacts related to access-before-elaboration checks. 2834 2835 ----------------------------- 2836 -- Find_Last_Init_In_Block -- 2837 ----------------------------- 2838 2839 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is 2840 HSS : constant Node_Id := Handled_Statement_Sequence (Blk); 2841 Stmt : Node_Id; 2842 2843 begin 2844 -- Examine the individual statements of the block in reverse to 2845 -- locate the last initialization call. 2846 2847 if Present (HSS) and then Present (Statements (HSS)) then 2848 Stmt := Last (Statements (HSS)); 2849 while Present (Stmt) loop 2850 2851 -- Peek inside nested blocks in case aborts are allowed 2852 2853 if Nkind (Stmt) = N_Block_Statement then 2854 return Find_Last_Init_In_Block (Stmt); 2855 2856 elsif Is_Init_Call (Stmt) then 2857 return Stmt; 2858 end if; 2859 2860 Prev (Stmt); 2861 end loop; 2862 end if; 2863 2864 return Empty; 2865 end Find_Last_Init_In_Block; 2866 2867 ------------------ 2868 -- Is_Init_Call -- 2869 ------------------ 2870 2871 function Is_Init_Call (N : Node_Id) return Boolean is 2872 function Is_Init_Proc_Of 2873 (Subp_Id : Entity_Id; 2874 Typ : Entity_Id) return Boolean; 2875 -- Determine whether subprogram Subp_Id is a valid init proc of 2876 -- type Typ. 2877 2878 --------------------- 2879 -- Is_Init_Proc_Of -- 2880 --------------------- 2881 2882 function Is_Init_Proc_Of 2883 (Subp_Id : Entity_Id; 2884 Typ : Entity_Id) return Boolean 2885 is 2886 Deep_Init : Entity_Id := Empty; 2887 Prim_Init : Entity_Id := Empty; 2888 Type_Init : Entity_Id := Empty; 2889 2890 begin 2891 -- Obtain all possible initialization routines of the 2892 -- related type and try to match the subprogram entity 2893 -- against one of them. 2894 2895 -- Deep_Initialize 2896 2897 Deep_Init := TSS (Typ, TSS_Deep_Initialize); 2898 2899 -- Primitive Initialize 2900 2901 if Is_Controlled (Typ) then 2902 Prim_Init := Find_Optional_Prim_Op (Typ, Name_Initialize); 2903 2904 if Present (Prim_Init) then 2905 Prim_Init := Ultimate_Alias (Prim_Init); 2906 end if; 2907 end if; 2908 2909 -- Type initialization routine 2910 2911 if Has_Non_Null_Base_Init_Proc (Typ) then 2912 Type_Init := Base_Init_Proc (Typ); 2913 end if; 2914 2915 return 2916 (Present (Deep_Init) and then Subp_Id = Deep_Init) 2917 or else 2918 (Present (Prim_Init) and then Subp_Id = Prim_Init) 2919 or else 2920 (Present (Type_Init) and then Subp_Id = Type_Init); 2921 end Is_Init_Proc_Of; 2922 2923 -- Local variables 2924 2925 Call_Id : Entity_Id; 2926 2927 -- Start of processing for Is_Init_Call 2928 2929 begin 2930 if Nkind (N) = N_Procedure_Call_Statement 2931 and then Nkind (Name (N)) = N_Identifier 2932 then 2933 Call_Id := Entity (Name (N)); 2934 2935 -- Consider both the type of the object declaration and its 2936 -- related initialization type. 2937 2938 return 2939 Is_Init_Proc_Of (Call_Id, Init_Typ) 2940 or else 2941 Is_Init_Proc_Of (Call_Id, Obj_Typ); 2942 end if; 2943 2944 return False; 2945 end Is_Init_Call; 2946 2947 ----------------------------- 2948 -- Next_Suitable_Statement -- 2949 ----------------------------- 2950 2951 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is 2952 Result : Node_Id; 2953 2954 begin 2955 -- Skip call markers and Program_Error raises installed by the 2956 -- ABE mechanism. 2957 2958 Result := Next (Stmt); 2959 while Present (Result) loop 2960 exit when Nkind (Result) not in 2961 N_Call_Marker | N_Raise_Program_Error; 2962 2963 Next (Result); 2964 end loop; 2965 2966 return Result; 2967 end Next_Suitable_Statement; 2968 2969 -- Local variables 2970 2971 Call : Node_Id; 2972 Stmt : Node_Id; 2973 Stmt_2 : Node_Id; 2974 2975 Deep_Init_Found : Boolean := False; 2976 -- A flag set when a call to [Deep_]Initialize has been found 2977 2978 -- Start of processing for Find_Last_Init 2979 2980 begin 2981 Last_Init := Decl; 2982 Body_Insert := Empty; 2983 2984 -- Object renamings and objects associated with controlled 2985 -- function results do not require initialization. 2986 2987 if Has_No_Init then 2988 return; 2989 end if; 2990 2991 Stmt := Next_Suitable_Statement (Decl); 2992 2993 -- For an object with suppressed initialization, we check whether 2994 -- there is in fact no initialization expression. If there is not, 2995 -- then this is an object declaration that has been turned into a 2996 -- different object declaration that calls the build-in-place 2997 -- function in a 'Reference attribute, as in "F(...)'Reference". 2998 -- We search for that later object declaration, so that the 2999 -- Inc_Decl will be inserted after the call. Otherwise, if the 3000 -- call raises an exception, we will finalize the (uninitialized) 3001 -- object, which is wrong. 3002 3003 if No_Initialization (Decl) then 3004 if No (Expression (Last_Init)) then 3005 loop 3006 Next (Last_Init); 3007 exit when No (Last_Init); 3008 exit when Nkind (Last_Init) = N_Object_Declaration 3009 and then Nkind (Expression (Last_Init)) = N_Reference 3010 and then Nkind (Prefix (Expression (Last_Init))) = 3011 N_Function_Call 3012 and then Is_Expanded_Build_In_Place_Call 3013 (Prefix (Expression (Last_Init))); 3014 end loop; 3015 end if; 3016 3017 return; 3018 3019 -- In all other cases the initialization calls follow the related 3020 -- object. The general structure of object initialization built by 3021 -- routine Default_Initialize_Object is as follows: 3022 3023 -- [begin -- aborts allowed 3024 -- Abort_Defer;] 3025 -- Type_Init_Proc (Obj); 3026 -- [begin] -- exceptions allowed 3027 -- Deep_Initialize (Obj); 3028 -- [exception -- exceptions allowed 3029 -- when others => 3030 -- Deep_Finalize (Obj, Self => False); 3031 -- raise; 3032 -- end;] 3033 -- [at end -- aborts allowed 3034 -- Abort_Undefer; 3035 -- end;] 3036 3037 -- When aborts are allowed, the initialization calls are housed 3038 -- within a block. 3039 3040 elsif Nkind (Stmt) = N_Block_Statement then 3041 Last_Init := Find_Last_Init_In_Block (Stmt); 3042 Body_Insert := Stmt; 3043 3044 -- Otherwise the initialization calls follow the related object 3045 3046 else 3047 Stmt_2 := Next_Suitable_Statement (Stmt); 3048 3049 -- Check for an optional call to Deep_Initialize which may 3050 -- appear within a block depending on whether the object has 3051 -- controlled components. 3052 3053 if Present (Stmt_2) then 3054 if Nkind (Stmt_2) = N_Block_Statement then 3055 Call := Find_Last_Init_In_Block (Stmt_2); 3056 3057 if Present (Call) then 3058 Deep_Init_Found := True; 3059 Last_Init := Call; 3060 Body_Insert := Stmt_2; 3061 end if; 3062 3063 elsif Is_Init_Call (Stmt_2) then 3064 Deep_Init_Found := True; 3065 Last_Init := Stmt_2; 3066 Body_Insert := Last_Init; 3067 end if; 3068 end if; 3069 3070 -- If the object lacks a call to Deep_Initialize, then it must 3071 -- have a call to its related type init proc. 3072 3073 if not Deep_Init_Found and then Is_Init_Call (Stmt) then 3074 Last_Init := Stmt; 3075 Body_Insert := Last_Init; 3076 end if; 3077 end if; 3078 end Find_Last_Init; 3079 3080 -- Local variables 3081 3082 Body_Ins : Node_Id; 3083 Count_Ins : Node_Id; 3084 Fin_Call : Node_Id; 3085 Fin_Stmts : List_Id := No_List; 3086 Inc_Decl : Node_Id; 3087 Label : Node_Id; 3088 Label_Id : Entity_Id; 3089 Obj_Ref : Node_Id; 3090 3091 -- Start of processing for Process_Object_Declaration 3092 3093 begin 3094 -- Handle the object type and the reference to the object 3095 3096 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); 3097 Obj_Typ := Base_Type (Etype (Obj_Id)); 3098 3099 loop 3100 if Is_Access_Type (Obj_Typ) then 3101 Obj_Typ := Directly_Designated_Type (Obj_Typ); 3102 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); 3103 3104 elsif Is_Concurrent_Type (Obj_Typ) 3105 and then Present (Corresponding_Record_Type (Obj_Typ)) 3106 then 3107 Obj_Typ := Corresponding_Record_Type (Obj_Typ); 3108 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); 3109 3110 elsif Is_Private_Type (Obj_Typ) 3111 and then Present (Full_View (Obj_Typ)) 3112 then 3113 Obj_Typ := Full_View (Obj_Typ); 3114 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); 3115 3116 elsif Obj_Typ /= Base_Type (Obj_Typ) then 3117 Obj_Typ := Base_Type (Obj_Typ); 3118 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); 3119 3120 else 3121 exit; 3122 end if; 3123 end loop; 3124 3125 Set_Etype (Obj_Ref, Obj_Typ); 3126 3127 -- Handle the initialization type of the object declaration 3128 3129 Init_Typ := Obj_Typ; 3130 loop 3131 if Is_Private_Type (Init_Typ) 3132 and then Present (Full_View (Init_Typ)) 3133 then 3134 Init_Typ := Full_View (Init_Typ); 3135 3136 elsif Is_Untagged_Derivation (Init_Typ) then 3137 Init_Typ := Root_Type (Init_Typ); 3138 3139 else 3140 exit; 3141 end if; 3142 end loop; 3143 3144 -- Set a new value for the state counter and insert the statement 3145 -- after the object declaration. Generate: 3146 3147 -- Counter := <value>; 3148 3149 Inc_Decl := 3150 Make_Assignment_Statement (Loc, 3151 Name => New_Occurrence_Of (Counter_Id, Loc), 3152 Expression => Make_Integer_Literal (Loc, Counter_Val)); 3153 3154 -- Insert the counter after all initialization has been done. The 3155 -- place of insertion depends on the context. 3156 3157 if Ekind (Obj_Id) in E_Constant | E_Variable then 3158 3159 -- The object is initialized by a build-in-place function call. 3160 -- The counter insertion point is after the function call. 3161 3162 if Present (BIP_Initialization_Call (Obj_Id)) then 3163 Count_Ins := BIP_Initialization_Call (Obj_Id); 3164 Body_Ins := Empty; 3165 3166 -- The object is initialized by an aggregate. Insert the counter 3167 -- after the last aggregate assignment. 3168 3169 elsif Present (Last_Aggregate_Assignment (Obj_Id)) then 3170 Count_Ins := Last_Aggregate_Assignment (Obj_Id); 3171 Body_Ins := Empty; 3172 3173 -- In all other cases the counter is inserted after the last call 3174 -- to either [Deep_]Initialize or the type-specific init proc. 3175 3176 else 3177 Find_Last_Init (Count_Ins, Body_Ins); 3178 end if; 3179 3180 -- In all other cases the counter is inserted after the last call to 3181 -- either [Deep_]Initialize or the type-specific init proc. 3182 3183 else 3184 Find_Last_Init (Count_Ins, Body_Ins); 3185 end if; 3186 3187 -- If the Initialize function is null or trivial, the call will have 3188 -- been replaced with a null statement, in which case place counter 3189 -- declaration after object declaration itself. 3190 3191 if No (Count_Ins) then 3192 Count_Ins := Decl; 3193 end if; 3194 3195 Insert_After (Count_Ins, Inc_Decl); 3196 Analyze (Inc_Decl); 3197 3198 -- If the current declaration is the last in the list, the finalizer 3199 -- body needs to be inserted after the set counter statement for the 3200 -- current object declaration. This is complicated by the fact that 3201 -- the set counter statement may appear in abort deferred block. In 3202 -- that case, the proper insertion place is after the block. 3203 3204 if No (Finalizer_Insert_Nod) then 3205 3206 -- Insertion after an abort deferred block 3207 3208 if Present (Body_Ins) then 3209 Finalizer_Insert_Nod := Body_Ins; 3210 else 3211 Finalizer_Insert_Nod := Inc_Decl; 3212 end if; 3213 end if; 3214 3215 -- Create the associated label with this object, generate: 3216 3217 -- L<counter> : label; 3218 3219 Label_Id := 3220 Make_Identifier (Loc, New_External_Name ('L', Counter_Val)); 3221 Set_Entity 3222 (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id))); 3223 Label := Make_Label (Loc, Label_Id); 3224 3225 Prepend_To (Finalizer_Decls, 3226 Make_Implicit_Label_Declaration (Loc, 3227 Defining_Identifier => Entity (Label_Id), 3228 Label_Construct => Label)); 3229 3230 -- Create the associated jump with this object, generate: 3231 3232 -- when <counter> => 3233 -- goto L<counter>; 3234 3235 Prepend_To (Jump_Alts, 3236 Make_Case_Statement_Alternative (Loc, 3237 Discrete_Choices => New_List ( 3238 Make_Integer_Literal (Loc, Counter_Val)), 3239 Statements => New_List ( 3240 Make_Goto_Statement (Loc, 3241 Name => New_Occurrence_Of (Entity (Label_Id), Loc))))); 3242 3243 -- Insert the jump destination, generate: 3244 3245 -- <<L<counter>>> 3246 3247 Append_To (Finalizer_Stmts, Label); 3248 3249 -- Disable warnings on Obj_Id. This works around an issue where GCC 3250 -- is not able to detect that Obj_Id is protected by a counter and 3251 -- emits spurious warnings. 3252 3253 if not Comes_From_Source (Obj_Id) then 3254 Set_Warnings_Off (Obj_Id); 3255 end if; 3256 3257 -- Processing for simple protected objects. Such objects require 3258 -- manual finalization of their lock managers. 3259 3260 if Is_Protected then 3261 if Is_Simple_Protected_Type (Obj_Typ) then 3262 Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref); 3263 3264 if Present (Fin_Call) then 3265 Fin_Stmts := New_List (Fin_Call); 3266 end if; 3267 3268 elsif Has_Simple_Protected_Object (Obj_Typ) then 3269 if Is_Record_Type (Obj_Typ) then 3270 Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ); 3271 elsif Is_Array_Type (Obj_Typ) then 3272 Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ); 3273 end if; 3274 end if; 3275 3276 -- Generate: 3277 -- begin 3278 -- System.Tasking.Protected_Objects.Finalize_Protection 3279 -- (Obj._object); 3280 3281 -- exception 3282 -- when others => 3283 -- null; 3284 -- end; 3285 3286 if Present (Fin_Stmts) and then Exceptions_OK then 3287 Fin_Stmts := New_List ( 3288 Make_Block_Statement (Loc, 3289 Handled_Statement_Sequence => 3290 Make_Handled_Sequence_Of_Statements (Loc, 3291 Statements => Fin_Stmts, 3292 3293 Exception_Handlers => New_List ( 3294 Make_Exception_Handler (Loc, 3295 Exception_Choices => New_List ( 3296 Make_Others_Choice (Loc)), 3297 3298 Statements => New_List ( 3299 Make_Null_Statement (Loc))))))); 3300 end if; 3301 3302 -- Processing for regular controlled objects 3303 3304 else 3305 -- Generate: 3306 -- begin 3307 -- [Deep_]Finalize (Obj); 3308 3309 -- exception 3310 -- when Id : others => 3311 -- if not Raised then 3312 -- Raised := True; 3313 -- Save_Occurrence (E, Id); 3314 -- end if; 3315 -- end; 3316 3317 Fin_Call := 3318 Make_Final_Call ( 3319 Obj_Ref => Obj_Ref, 3320 Typ => Obj_Typ); 3321 3322 -- Guard against a missing [Deep_]Finalize when the object type 3323 -- was not properly frozen. 3324 3325 if No (Fin_Call) then 3326 Fin_Call := Make_Null_Statement (Loc); 3327 end if; 3328 3329 -- For CodePeer, the exception handlers normally generated here 3330 -- generate complex flowgraphs which result in capacity problems. 3331 -- Omitting these handlers for CodePeer is justified as follows: 3332 3333 -- If a handler is dead, then omitting it is surely ok 3334 3335 -- If a handler is live, then CodePeer should flag the 3336 -- potentially-exception-raising construct that causes it 3337 -- to be live. That is what we are interested in, not what 3338 -- happens after the exception is raised. 3339 3340 if Exceptions_OK and not CodePeer_Mode then 3341 Fin_Stmts := New_List ( 3342 Make_Block_Statement (Loc, 3343 Handled_Statement_Sequence => 3344 Make_Handled_Sequence_Of_Statements (Loc, 3345 Statements => New_List (Fin_Call), 3346 3347 Exception_Handlers => New_List ( 3348 Build_Exception_Handler 3349 (Finalizer_Data, For_Package))))); 3350 3351 -- When exception handlers are prohibited, the finalization call 3352 -- appears unprotected. Any exception raised during finalization 3353 -- will bypass the circuitry which ensures the cleanup of all 3354 -- remaining objects. 3355 3356 else 3357 Fin_Stmts := New_List (Fin_Call); 3358 end if; 3359 3360 -- If we are dealing with a return object of a build-in-place 3361 -- function, generate the following cleanup statements: 3362 3363 -- if BIPallocfrom > Secondary_Stack'Pos 3364 -- and then BIPfinalizationmaster /= null 3365 -- then 3366 -- declare 3367 -- type Ptr_Typ is access Obj_Typ; 3368 -- for Ptr_Typ'Storage_Pool use 3369 -- Base_Pool (BIPfinalizationmaster.all).all; 3370 -- begin 3371 -- Free (Ptr_Typ (Temp)); 3372 -- end; 3373 -- end if; 3374 3375 -- The generated code effectively detaches the temporary from the 3376 -- caller finalization master and deallocates the object. 3377 3378 if Is_Return_Object (Obj_Id) then 3379 declare 3380 Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id); 3381 begin 3382 if Is_Build_In_Place_Function (Func_Id) 3383 and then Needs_BIP_Finalization_Master (Func_Id) 3384 then 3385 Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id)); 3386 end if; 3387 end; 3388 end if; 3389 3390 if Ekind (Obj_Id) in E_Constant | E_Variable 3391 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) 3392 then 3393 -- Temporaries created for the purpose of "exporting" a 3394 -- transient object out of an Expression_With_Actions (EWA) 3395 -- need guards. The following illustrates the usage of such 3396 -- temporaries. 3397 3398 -- Access_Typ : access [all] Obj_Typ; 3399 -- Temp : Access_Typ := null; 3400 -- <Counter> := ...; 3401 3402 -- do 3403 -- Ctrl_Trans : [access [all]] Obj_Typ := ...; 3404 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer 3405 -- <or> 3406 -- Temp := Ctrl_Trans'Unchecked_Access; 3407 -- in ... end; 3408 3409 -- The finalization machinery does not process EWA nodes as 3410 -- this may lead to premature finalization of expressions. Note 3411 -- that Temp is marked as being properly initialized regardless 3412 -- of whether the initialization of Ctrl_Trans succeeded. Since 3413 -- a failed initialization may leave Temp with a value of null, 3414 -- add a guard to handle this case: 3415 3416 -- if Obj /= null then 3417 -- <object finalization statements> 3418 -- end if; 3419 3420 if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = 3421 N_Object_Declaration 3422 then 3423 Fin_Stmts := New_List ( 3424 Make_If_Statement (Loc, 3425 Condition => 3426 Make_Op_Ne (Loc, 3427 Left_Opnd => New_Occurrence_Of (Obj_Id, Loc), 3428 Right_Opnd => Make_Null (Loc)), 3429 Then_Statements => Fin_Stmts)); 3430 3431 -- Return objects use a flag to aid in processing their 3432 -- potential finalization when the enclosing function fails 3433 -- to return properly. Generate: 3434 3435 -- if not Flag then 3436 -- <object finalization statements> 3437 -- end if; 3438 3439 else 3440 Fin_Stmts := New_List ( 3441 Make_If_Statement (Loc, 3442 Condition => 3443 Make_Op_Not (Loc, 3444 Right_Opnd => 3445 New_Occurrence_Of 3446 (Status_Flag_Or_Transient_Decl (Obj_Id), Loc)), 3447 3448 Then_Statements => Fin_Stmts)); 3449 end if; 3450 end if; 3451 end if; 3452 3453 Append_List_To (Finalizer_Stmts, Fin_Stmts); 3454 3455 -- Since the declarations are examined in reverse, the state counter 3456 -- must be decremented in order to keep with the true position of 3457 -- objects. 3458 3459 Counter_Val := Counter_Val - 1; 3460 end Process_Object_Declaration; 3461 3462 ------------------------------------- 3463 -- Process_Tagged_Type_Declaration -- 3464 ------------------------------------- 3465 3466 procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is 3467 Typ : constant Entity_Id := Defining_Identifier (Decl); 3468 DT_Ptr : constant Entity_Id := 3469 Node (First_Elmt (Access_Disp_Table (Typ))); 3470 begin 3471 -- Generate: 3472 -- Ada.Tags.Unregister_Tag (<Typ>P); 3473 3474 Append_To (Tagged_Type_Stmts, 3475 Make_Procedure_Call_Statement (Loc, 3476 Name => 3477 New_Occurrence_Of (RTE (RE_Unregister_Tag), Loc), 3478 Parameter_Associations => New_List ( 3479 New_Occurrence_Of (DT_Ptr, Loc)))); 3480 end Process_Tagged_Type_Declaration; 3481 3482 -- Start of processing for Build_Finalizer_Helper 3483 3484 begin 3485 Fin_Id := Empty; 3486 3487 -- Do not perform this expansion in SPARK mode because it is not 3488 -- necessary. 3489 3490 if GNATprove_Mode then 3491 return; 3492 end if; 3493 3494 -- Step 1: Extract all lists which may contain controlled objects or 3495 -- library-level tagged types. 3496 3497 if For_Package_Spec then 3498 Decls := Visible_Declarations (Specification (N)); 3499 Priv_Decls := Private_Declarations (Specification (N)); 3500 3501 -- Retrieve the package spec id 3502 3503 Spec_Id := Defining_Unit_Name (Specification (N)); 3504 3505 if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then 3506 Spec_Id := Defining_Identifier (Spec_Id); 3507 end if; 3508 3509 -- Accept statement, block, entry body, package body, protected body, 3510 -- subprogram body or task body. 3511 3512 else 3513 Decls := Declarations (N); 3514 HSS := Handled_Statement_Sequence (N); 3515 3516 if Present (HSS) then 3517 if Present (Statements (HSS)) then 3518 Stmts := Statements (HSS); 3519 end if; 3520 3521 if Present (At_End_Proc (HSS)) then 3522 Prev_At_End := At_End_Proc (HSS); 3523 end if; 3524 end if; 3525 3526 -- Retrieve the package spec id for package bodies 3527 3528 if For_Package_Body then 3529 Spec_Id := Corresponding_Spec (N); 3530 end if; 3531 end if; 3532 3533 -- Do not process nested packages since those are handled by the 3534 -- enclosing scope's finalizer. Do not process non-expanded package 3535 -- instantiations since those will be re-analyzed and re-expanded. 3536 3537 if For_Package 3538 and then 3539 (not Is_Library_Level_Entity (Spec_Id) 3540 3541 -- Nested packages are considered to be library level entities, 3542 -- but do not need to be processed separately. True library level 3543 -- packages have a scope value of 1. 3544 3545 or else Scope_Depth_Value (Spec_Id) /= Uint_1 3546 or else (Is_Generic_Instance (Spec_Id) 3547 and then Package_Instantiation (Spec_Id) /= N)) 3548 then 3549 return; 3550 end if; 3551 3552 -- Step 2: Object [pre]processing 3553 3554 if For_Package then 3555 3556 -- Preprocess the visible declarations now in order to obtain the 3557 -- correct number of controlled object by the time the private 3558 -- declarations are processed. 3559 3560 Process_Declarations (Decls, Preprocess => True, Top_Level => True); 3561 3562 -- From all the possible contexts, only package specifications may 3563 -- have private declarations. 3564 3565 if For_Package_Spec then 3566 Process_Declarations 3567 (Priv_Decls, Preprocess => True, Top_Level => True); 3568 end if; 3569 3570 -- The current context may lack controlled objects, but require some 3571 -- other form of completion (task termination for instance). In such 3572 -- cases, the finalizer must be created and carry the additional 3573 -- statements. 3574 3575 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then 3576 Build_Components; 3577 end if; 3578 3579 -- The preprocessing has determined that the context has controlled 3580 -- objects or library-level tagged types. 3581 3582 if Has_Ctrl_Objs or Has_Tagged_Types then 3583 3584 -- Private declarations are processed first in order to preserve 3585 -- possible dependencies between public and private objects. 3586 3587 if For_Package_Spec then 3588 Process_Declarations (Priv_Decls); 3589 end if; 3590 3591 Process_Declarations (Decls); 3592 end if; 3593 3594 -- Non-package case 3595 3596 else 3597 -- Preprocess both declarations and statements 3598 3599 Process_Declarations (Decls, Preprocess => True, Top_Level => True); 3600 Process_Declarations (Stmts, Preprocess => True, Top_Level => True); 3601 3602 -- At this point it is known that N has controlled objects. Ensure 3603 -- that N has a declarative list since the finalizer spec will be 3604 -- attached to it. 3605 3606 if Has_Ctrl_Objs and then No (Decls) then 3607 Set_Declarations (N, New_List); 3608 Decls := Declarations (N); 3609 Spec_Decls := Decls; 3610 end if; 3611 3612 -- The current context may lack controlled objects, but require some 3613 -- other form of completion (task termination for instance). In such 3614 -- cases, the finalizer must be created and carry the additional 3615 -- statements. 3616 3617 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then 3618 Build_Components; 3619 end if; 3620 3621 if Has_Ctrl_Objs or Has_Tagged_Types then 3622 Process_Declarations (Stmts); 3623 Process_Declarations (Decls); 3624 end if; 3625 end if; 3626 3627 -- Step 3: Finalizer creation 3628 3629 if Acts_As_Clean or else Has_Ctrl_Objs or else Has_Tagged_Types then 3630 Create_Finalizer; 3631 end if; 3632 end Build_Finalizer_Helper; 3633 3634 -------------------------- 3635 -- Build_Finalizer_Call -- 3636 -------------------------- 3637 3638 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is 3639 Is_Prot_Body : constant Boolean := 3640 Nkind (N) = N_Subprogram_Body 3641 and then Is_Protected_Subprogram_Body (N); 3642 -- Determine whether N denotes the protected version of a subprogram 3643 -- which belongs to a protected type. 3644 3645 Loc : constant Source_Ptr := Sloc (N); 3646 HSS : Node_Id; 3647 3648 begin 3649 -- Do not perform this expansion in SPARK mode because we do not create 3650 -- finalizers in the first place. 3651 3652 if GNATprove_Mode then 3653 return; 3654 end if; 3655 3656 -- The At_End handler should have been assimilated by the finalizer 3657 3658 HSS := Handled_Statement_Sequence (N); 3659 pragma Assert (No (At_End_Proc (HSS))); 3660 3661 -- If the construct to be cleaned up is a protected subprogram body, the 3662 -- finalizer call needs to be associated with the block which wraps the 3663 -- unprotected version of the subprogram. The following illustrates this 3664 -- scenario: 3665 3666 -- procedure Prot_SubpP is 3667 -- procedure finalizer is 3668 -- begin 3669 -- Service_Entries (Prot_Obj); 3670 -- Abort_Undefer; 3671 -- end finalizer; 3672 3673 -- begin 3674 -- . . . 3675 -- begin 3676 -- Prot_SubpN (Prot_Obj); 3677 -- at end 3678 -- finalizer; 3679 -- end; 3680 -- end Prot_SubpP; 3681 3682 if Is_Prot_Body then 3683 HSS := Handled_Statement_Sequence (Last (Statements (HSS))); 3684 3685 -- An At_End handler and regular exception handlers cannot coexist in 3686 -- the same statement sequence. Wrap the original statements in a block. 3687 3688 elsif Present (Exception_Handlers (HSS)) then 3689 declare 3690 End_Lab : constant Node_Id := End_Label (HSS); 3691 Block : Node_Id; 3692 3693 begin 3694 Block := 3695 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS); 3696 3697 Set_Handled_Statement_Sequence (N, 3698 Make_Handled_Sequence_Of_Statements (Loc, New_List (Block))); 3699 3700 HSS := Handled_Statement_Sequence (N); 3701 Set_End_Label (HSS, End_Lab); 3702 end; 3703 end if; 3704 3705 Set_At_End_Proc (HSS, New_Occurrence_Of (Fin_Id, Loc)); 3706 3707 -- Attach reference to finalizer to tree, for LLVM use 3708 3709 Set_Parent (At_End_Proc (HSS), HSS); 3710 3711 Analyze (At_End_Proc (HSS)); 3712 Expand_At_End_Handler (HSS, Empty); 3713 end Build_Finalizer_Call; 3714 3715 --------------------- 3716 -- Build_Finalizer -- 3717 --------------------- 3718 3719 procedure Build_Finalizer 3720 (N : Node_Id; 3721 Clean_Stmts : List_Id; 3722 Mark_Id : Entity_Id; 3723 Top_Decls : List_Id; 3724 Defer_Abort : Boolean; 3725 Fin_Id : out Entity_Id) 3726 is 3727 Def_Ent : constant Entity_Id := Unique_Defining_Entity (N); 3728 Loc : constant Source_Ptr := Sloc (N); 3729 3730 -- Declarations used for the creation of _finalization_controller 3731 3732 Fin_Old_Id : Entity_Id := Empty; 3733 Fin_Controller_Id : Entity_Id := Empty; 3734 Fin_Controller_Decls : List_Id; 3735 Fin_Controller_Stmts : List_Id; 3736 Fin_Controller_Body : Node_Id := Empty; 3737 Fin_Controller_Spec : Node_Id := Empty; 3738 Postconditions_Call : Node_Id := Empty; 3739 3740 -- Defining identifiers for local objects used to store exception info 3741 3742 Raised_Post_Exception_Id : Entity_Id := Empty; 3743 Raised_Finalization_Exception_Id : Entity_Id := Empty; 3744 Saved_Exception_Id : Entity_Id := Empty; 3745 3746 -- Start of processing for Build_Finalizer 3747 3748 begin 3749 -- Create the general finalization routine 3750 3751 Build_Finalizer_Helper 3752 (N => N, 3753 Clean_Stmts => Clean_Stmts, 3754 Mark_Id => Mark_Id, 3755 Top_Decls => Top_Decls, 3756 Defer_Abort => Defer_Abort, 3757 Fin_Id => Fin_Id, 3758 Finalize_Old_Only => False); 3759 3760 -- When postconditions are present, expansion gets much more complicated 3761 -- due to both the fact that they must be called after finalization and 3762 -- that finalization of 'Old objects must occur after the postconditions 3763 -- get checked. 3764 3765 -- Additionally, exceptions between general finalization and 'Old 3766 -- finalization must be propagated correctly and exceptions which happen 3767 -- during _postconditions need to be saved and reraised after 3768 -- finalization of 'Old objects. 3769 3770 -- Generate: 3771 -- 3772 -- Postcond_Enabled := False; 3773 -- 3774 -- procedure _finalization_controller is 3775 -- 3776 -- -- Exception capturing and tracking 3777 -- 3778 -- Saved_Exception : Exception_Occurrence; 3779 -- Raised_Post_Exception : Boolean := False; 3780 -- Raised_Finalization_Exception : Boolean := False; 3781 -- 3782 -- -- Start of processing for _finalization_controller 3783 -- 3784 -- begin 3785 -- -- Perform general finalization 3786 -- 3787 -- begin 3788 -- _finalizer; 3789 -- exception 3790 -- when others => 3791 -- -- Save the exception 3792 -- 3793 -- Raised_Finalization_Exception := True; 3794 -- Save_Occurrence 3795 -- (Saved_Exception, Get_Current_Excep.all); 3796 -- end; 3797 -- 3798 -- -- Perform postcondition checks after general finalization, but 3799 -- -- before finalization of 'Old related objects. 3800 -- 3801 -- if not Raised_Finalization_Exception then 3802 -- begin 3803 -- -- Re-enable postconditions and check them 3804 -- 3805 -- Postcond_Enabled := True; 3806 -- _postconditions [(Result_Obj_For_Postcond[.all])]; 3807 -- exception 3808 -- when others => 3809 -- -- Save the exception 3810 -- 3811 -- Raised_Post_Exception := True; 3812 -- Save_Occurrence 3813 -- (Saved_Exception, Get_Current_Excep.all); 3814 -- end; 3815 -- end if; 3816 -- 3817 -- -- Finally finalize 'Old related objects 3818 -- 3819 -- begin 3820 -- _finalizer_old; 3821 -- exception 3822 -- when others => 3823 -- -- Reraise the previous finalization error if there is 3824 -- -- one. 3825 -- 3826 -- if Raised_Finalization_Exception then 3827 -- Reraise_Occurrence (Saved_Exception); 3828 -- end if; 3829 -- 3830 -- -- Otherwise, reraise the current one 3831 -- 3832 -- raise; 3833 -- end; 3834 -- 3835 -- -- Reraise any saved exception 3836 -- 3837 -- if Raised_Finalization_Exception 3838 -- or else Raised_Post_Exception 3839 -- then 3840 -- Reraise_Occurrence (Saved_Exception); 3841 -- end if; 3842 -- end _finalization_controller; 3843 3844 if Nkind (N) = N_Subprogram_Body 3845 and then Present (Postconditions_Proc (Def_Ent)) 3846 then 3847 Fin_Controller_Stmts := New_List; 3848 Fin_Controller_Decls := New_List; 3849 3850 -- Build the 'Old finalizer 3851 3852 Build_Finalizer_Helper 3853 (N => N, 3854 Clean_Stmts => Empty_List, 3855 Mark_Id => Mark_Id, 3856 Top_Decls => Top_Decls, 3857 Defer_Abort => Defer_Abort, 3858 Fin_Id => Fin_Old_Id, 3859 Finalize_Old_Only => True); 3860 3861 -- Create local declarations for _finalization_controller needed for 3862 -- saving exceptions. 3863 -- 3864 -- Generate: 3865 -- 3866 -- Saved_Exception : Exception_Occurrence; 3867 -- Raised_Post_Exception : Boolean := False; 3868 -- Raised_Finalization_Exception : Boolean := False; 3869 3870 Saved_Exception_Id := Make_Temporary (Loc, 'S'); 3871 Raised_Post_Exception_Id := Make_Temporary (Loc, 'P'); 3872 Raised_Finalization_Exception_Id := Make_Temporary (Loc, 'F'); 3873 3874 Append_List_To (Fin_Controller_Decls, New_List ( 3875 Make_Object_Declaration (Loc, 3876 Defining_Identifier => Saved_Exception_Id, 3877 Object_Definition => 3878 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)), 3879 Make_Object_Declaration (Loc, 3880 Defining_Identifier => Raised_Post_Exception_Id, 3881 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 3882 Expression => New_Occurrence_Of (Standard_False, Loc)), 3883 Make_Object_Declaration (Loc, 3884 Defining_Identifier => Raised_Finalization_Exception_Id, 3885 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 3886 Expression => New_Occurrence_Of (Standard_False, Loc)))); 3887 3888 -- Call _finalizer and save any exceptions which occur 3889 3890 -- Generate: 3891 -- 3892 -- begin 3893 -- _finalizer; 3894 -- exception 3895 -- when others => 3896 -- Raised_Finalization_Exception := True; 3897 -- Save_Occurrence 3898 -- (Saved_Exception, Get_Current_Excep.all); 3899 -- end; 3900 3901 if Present (Fin_Id) then 3902 Append_To (Fin_Controller_Stmts, 3903 Make_Block_Statement (Loc, 3904 Handled_Statement_Sequence => 3905 Make_Handled_Sequence_Of_Statements (Loc, 3906 Statements => New_List ( 3907 Make_Procedure_Call_Statement (Loc, 3908 Name => New_Occurrence_Of (Fin_Id, Loc))), 3909 Exception_Handlers => New_List ( 3910 Make_Exception_Handler (Loc, 3911 Exception_Choices => New_List ( 3912 Make_Others_Choice (Loc)), 3913 Statements => New_List ( 3914 Make_Assignment_Statement (Loc, 3915 Name => 3916 New_Occurrence_Of 3917 (Raised_Finalization_Exception_Id, Loc), 3918 Expression => 3919 New_Occurrence_Of (Standard_True, Loc)), 3920 Make_Procedure_Call_Statement (Loc, 3921 Name => 3922 New_Occurrence_Of 3923 (RTE (RE_Save_Occurrence), Loc), 3924 Parameter_Associations => New_List ( 3925 New_Occurrence_Of 3926 (Saved_Exception_Id, Loc), 3927 Make_Explicit_Dereference (Loc, 3928 Prefix => 3929 Make_Function_Call (Loc, 3930 Name => 3931 Make_Explicit_Dereference (Loc, 3932 Prefix => 3933 New_Occurrence_Of 3934 (RTE (RE_Get_Current_Excep), 3935 Loc)))))))))))); 3936 end if; 3937 3938 -- Create the call to postconditions based on the kind of the current 3939 -- subprogram, and the type of the Result_Obj_For_Postcond. 3940 3941 -- Generate: 3942 -- 3943 -- _postconditions (Result_Obj_For_Postcond[.all]); 3944 -- 3945 -- or 3946 -- 3947 -- _postconditions; 3948 3949 if Ekind (Def_Ent) = E_Procedure then 3950 Postconditions_Call := 3951 Make_Procedure_Call_Statement (Loc, 3952 Name => 3953 New_Occurrence_Of 3954 (Postconditions_Proc (Def_Ent), Loc)); 3955 else 3956 Postconditions_Call := 3957 Make_Procedure_Call_Statement (Loc, 3958 Name => 3959 New_Occurrence_Of 3960 (Postconditions_Proc (Def_Ent), Loc), 3961 Parameter_Associations => New_List ( 3962 (if Is_Elementary_Type (Etype (Def_Ent)) then 3963 New_Occurrence_Of 3964 (Get_Result_Object_For_Postcond 3965 (Def_Ent), Loc) 3966 else 3967 Make_Explicit_Dereference (Loc, 3968 New_Occurrence_Of 3969 (Get_Result_Object_For_Postcond 3970 (Def_Ent), Loc))))); 3971 end if; 3972 3973 -- Call _postconditions when no general finalization exceptions have 3974 -- occured taking care to enable the postconditions and save any 3975 -- exception occurrences. 3976 3977 -- Generate: 3978 -- 3979 -- if not Raised_Finalization_Exception then 3980 -- begin 3981 -- Postcond_Enabled := True; 3982 -- _postconditions [(Result_Obj_For_Postcond[.all])]; 3983 -- exception 3984 -- when others => 3985 -- Raised_Post_Exception := True; 3986 -- Save_Occurrence 3987 -- (Saved_Exception, Get_Current_Excep.all); 3988 -- end; 3989 -- end if; 3990 3991 Append_To (Fin_Controller_Stmts, 3992 Make_If_Statement (Loc, 3993 Condition => 3994 Make_Op_Not (Loc, 3995 Right_Opnd => 3996 New_Occurrence_Of 3997 (Raised_Finalization_Exception_Id, Loc)), 3998 Then_Statements => New_List ( 3999 Make_Block_Statement (Loc, 4000 Handled_Statement_Sequence => 4001 Make_Handled_Sequence_Of_Statements (Loc, 4002 Statements => New_List ( 4003 Make_Assignment_Statement (Loc, 4004 Name => 4005 New_Occurrence_Of 4006 (Get_Postcond_Enabled (Def_Ent), Loc), 4007 Expression => 4008 New_Occurrence_Of 4009 (Standard_True, Loc)), 4010 Postconditions_Call), 4011 Exception_Handlers => New_List ( 4012 Make_Exception_Handler (Loc, 4013 Exception_Choices => New_List ( 4014 Make_Others_Choice (Loc)), 4015 Statements => New_List ( 4016 Make_Assignment_Statement (Loc, 4017 Name => 4018 New_Occurrence_Of 4019 (Raised_Post_Exception_Id, Loc), 4020 Expression => 4021 New_Occurrence_Of (Standard_True, Loc)), 4022 Make_Procedure_Call_Statement (Loc, 4023 Name => 4024 New_Occurrence_Of 4025 (RTE (RE_Save_Occurrence), Loc), 4026 Parameter_Associations => New_List ( 4027 New_Occurrence_Of 4028 (Saved_Exception_Id, Loc), 4029 Make_Explicit_Dereference (Loc, 4030 Prefix => 4031 Make_Function_Call (Loc, 4032 Name => 4033 Make_Explicit_Dereference (Loc, 4034 Prefix => 4035 New_Occurrence_Of 4036 (RTE (RE_Get_Current_Excep), 4037 Loc)))))))))))))); 4038 4039 -- Call _finalizer_old and reraise any exception that occurred during 4040 -- initial finalization within the exception handler. Otherwise, 4041 -- propagate the current exception. 4042 4043 -- Generate: 4044 -- 4045 -- begin 4046 -- _finalizer_old; 4047 -- exception 4048 -- when others => 4049 -- if Raised_Finalization_Exception then 4050 -- Reraise_Occurrence (Saved_Exception); 4051 -- end if; 4052 -- raise; 4053 -- end; 4054 4055 if Present (Fin_Old_Id) then 4056 Append_To (Fin_Controller_Stmts, 4057 Make_Block_Statement (Loc, 4058 Handled_Statement_Sequence => 4059 Make_Handled_Sequence_Of_Statements (Loc, 4060 Statements => New_List ( 4061 Make_Procedure_Call_Statement (Loc, 4062 Name => New_Occurrence_Of (Fin_Old_Id, Loc))), 4063 Exception_Handlers => New_List ( 4064 Make_Exception_Handler (Loc, 4065 Exception_Choices => New_List ( 4066 Make_Others_Choice (Loc)), 4067 Statements => New_List ( 4068 Make_If_Statement (Loc, 4069 Condition => 4070 New_Occurrence_Of 4071 (Raised_Finalization_Exception_Id, Loc), 4072 Then_Statements => New_List ( 4073 Make_Procedure_Call_Statement (Loc, 4074 Name => 4075 New_Occurrence_Of 4076 (RTE (RE_Reraise_Occurrence), Loc), 4077 Parameter_Associations => New_List ( 4078 New_Occurrence_Of 4079 (Saved_Exception_Id, Loc))))), 4080 Make_Raise_Statement (Loc))))))); 4081 end if; 4082 4083 -- Once finalization is complete reraise any pending exceptions 4084 4085 -- Generate: 4086 -- 4087 -- if Raised_Post_Exception 4088 -- or else Raised_Finalization_Exception 4089 -- then 4090 -- Reraise_Occurrence (Saved_Exception); 4091 -- end if; 4092 4093 Append_To (Fin_Controller_Stmts, 4094 Make_If_Statement (Loc, 4095 Condition => 4096 Make_Or_Else (Loc, 4097 Left_Opnd => 4098 New_Occurrence_Of 4099 (Raised_Post_Exception_Id, Loc), 4100 Right_Opnd => 4101 New_Occurrence_Of 4102 (Raised_Finalization_Exception_Id, Loc)), 4103 Then_Statements => New_List ( 4104 Make_Procedure_Call_Statement (Loc, 4105 Name => 4106 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc), 4107 Parameter_Associations => New_List ( 4108 New_Occurrence_Of 4109 (Saved_Exception_Id, Loc)))))); 4110 4111 -- Make the finalization controller subprogram body and declaration. 4112 4113 -- Generate: 4114 -- procedure _finalization_controller; 4115 -- 4116 -- procedure _finalization_controller is 4117 -- begin 4118 -- [Fin_Controller_Stmts]; 4119 -- end; 4120 4121 Fin_Controller_Id := 4122 Make_Defining_Identifier (Loc, 4123 Chars => New_External_Name (Name_uFinalization_Controller)); 4124 4125 Fin_Controller_Spec := 4126 Make_Subprogram_Declaration (Loc, 4127 Specification => 4128 Make_Procedure_Specification (Loc, 4129 Defining_Unit_Name => Fin_Controller_Id)); 4130 4131 Fin_Controller_Body := 4132 Make_Subprogram_Body (Loc, 4133 Specification => 4134 Make_Procedure_Specification (Loc, 4135 Defining_Unit_Name => 4136 Make_Defining_Identifier (Loc, Chars (Fin_Controller_Id))), 4137 Declarations => Fin_Controller_Decls, 4138 Handled_Statement_Sequence => 4139 Make_Handled_Sequence_Of_Statements (Loc, 4140 Statements => Fin_Controller_Stmts)); 4141 4142 -- Disable _postconditions calls which get generated before return 4143 -- statements to delay their evaluation until after finalization. 4144 4145 -- This is done by way of the local Postcond_Enabled object which is 4146 -- initially assigned to True - we then create an assignment within 4147 -- the subprogram's declaration to make it False and assign it back 4148 -- to True before _postconditions is called within 4149 -- _finalization_controller. 4150 4151 -- Generate: 4152 -- 4153 -- Postcond_Enable := False; 4154 4155 Append_To (Top_Decls, 4156 Make_Assignment_Statement (Loc, 4157 Name => 4158 New_Occurrence_Of 4159 (Get_Postcond_Enabled (Def_Ent), Loc), 4160 Expression => 4161 New_Occurrence_Of 4162 (Standard_False, Loc))); 4163 4164 -- Add the subprogram to the list of declarations an analyze it 4165 4166 Append_To (Top_Decls, Fin_Controller_Spec); 4167 Analyze (Fin_Controller_Spec); 4168 Insert_After (Fin_Controller_Spec, Fin_Controller_Body); 4169 Analyze (Fin_Controller_Body, Suppress => All_Checks); 4170 4171 -- Return the finalization controller as the result Fin_Id 4172 4173 Fin_Id := Fin_Controller_Id; 4174 end if; 4175 end Build_Finalizer; 4176 4177 --------------------- 4178 -- Build_Late_Proc -- 4179 --------------------- 4180 4181 procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is 4182 begin 4183 for Final_Prim in Name_Of'Range loop 4184 if Name_Of (Final_Prim) = Nam then 4185 Set_TSS (Typ, 4186 Make_Deep_Proc 4187 (Prim => Final_Prim, 4188 Typ => Typ, 4189 Stmts => Make_Deep_Record_Body (Final_Prim, Typ))); 4190 end if; 4191 end loop; 4192 end Build_Late_Proc; 4193 4194 ------------------------------- 4195 -- Build_Object_Declarations -- 4196 ------------------------------- 4197 4198 procedure Build_Object_Declarations 4199 (Data : out Finalization_Exception_Data; 4200 Decls : List_Id; 4201 Loc : Source_Ptr; 4202 For_Package : Boolean := False) 4203 is 4204 Decl : Node_Id; 4205 4206 Dummy : Entity_Id; 4207 -- This variable captures an unused dummy internal entity, see the 4208 -- comment associated with its use. 4209 4210 begin 4211 pragma Assert (Decls /= No_List); 4212 4213 -- Always set the proper location as it may be needed even when 4214 -- exception propagation is forbidden. 4215 4216 Data.Loc := Loc; 4217 4218 if Restriction_Active (No_Exception_Propagation) then 4219 Data.Abort_Id := Empty; 4220 Data.E_Id := Empty; 4221 Data.Raised_Id := Empty; 4222 return; 4223 end if; 4224 4225 Data.Raised_Id := Make_Temporary (Loc, 'R'); 4226 4227 -- In certain scenarios, finalization can be triggered by an abort. If 4228 -- the finalization itself fails and raises an exception, the resulting 4229 -- Program_Error must be supressed and replaced by an abort signal. In 4230 -- order to detect this scenario, save the state of entry into the 4231 -- finalization code. 4232 4233 -- This is not needed for library-level finalizers as they are called by 4234 -- the environment task and cannot be aborted. 4235 4236 if not For_Package then 4237 if Abort_Allowed then 4238 Data.Abort_Id := Make_Temporary (Loc, 'A'); 4239 4240 -- Generate: 4241 -- Abort_Id : constant Boolean := <A_Expr>; 4242 4243 Append_To (Decls, 4244 Make_Object_Declaration (Loc, 4245 Defining_Identifier => Data.Abort_Id, 4246 Constant_Present => True, 4247 Object_Definition => 4248 New_Occurrence_Of (Standard_Boolean, Loc), 4249 Expression => 4250 New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc))); 4251 4252 -- Abort is not required 4253 4254 else 4255 -- Generate a dummy entity to ensure that the internal symbols are 4256 -- in sync when a unit is compiled with and without aborts. 4257 4258 Dummy := Make_Temporary (Loc, 'A'); 4259 Data.Abort_Id := Empty; 4260 end if; 4261 4262 -- Library-level finalizers 4263 4264 else 4265 Data.Abort_Id := Empty; 4266 end if; 4267 4268 if Exception_Extra_Info then 4269 Data.E_Id := Make_Temporary (Loc, 'E'); 4270 4271 -- Generate: 4272 -- E_Id : Exception_Occurrence; 4273 4274 Decl := 4275 Make_Object_Declaration (Loc, 4276 Defining_Identifier => Data.E_Id, 4277 Object_Definition => 4278 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)); 4279 Set_No_Initialization (Decl); 4280 4281 Append_To (Decls, Decl); 4282 4283 else 4284 Data.E_Id := Empty; 4285 end if; 4286 4287 -- Generate: 4288 -- Raised_Id : Boolean := False; 4289 4290 Append_To (Decls, 4291 Make_Object_Declaration (Loc, 4292 Defining_Identifier => Data.Raised_Id, 4293 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 4294 Expression => New_Occurrence_Of (Standard_False, Loc))); 4295 4296 if Debug_Generated_Code then 4297 Set_Debug_Info_Needed (Data.Raised_Id); 4298 end if; 4299 end Build_Object_Declarations; 4300 4301 --------------------------- 4302 -- Build_Raise_Statement -- 4303 --------------------------- 4304 4305 function Build_Raise_Statement 4306 (Data : Finalization_Exception_Data) return Node_Id 4307 is 4308 Stmt : Node_Id; 4309 Expr : Node_Id; 4310 4311 begin 4312 -- Standard run-time use the specialized routine 4313 -- Raise_From_Controlled_Operation. 4314 4315 if Exception_Extra_Info 4316 and then RTE_Available (RE_Raise_From_Controlled_Operation) 4317 then 4318 Stmt := 4319 Make_Procedure_Call_Statement (Data.Loc, 4320 Name => 4321 New_Occurrence_Of 4322 (RTE (RE_Raise_From_Controlled_Operation), Data.Loc), 4323 Parameter_Associations => 4324 New_List (New_Occurrence_Of (Data.E_Id, Data.Loc))); 4325 4326 -- Restricted run-time: exception messages are not supported and hence 4327 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error 4328 -- instead. 4329 4330 else 4331 Stmt := 4332 Make_Raise_Program_Error (Data.Loc, 4333 Reason => PE_Finalize_Raised_Exception); 4334 end if; 4335 4336 -- Generate: 4337 4338 -- Raised_Id and then not Abort_Id 4339 -- <or> 4340 -- Raised_Id 4341 4342 Expr := New_Occurrence_Of (Data.Raised_Id, Data.Loc); 4343 4344 if Present (Data.Abort_Id) then 4345 Expr := Make_And_Then (Data.Loc, 4346 Left_Opnd => Expr, 4347 Right_Opnd => 4348 Make_Op_Not (Data.Loc, 4349 Right_Opnd => New_Occurrence_Of (Data.Abort_Id, Data.Loc))); 4350 end if; 4351 4352 -- Generate: 4353 4354 -- if Raised_Id and then not Abort_Id then 4355 -- Raise_From_Controlled_Operation (E_Id); 4356 -- <or> 4357 -- raise Program_Error; -- restricted runtime 4358 -- end if; 4359 4360 return 4361 Make_If_Statement (Data.Loc, 4362 Condition => Expr, 4363 Then_Statements => New_List (Stmt)); 4364 end Build_Raise_Statement; 4365 4366 ----------------------------- 4367 -- Build_Record_Deep_Procs -- 4368 ----------------------------- 4369 4370 procedure Build_Record_Deep_Procs (Typ : Entity_Id) is 4371 begin 4372 Set_TSS (Typ, 4373 Make_Deep_Proc 4374 (Prim => Initialize_Case, 4375 Typ => Typ, 4376 Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); 4377 4378 if not Is_Limited_View (Typ) then 4379 Set_TSS (Typ, 4380 Make_Deep_Proc 4381 (Prim => Adjust_Case, 4382 Typ => Typ, 4383 Stmts => Make_Deep_Record_Body (Adjust_Case, Typ))); 4384 end if; 4385 4386 -- Do not generate Deep_Finalize and Finalize_Address if finalization is 4387 -- suppressed since these routine will not be used. 4388 4389 if not Restriction_Active (No_Finalization) then 4390 Set_TSS (Typ, 4391 Make_Deep_Proc 4392 (Prim => Finalize_Case, 4393 Typ => Typ, 4394 Stmts => Make_Deep_Record_Body (Finalize_Case, Typ))); 4395 4396 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode) 4397 4398 if not CodePeer_Mode then 4399 Set_TSS (Typ, 4400 Make_Deep_Proc 4401 (Prim => Address_Case, 4402 Typ => Typ, 4403 Stmts => Make_Deep_Record_Body (Address_Case, Typ))); 4404 end if; 4405 end if; 4406 end Build_Record_Deep_Procs; 4407 4408 ------------------- 4409 -- Cleanup_Array -- 4410 ------------------- 4411 4412 function Cleanup_Array 4413 (N : Node_Id; 4414 Obj : Node_Id; 4415 Typ : Entity_Id) return List_Id 4416 is 4417 Loc : constant Source_Ptr := Sloc (N); 4418 Index_List : constant List_Id := New_List; 4419 4420 function Free_Component return List_Id; 4421 -- Generate the code to finalize the task or protected subcomponents 4422 -- of a single component of the array. 4423 4424 function Free_One_Dimension (Dim : Int) return List_Id; 4425 -- Generate a loop over one dimension of the array 4426 4427 -------------------- 4428 -- Free_Component -- 4429 -------------------- 4430 4431 function Free_Component return List_Id is 4432 Stmts : List_Id := New_List; 4433 Tsk : Node_Id; 4434 C_Typ : constant Entity_Id := Component_Type (Typ); 4435 4436 begin 4437 -- Component type is known to contain tasks or protected objects 4438 4439 Tsk := 4440 Make_Indexed_Component (Loc, 4441 Prefix => Duplicate_Subexpr_No_Checks (Obj), 4442 Expressions => Index_List); 4443 4444 Set_Etype (Tsk, C_Typ); 4445 4446 if Is_Task_Type (C_Typ) then 4447 Append_To (Stmts, Cleanup_Task (N, Tsk)); 4448 4449 elsif Is_Simple_Protected_Type (C_Typ) then 4450 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk)); 4451 4452 elsif Is_Record_Type (C_Typ) then 4453 Stmts := Cleanup_Record (N, Tsk, C_Typ); 4454 4455 elsif Is_Array_Type (C_Typ) then 4456 Stmts := Cleanup_Array (N, Tsk, C_Typ); 4457 end if; 4458 4459 return Stmts; 4460 end Free_Component; 4461 4462 ------------------------ 4463 -- Free_One_Dimension -- 4464 ------------------------ 4465 4466 function Free_One_Dimension (Dim : Int) return List_Id is 4467 Index : Entity_Id; 4468 4469 begin 4470 if Dim > Number_Dimensions (Typ) then 4471 return Free_Component; 4472 4473 -- Here we generate the required loop 4474 4475 else 4476 Index := Make_Temporary (Loc, 'J'); 4477 Append (New_Occurrence_Of (Index, Loc), Index_List); 4478 4479 return New_List ( 4480 Make_Implicit_Loop_Statement (N, 4481 Identifier => Empty, 4482 Iteration_Scheme => 4483 Make_Iteration_Scheme (Loc, 4484 Loop_Parameter_Specification => 4485 Make_Loop_Parameter_Specification (Loc, 4486 Defining_Identifier => Index, 4487 Discrete_Subtype_Definition => 4488 Make_Attribute_Reference (Loc, 4489 Prefix => Duplicate_Subexpr (Obj), 4490 Attribute_Name => Name_Range, 4491 Expressions => New_List ( 4492 Make_Integer_Literal (Loc, Dim))))), 4493 Statements => Free_One_Dimension (Dim + 1))); 4494 end if; 4495 end Free_One_Dimension; 4496 4497 -- Start of processing for Cleanup_Array 4498 4499 begin 4500 return Free_One_Dimension (1); 4501 end Cleanup_Array; 4502 4503 -------------------- 4504 -- Cleanup_Record -- 4505 -------------------- 4506 4507 function Cleanup_Record 4508 (N : Node_Id; 4509 Obj : Node_Id; 4510 Typ : Entity_Id) return List_Id 4511 is 4512 Loc : constant Source_Ptr := Sloc (N); 4513 Stmts : constant List_Id := New_List; 4514 U_Typ : constant Entity_Id := Underlying_Type (Typ); 4515 4516 Comp : Entity_Id; 4517 Tsk : Node_Id; 4518 4519 begin 4520 if Has_Discriminants (U_Typ) 4521 and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration 4522 and then Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition 4523 and then 4524 Present 4525 (Variant_Part (Component_List (Type_Definition (Parent (U_Typ))))) 4526 then 4527 -- For now, do not attempt to free a component that may appear in a 4528 -- variant, and instead issue a warning. Doing this "properly" would 4529 -- require building a case statement and would be quite a mess. Note 4530 -- that the RM only requires that free "work" for the case of a task 4531 -- access value, so already we go way beyond this in that we deal 4532 -- with the array case and non-discriminated record cases. 4533 4534 Error_Msg_N 4535 ("task/protected object in variant record will not be freed??", N); 4536 return New_List (Make_Null_Statement (Loc)); 4537 end if; 4538 4539 Comp := First_Component (U_Typ); 4540 while Present (Comp) loop 4541 if Has_Task (Etype (Comp)) 4542 or else Has_Simple_Protected_Object (Etype (Comp)) 4543 then 4544 Tsk := 4545 Make_Selected_Component (Loc, 4546 Prefix => Duplicate_Subexpr_No_Checks (Obj), 4547 Selector_Name => New_Occurrence_Of (Comp, Loc)); 4548 Set_Etype (Tsk, Etype (Comp)); 4549 4550 if Is_Task_Type (Etype (Comp)) then 4551 Append_To (Stmts, Cleanup_Task (N, Tsk)); 4552 4553 elsif Is_Simple_Protected_Type (Etype (Comp)) then 4554 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk)); 4555 4556 elsif Is_Record_Type (Etype (Comp)) then 4557 4558 -- Recurse, by generating the prefix of the argument to the 4559 -- eventual cleanup call. 4560 4561 Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp))); 4562 4563 elsif Is_Array_Type (Etype (Comp)) then 4564 Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp))); 4565 end if; 4566 end if; 4567 4568 Next_Component (Comp); 4569 end loop; 4570 4571 return Stmts; 4572 end Cleanup_Record; 4573 4574 ------------------------------ 4575 -- Cleanup_Protected_Object -- 4576 ------------------------------ 4577 4578 function Cleanup_Protected_Object 4579 (N : Node_Id; 4580 Ref : Node_Id) return Node_Id 4581 is 4582 Loc : constant Source_Ptr := Sloc (N); 4583 4584 begin 4585 -- For restricted run-time libraries (Ravenscar), tasks are 4586 -- non-terminating, and protected objects can only appear at library 4587 -- level, so we do not want finalization of protected objects. 4588 4589 if Restricted_Profile then 4590 return Empty; 4591 4592 else 4593 return 4594 Make_Procedure_Call_Statement (Loc, 4595 Name => 4596 New_Occurrence_Of (RTE (RE_Finalize_Protection), Loc), 4597 Parameter_Associations => New_List (Concurrent_Ref (Ref))); 4598 end if; 4599 end Cleanup_Protected_Object; 4600 4601 ------------------ 4602 -- Cleanup_Task -- 4603 ------------------ 4604 4605 function Cleanup_Task 4606 (N : Node_Id; 4607 Ref : Node_Id) return Node_Id 4608 is 4609 Loc : constant Source_Ptr := Sloc (N); 4610 4611 begin 4612 -- For restricted run-time libraries (Ravenscar), tasks are 4613 -- non-terminating and they can only appear at library level, 4614 -- so we do not want finalization of task objects. 4615 4616 if Restricted_Profile then 4617 return Empty; 4618 4619 else 4620 return 4621 Make_Procedure_Call_Statement (Loc, 4622 Name => 4623 New_Occurrence_Of (RTE (RE_Free_Task), Loc), 4624 Parameter_Associations => New_List (Concurrent_Ref (Ref))); 4625 end if; 4626 end Cleanup_Task; 4627 4628 -------------------------------------- 4629 -- Check_Unnesting_Elaboration_Code -- 4630 -------------------------------------- 4631 4632 procedure Check_Unnesting_Elaboration_Code (N : Node_Id) is 4633 Loc : constant Source_Ptr := Sloc (N); 4634 Block_Elab_Proc : Entity_Id := Empty; 4635 4636 procedure Set_Block_Elab_Proc; 4637 -- Create a defining identifier for a procedure that will replace 4638 -- a block with nested subprograms (unless it has already been created, 4639 -- in which case this is a no-op). 4640 4641 procedure Set_Block_Elab_Proc is 4642 begin 4643 if No (Block_Elab_Proc) then 4644 Block_Elab_Proc := 4645 Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('I')); 4646 end if; 4647 end Set_Block_Elab_Proc; 4648 4649 procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id); 4650 -- Find entities in the elaboration code of a library package body that 4651 -- contain or represent a subprogram body. A body can appear within a 4652 -- block or a loop or can appear by itself if generated for an object 4653 -- declaration that involves controlled actions. The first such entity 4654 -- forces creation of a new procedure entity (via Set_Block_Elab_Proc) 4655 -- that will be used to reset the scopes of all entities that become 4656 -- local to the new elaboration procedure. This is needed for subsequent 4657 -- unnesting actions, which depend on proper setting of the Scope links 4658 -- to determine the nesting level of each subprogram. 4659 4660 ----------------------- 4661 -- Find_Local_Scope -- 4662 ----------------------- 4663 4664 procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id) is 4665 Id : Entity_Id; 4666 Stat : Node_Id; 4667 Node : Node_Id; 4668 4669 begin 4670 Stat := First (L); 4671 while Present (Stat) loop 4672 case Nkind (Stat) is 4673 when N_Block_Statement => 4674 if Present (Identifier (Stat)) then 4675 Id := Entity (Identifier (Stat)); 4676 4677 -- The Scope of this block needs to be reset to the new 4678 -- procedure if the block contains nested subprograms. 4679 4680 if Present (Id) and then Contains_Subprogram (Id) then 4681 Set_Block_Elab_Proc; 4682 Set_Scope (Id, Block_Elab_Proc); 4683 end if; 4684 end if; 4685 4686 when N_Loop_Statement => 4687 Id := Entity (Identifier (Stat)); 4688 4689 if Present (Id) and then Contains_Subprogram (Id) then 4690 if Scope (Id) = Current_Scope then 4691 Set_Block_Elab_Proc; 4692 Set_Scope (Id, Block_Elab_Proc); 4693 end if; 4694 end if; 4695 4696 -- We traverse the loop's statements as well, which may 4697 -- include other block (etc.) statements that need to have 4698 -- their Scope set to Block_Elab_Proc. (Is this really the 4699 -- case, or do such nested blocks refer to the loop scope 4700 -- rather than the loop's enclosing scope???.) 4701 4702 Reset_Scopes_To_Block_Elab_Proc (Statements (Stat)); 4703 4704 when N_If_Statement => 4705 Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Stat)); 4706 Reset_Scopes_To_Block_Elab_Proc (Else_Statements (Stat)); 4707 4708 Node := First (Elsif_Parts (Stat)); 4709 while Present (Node) loop 4710 Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Node)); 4711 Next (Node); 4712 end loop; 4713 4714 when N_Case_Statement => 4715 Node := First (Alternatives (Stat)); 4716 while Present (Node) loop 4717 Reset_Scopes_To_Block_Elab_Proc (Statements (Node)); 4718 Next (Node); 4719 end loop; 4720 4721 -- Reset the Scope of a subprogram occurring at the top level 4722 4723 when N_Subprogram_Body => 4724 Id := Defining_Entity (Stat); 4725 4726 Set_Block_Elab_Proc; 4727 Set_Scope (Id, Block_Elab_Proc); 4728 4729 when others => 4730 null; 4731 end case; 4732 4733 Next (Stat); 4734 end loop; 4735 end Reset_Scopes_To_Block_Elab_Proc; 4736 4737 -- Local variables 4738 4739 H_Seq : constant Node_Id := Handled_Statement_Sequence (N); 4740 Elab_Body : Node_Id; 4741 Elab_Call : Node_Id; 4742 4743 -- Start of processing for Check_Unnesting_Elaboration_Code 4744 4745 begin 4746 if Present (H_Seq) then 4747 Reset_Scopes_To_Block_Elab_Proc (Statements (H_Seq)); 4748 4749 -- There may be subprograms declared in the exception handlers 4750 -- of the current body. 4751 4752 if Present (Exception_Handlers (H_Seq)) then 4753 declare 4754 Handler : Node_Id := First (Exception_Handlers (H_Seq)); 4755 begin 4756 while Present (Handler) loop 4757 Reset_Scopes_To_Block_Elab_Proc (Statements (Handler)); 4758 4759 Next (Handler); 4760 end loop; 4761 end; 4762 end if; 4763 4764 if Present (Block_Elab_Proc) then 4765 Elab_Body := 4766 Make_Subprogram_Body (Loc, 4767 Specification => 4768 Make_Procedure_Specification (Loc, 4769 Defining_Unit_Name => Block_Elab_Proc), 4770 Declarations => New_List, 4771 Handled_Statement_Sequence => 4772 Relocate_Node (Handled_Statement_Sequence (N))); 4773 4774 Elab_Call := 4775 Make_Procedure_Call_Statement (Loc, 4776 Name => New_Occurrence_Of (Block_Elab_Proc, Loc)); 4777 4778 Append_To (Declarations (N), Elab_Body); 4779 Analyze (Elab_Body); 4780 Set_Has_Nested_Subprogram (Block_Elab_Proc); 4781 4782 Set_Handled_Statement_Sequence (N, 4783 Make_Handled_Sequence_Of_Statements (Loc, 4784 Statements => New_List (Elab_Call))); 4785 4786 Analyze (Elab_Call); 4787 4788 -- Could we reset the scopes of entities associated with the new 4789 -- procedure here via a loop over entities rather than doing it in 4790 -- the recursive Reset_Scopes_To_Elab_Proc procedure??? 4791 end if; 4792 end if; 4793 end Check_Unnesting_Elaboration_Code; 4794 4795 --------------------------------------- 4796 -- Check_Unnesting_In_Decls_Or_Stmts -- 4797 --------------------------------------- 4798 4799 procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id) is 4800 Decl_Or_Stmt : Node_Id; 4801 4802 begin 4803 if Unnest_Subprogram_Mode 4804 and then Present (Decls_Or_Stmts) 4805 then 4806 Decl_Or_Stmt := First (Decls_Or_Stmts); 4807 while Present (Decl_Or_Stmt) loop 4808 if Nkind (Decl_Or_Stmt) = N_Block_Statement 4809 and then Contains_Subprogram (Entity (Identifier (Decl_Or_Stmt))) 4810 then 4811 Unnest_Block (Decl_Or_Stmt); 4812 4813 -- If-statements may contain subprogram bodies at the outer level 4814 -- of their statement lists, and the subprograms may make up-level 4815 -- references (such as to objects declared in the same statement 4816 -- list). Unlike block and loop cases, however, we don't have an 4817 -- entity on which to test the Contains_Subprogram flag, so 4818 -- Unnest_If_Statement must traverse the statement lists to 4819 -- determine whether there are nested subprograms present. 4820 4821 elsif Nkind (Decl_Or_Stmt) = N_If_Statement then 4822 Unnest_If_Statement (Decl_Or_Stmt); 4823 4824 elsif Nkind (Decl_Or_Stmt) = N_Loop_Statement then 4825 declare 4826 Id : constant Entity_Id := 4827 Entity (Identifier (Decl_Or_Stmt)); 4828 4829 begin 4830 -- When a top-level loop within declarations of a library 4831 -- package spec or body contains nested subprograms, we wrap 4832 -- it in a procedure to handle possible up-level references 4833 -- to entities associated with the loop (such as loop 4834 -- parameters). 4835 4836 if Present (Id) and then Contains_Subprogram (Id) then 4837 Unnest_Loop (Decl_Or_Stmt); 4838 end if; 4839 end; 4840 4841 elsif Nkind (Decl_Or_Stmt) = N_Package_Declaration 4842 and then not Modify_Tree_For_C 4843 then 4844 Check_Unnesting_In_Decls_Or_Stmts 4845 (Visible_Declarations (Specification (Decl_Or_Stmt))); 4846 Check_Unnesting_In_Decls_Or_Stmts 4847 (Private_Declarations (Specification (Decl_Or_Stmt))); 4848 4849 elsif Nkind (Decl_Or_Stmt) = N_Package_Body 4850 and then not Modify_Tree_For_C 4851 then 4852 Check_Unnesting_In_Decls_Or_Stmts (Declarations (Decl_Or_Stmt)); 4853 if Present (Statements 4854 (Handled_Statement_Sequence (Decl_Or_Stmt))) 4855 then 4856 Check_Unnesting_In_Decls_Or_Stmts (Statements 4857 (Handled_Statement_Sequence (Decl_Or_Stmt))); 4858 Check_Unnesting_In_Handlers (Decl_Or_Stmt); 4859 end if; 4860 end if; 4861 4862 Next (Decl_Or_Stmt); 4863 end loop; 4864 end if; 4865 end Check_Unnesting_In_Decls_Or_Stmts; 4866 4867 --------------------------------- 4868 -- Check_Unnesting_In_Handlers -- 4869 --------------------------------- 4870 4871 procedure Check_Unnesting_In_Handlers (N : Node_Id) is 4872 Stmt_Seq : constant Node_Id := Handled_Statement_Sequence (N); 4873 4874 begin 4875 if Present (Stmt_Seq) 4876 and then Present (Exception_Handlers (Stmt_Seq)) 4877 then 4878 declare 4879 Handler : Node_Id := First (Exception_Handlers (Stmt_Seq)); 4880 begin 4881 while Present (Handler) loop 4882 if Present (Statements (Handler)) then 4883 Check_Unnesting_In_Decls_Or_Stmts (Statements (Handler)); 4884 end if; 4885 4886 Next (Handler); 4887 end loop; 4888 end; 4889 end if; 4890 end Check_Unnesting_In_Handlers; 4891 4892 ------------------------------ 4893 -- Check_Visibly_Controlled -- 4894 ------------------------------ 4895 4896 procedure Check_Visibly_Controlled 4897 (Prim : Final_Primitives; 4898 Typ : Entity_Id; 4899 E : in out Entity_Id; 4900 Cref : in out Node_Id) 4901 is 4902 Parent_Type : Entity_Id; 4903 Op : Entity_Id; 4904 4905 begin 4906 if Is_Derived_Type (Typ) 4907 and then Comes_From_Source (E) 4908 and then not Present (Overridden_Operation (E)) 4909 then 4910 -- We know that the explicit operation on the type does not override 4911 -- the inherited operation of the parent, and that the derivation 4912 -- is from a private type that is not visibly controlled. 4913 4914 Parent_Type := Etype (Typ); 4915 Op := Find_Optional_Prim_Op (Parent_Type, Name_Of (Prim)); 4916 4917 if Present (Op) then 4918 E := Op; 4919 4920 -- Wrap the object to be initialized into the proper 4921 -- unchecked conversion, to be compatible with the operation 4922 -- to be called. 4923 4924 if Nkind (Cref) = N_Unchecked_Type_Conversion then 4925 Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref)); 4926 else 4927 Cref := Unchecked_Convert_To (Parent_Type, Cref); 4928 end if; 4929 end if; 4930 end if; 4931 end Check_Visibly_Controlled; 4932 4933 -------------------------- 4934 -- Contains_Subprogram -- 4935 -------------------------- 4936 4937 function Contains_Subprogram (Blk : Entity_Id) return Boolean is 4938 E : Entity_Id; 4939 4940 begin 4941 E := First_Entity (Blk); 4942 4943 while Present (E) loop 4944 if Is_Subprogram (E) then 4945 return True; 4946 4947 elsif Ekind (E) in E_Block | E_Loop 4948 and then Contains_Subprogram (E) 4949 then 4950 return True; 4951 end if; 4952 4953 Next_Entity (E); 4954 end loop; 4955 4956 return False; 4957 end Contains_Subprogram; 4958 4959 ------------------ 4960 -- Convert_View -- 4961 ------------------ 4962 4963 function Convert_View 4964 (Proc : Entity_Id; 4965 Arg : Node_Id; 4966 Ind : Pos := 1) return Node_Id 4967 is 4968 Fent : Entity_Id := First_Entity (Proc); 4969 Ftyp : Entity_Id; 4970 Atyp : Entity_Id; 4971 4972 begin 4973 for J in 2 .. Ind loop 4974 Next_Entity (Fent); 4975 end loop; 4976 4977 Ftyp := Etype (Fent); 4978 4979 if Nkind (Arg) in N_Type_Conversion | N_Unchecked_Type_Conversion then 4980 Atyp := Entity (Subtype_Mark (Arg)); 4981 else 4982 Atyp := Etype (Arg); 4983 end if; 4984 4985 if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then 4986 return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg); 4987 4988 elsif Ftyp /= Atyp 4989 and then Present (Atyp) 4990 and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp)) 4991 and then Base_Type (Underlying_Type (Atyp)) = 4992 Base_Type (Underlying_Type (Ftyp)) 4993 then 4994 return Unchecked_Convert_To (Ftyp, Arg); 4995 4996 -- If the argument is already a conversion, as generated by 4997 -- Make_Init_Call, set the target type to the type of the formal 4998 -- directly, to avoid spurious typing problems. 4999 5000 elsif Nkind (Arg) in N_Unchecked_Type_Conversion | N_Type_Conversion 5001 and then not Is_Class_Wide_Type (Atyp) 5002 then 5003 Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg))); 5004 Set_Etype (Arg, Ftyp); 5005 return Arg; 5006 5007 -- Otherwise, introduce a conversion when the designated object 5008 -- has a type derived from the formal of the controlled routine. 5009 5010 elsif Is_Private_Type (Ftyp) 5011 and then Present (Atyp) 5012 and then Is_Derived_Type (Underlying_Type (Base_Type (Atyp))) 5013 then 5014 return Unchecked_Convert_To (Ftyp, Arg); 5015 5016 else 5017 return Arg; 5018 end if; 5019 end Convert_View; 5020 5021 ------------------------------- 5022 -- CW_Or_Has_Controlled_Part -- 5023 ------------------------------- 5024 5025 function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is 5026 begin 5027 return Is_Class_Wide_Type (T) or else Needs_Finalization (T); 5028 end CW_Or_Has_Controlled_Part; 5029 5030 ------------------------ 5031 -- Enclosing_Function -- 5032 ------------------------ 5033 5034 function Enclosing_Function (E : Entity_Id) return Entity_Id is 5035 Func_Id : Entity_Id; 5036 5037 begin 5038 Func_Id := E; 5039 while Present (Func_Id) and then Func_Id /= Standard_Standard loop 5040 if Ekind (Func_Id) = E_Function then 5041 return Func_Id; 5042 end if; 5043 5044 Func_Id := Scope (Func_Id); 5045 end loop; 5046 5047 return Empty; 5048 end Enclosing_Function; 5049 5050 ------------------------------- 5051 -- Establish_Transient_Scope -- 5052 ------------------------------- 5053 5054 -- This procedure is called each time a transient block has to be inserted 5055 -- that is to say for each call to a function with unconstrained or tagged 5056 -- result. It creates a new scope on the scope stack in order to enclose 5057 -- all transient variables generated. 5058 5059 procedure Establish_Transient_Scope 5060 (N : Node_Id; 5061 Manage_Sec_Stack : Boolean) 5062 is 5063 procedure Create_Transient_Scope (Constr : Node_Id); 5064 -- Place a new scope on the scope stack in order to service construct 5065 -- Constr. The new scope may also manage the secondary stack. 5066 5067 procedure Delegate_Sec_Stack_Management; 5068 -- Move the management of the secondary stack to the nearest enclosing 5069 -- suitable scope. 5070 5071 function Find_Enclosing_Transient_Scope return Entity_Id; 5072 -- Examine the scope stack looking for the nearest enclosing transient 5073 -- scope. Return Empty if no such scope exists. 5074 5075 function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean; 5076 -- Determine whether arbitrary Id denotes a package or subprogram [body] 5077 5078 ---------------------------- 5079 -- Create_Transient_Scope -- 5080 ---------------------------- 5081 5082 procedure Create_Transient_Scope (Constr : Node_Id) is 5083 Loc : constant Source_Ptr := Sloc (N); 5084 5085 Iter_Loop : Entity_Id; 5086 Trans_Scop : Entity_Id; 5087 5088 begin 5089 Trans_Scop := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); 5090 Set_Etype (Trans_Scop, Standard_Void_Type); 5091 5092 Push_Scope (Trans_Scop); 5093 Set_Node_To_Be_Wrapped (Constr); 5094 Set_Scope_Is_Transient; 5095 5096 -- The transient scope must also manage the secondary stack 5097 5098 if Manage_Sec_Stack then 5099 Set_Uses_Sec_Stack (Trans_Scop); 5100 Check_Restriction (No_Secondary_Stack, N); 5101 5102 -- The expansion of iterator loops generates references to objects 5103 -- in order to extract elements from a container: 5104 5105 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor); 5106 -- Obj : <object type> renames Ref.all.Element.all; 5107 5108 -- These references are controlled and returned on the secondary 5109 -- stack. A new reference is created at each iteration of the loop 5110 -- and as a result it must be finalized and the space occupied by 5111 -- it on the secondary stack reclaimed at the end of the current 5112 -- iteration. 5113 5114 -- When the context that requires a transient scope is a call to 5115 -- routine Reference, the node to be wrapped is the source object: 5116 5117 -- for Obj of Container loop 5118 5119 -- Routine Wrap_Transient_Declaration however does not generate 5120 -- a physical block as wrapping a declaration will kill it too 5121 -- early. To handle this peculiar case, mark the related iterator 5122 -- loop as requiring the secondary stack. This signals the 5123 -- finalization machinery to manage the secondary stack (see 5124 -- routine Process_Statements_For_Controlled_Objects). 5125 5126 Iter_Loop := Find_Enclosing_Iterator_Loop (Trans_Scop); 5127 5128 if Present (Iter_Loop) then 5129 Set_Uses_Sec_Stack (Iter_Loop); 5130 end if; 5131 end if; 5132 5133 if Debug_Flag_W then 5134 Write_Str (" <Transient>"); 5135 Write_Eol; 5136 end if; 5137 end Create_Transient_Scope; 5138 5139 ----------------------------------- 5140 -- Delegate_Sec_Stack_Management -- 5141 ----------------------------------- 5142 5143 procedure Delegate_Sec_Stack_Management is 5144 Scop_Id : Entity_Id; 5145 Scop_Rec : Scope_Stack_Entry; 5146 5147 begin 5148 for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop 5149 Scop_Rec := Scope_Stack.Table (Index); 5150 Scop_Id := Scop_Rec.Entity; 5151 5152 -- Prevent the search from going too far or within the scope space 5153 -- of another unit. 5154 5155 if Scop_Id = Standard_Standard then 5156 return; 5157 5158 -- No transient scope should be encountered during the traversal 5159 -- because Establish_Transient_Scope should have already handled 5160 -- this case. 5161 5162 elsif Scop_Rec.Is_Transient then 5163 pragma Assert (False); 5164 return; 5165 5166 -- The construct which requires secondary stack management is 5167 -- always enclosed by a package or subprogram scope. 5168 5169 elsif Is_Package_Or_Subprogram (Scop_Id) then 5170 Set_Uses_Sec_Stack (Scop_Id); 5171 Check_Restriction (No_Secondary_Stack, N); 5172 5173 return; 5174 end if; 5175 end loop; 5176 5177 -- At this point no suitable scope was found. This should never occur 5178 -- because a construct is always enclosed by a compilation unit which 5179 -- has a scope. 5180 5181 pragma Assert (False); 5182 end Delegate_Sec_Stack_Management; 5183 5184 ------------------------------------ 5185 -- Find_Enclosing_Transient_Scope -- 5186 ------------------------------------ 5187 5188 function Find_Enclosing_Transient_Scope return Entity_Id is 5189 Scop_Id : Entity_Id; 5190 Scop_Rec : Scope_Stack_Entry; 5191 5192 begin 5193 for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop 5194 Scop_Rec := Scope_Stack.Table (Index); 5195 Scop_Id := Scop_Rec.Entity; 5196 5197 -- Prevent the search from going too far or within the scope space 5198 -- of another unit. 5199 5200 if Scop_Id = Standard_Standard 5201 or else Is_Package_Or_Subprogram (Scop_Id) 5202 then 5203 exit; 5204 5205 elsif Scop_Rec.Is_Transient then 5206 return Scop_Id; 5207 end if; 5208 end loop; 5209 5210 return Empty; 5211 end Find_Enclosing_Transient_Scope; 5212 5213 ------------------------------ 5214 -- Is_Package_Or_Subprogram -- 5215 ------------------------------ 5216 5217 function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean is 5218 begin 5219 return Ekind (Id) in E_Entry 5220 | E_Entry_Family 5221 | E_Function 5222 | E_Package 5223 | E_Procedure 5224 | E_Subprogram_Body; 5225 end Is_Package_Or_Subprogram; 5226 5227 -- Local variables 5228 5229 Trans_Id : constant Entity_Id := Find_Enclosing_Transient_Scope; 5230 Context : Node_Id; 5231 5232 -- Start of processing for Establish_Transient_Scope 5233 5234 begin 5235 -- Do not create a new transient scope if there is an existing transient 5236 -- scope on the stack. 5237 5238 if Present (Trans_Id) then 5239 5240 -- If the transient scope was requested for purposes of managing the 5241 -- secondary stack, then the existing scope must perform this task. 5242 5243 if Manage_Sec_Stack then 5244 Set_Uses_Sec_Stack (Trans_Id); 5245 end if; 5246 5247 return; 5248 end if; 5249 5250 -- At this point it is known that the scope stack is free of transient 5251 -- scopes. Locate the proper construct which must be serviced by a new 5252 -- transient scope. 5253 5254 Context := Find_Transient_Context (N); 5255 5256 if Present (Context) then 5257 if Nkind (Context) = N_Assignment_Statement then 5258 5259 -- An assignment statement with suppressed controlled semantics 5260 -- does not need a transient scope because finalization is not 5261 -- desirable at this point. Note that No_Ctrl_Actions is also 5262 -- set for non-controlled assignments to suppress dispatching 5263 -- _assign. 5264 5265 if No_Ctrl_Actions (Context) 5266 and then Needs_Finalization (Etype (Name (Context))) 5267 then 5268 -- When a controlled component is initialized by a function 5269 -- call, the result on the secondary stack is always assigned 5270 -- to the component. Signal the nearest suitable scope that it 5271 -- is safe to manage the secondary stack. 5272 5273 if Manage_Sec_Stack and then Within_Init_Proc then 5274 Delegate_Sec_Stack_Management; 5275 end if; 5276 5277 -- Otherwise the assignment is a normal transient context and thus 5278 -- requires a transient scope. 5279 5280 else 5281 Create_Transient_Scope (Context); 5282 end if; 5283 5284 -- General case 5285 5286 else 5287 Create_Transient_Scope (Context); 5288 end if; 5289 end if; 5290 end Establish_Transient_Scope; 5291 5292 ---------------------------- 5293 -- Expand_Cleanup_Actions -- 5294 ---------------------------- 5295 5296 procedure Expand_Cleanup_Actions (N : Node_Id) is 5297 pragma Assert 5298 (Nkind (N) in N_Block_Statement 5299 | N_Entry_Body 5300 | N_Extended_Return_Statement 5301 | N_Subprogram_Body 5302 | N_Task_Body); 5303 5304 Scop : constant Entity_Id := Current_Scope; 5305 5306 Is_Asynchronous_Call : constant Boolean := 5307 Nkind (N) = N_Block_Statement 5308 and then Is_Asynchronous_Call_Block (N); 5309 Is_Master : constant Boolean := 5310 Nkind (N) /= N_Extended_Return_Statement 5311 and then Nkind (N) /= N_Entry_Body 5312 and then Is_Task_Master (N); 5313 Is_Protected_Subp_Body : constant Boolean := 5314 Nkind (N) = N_Subprogram_Body 5315 and then Is_Protected_Subprogram_Body (N); 5316 Is_Task_Allocation : constant Boolean := 5317 Nkind (N) = N_Block_Statement 5318 and then Is_Task_Allocation_Block (N); 5319 Is_Task_Body : constant Boolean := 5320 Nkind (Original_Node (N)) = N_Task_Body; 5321 5322 -- We mark the secondary stack if it is used in this construct, and 5323 -- we're not returning a function result on the secondary stack, except 5324 -- that a build-in-place function that might or might not return on the 5325 -- secondary stack always needs a mark. A run-time test is required in 5326 -- the case where the build-in-place function has a BIP_Alloc extra 5327 -- parameter (see Create_Finalizer). 5328 5329 Needs_Sec_Stack_Mark : constant Boolean := 5330 (Uses_Sec_Stack (Scop) 5331 and then 5332 not Sec_Stack_Needed_For_Return (Scop)) 5333 or else 5334 (Is_Build_In_Place_Function (Scop) 5335 and then Needs_BIP_Alloc_Form (Scop)); 5336 5337 Needs_Custom_Cleanup : constant Boolean := 5338 Nkind (N) = N_Block_Statement 5339 and then Present (Cleanup_Actions (N)); 5340 5341 Has_Postcondition : constant Boolean := 5342 Nkind (N) = N_Subprogram_Body 5343 and then Present 5344 (Postconditions_Proc 5345 (Unique_Defining_Entity (N))); 5346 5347 Actions_Required : constant Boolean := 5348 Requires_Cleanup_Actions (N, True) 5349 or else Is_Asynchronous_Call 5350 or else Is_Master 5351 or else Is_Protected_Subp_Body 5352 or else Is_Task_Allocation 5353 or else Is_Task_Body 5354 or else Needs_Sec_Stack_Mark 5355 or else Needs_Custom_Cleanup; 5356 5357 HSS : Node_Id := Handled_Statement_Sequence (N); 5358 Loc : Source_Ptr; 5359 Cln : List_Id; 5360 5361 procedure Wrap_HSS_In_Block; 5362 -- Move HSS inside a new block along with the original exception 5363 -- handlers. Make the newly generated block the sole statement of HSS. 5364 5365 ----------------------- 5366 -- Wrap_HSS_In_Block -- 5367 ----------------------- 5368 5369 procedure Wrap_HSS_In_Block is 5370 Block : Node_Id; 5371 Block_Id : Entity_Id; 5372 End_Lab : Node_Id; 5373 5374 begin 5375 -- Preserve end label to provide proper cross-reference information 5376 5377 End_Lab := End_Label (HSS); 5378 Block := 5379 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS); 5380 5381 Block_Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); 5382 Set_Identifier (Block, New_Occurrence_Of (Block_Id, Loc)); 5383 Set_Etype (Block_Id, Standard_Void_Type); 5384 Set_Block_Node (Block_Id, Identifier (Block)); 5385 5386 -- Signal the finalization machinery that this particular block 5387 -- contains the original context. 5388 5389 Set_Is_Finalization_Wrapper (Block); 5390 5391 Set_Handled_Statement_Sequence (N, 5392 Make_Handled_Sequence_Of_Statements (Loc, New_List (Block))); 5393 HSS := Handled_Statement_Sequence (N); 5394 5395 Set_First_Real_Statement (HSS, Block); 5396 Set_End_Label (HSS, End_Lab); 5397 5398 -- Comment needed here, see RH for 1.306 ??? 5399 5400 if Nkind (N) = N_Subprogram_Body then 5401 Set_Has_Nested_Block_With_Handler (Scop); 5402 end if; 5403 end Wrap_HSS_In_Block; 5404 5405 -- Start of processing for Expand_Cleanup_Actions 5406 5407 begin 5408 -- The current construct does not need any form of servicing 5409 5410 if not Actions_Required then 5411 return; 5412 5413 -- If the current node is a rewritten task body and the descriptors have 5414 -- not been delayed (due to some nested instantiations), do not generate 5415 -- redundant cleanup actions. 5416 5417 elsif Is_Task_Body 5418 and then Nkind (N) = N_Subprogram_Body 5419 and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N)) 5420 then 5421 return; 5422 end if; 5423 5424 -- If an extended return statement contains something like 5425 -- 5426 -- X := F (...); 5427 -- 5428 -- where F is a build-in-place function call returning a controlled 5429 -- type, then a temporary object will be implicitly declared as part 5430 -- of the statement list, and this will need cleanup. In such cases, 5431 -- we transform: 5432 -- 5433 -- return Result : T := ... do 5434 -- <statements> -- possibly with handlers 5435 -- end return; 5436 -- 5437 -- into: 5438 -- 5439 -- return Result : T := ... do 5440 -- declare -- no declarations 5441 -- begin 5442 -- <statements> -- possibly with handlers 5443 -- end; -- no handlers 5444 -- end return; 5445 -- 5446 -- So Expand_Cleanup_Actions will end up being called recursively on the 5447 -- block statement. 5448 5449 if Nkind (N) = N_Extended_Return_Statement then 5450 declare 5451 Block : constant Node_Id := 5452 Make_Block_Statement (Sloc (N), 5453 Declarations => Empty_List, 5454 Handled_Statement_Sequence => 5455 Handled_Statement_Sequence (N)); 5456 begin 5457 Set_Handled_Statement_Sequence (N, 5458 Make_Handled_Sequence_Of_Statements (Sloc (N), 5459 Statements => New_List (Block))); 5460 5461 Analyze (Block); 5462 end; 5463 5464 -- Analysis of the block did all the work 5465 5466 return; 5467 end if; 5468 5469 if Needs_Custom_Cleanup then 5470 Cln := Cleanup_Actions (N); 5471 else 5472 Cln := No_List; 5473 end if; 5474 5475 declare 5476 Decls : List_Id := Declarations (N); 5477 Fin_Id : Entity_Id; 5478 Mark : Entity_Id := Empty; 5479 New_Decls : List_Id; 5480 5481 begin 5482 -- If we are generating expanded code for debugging purposes, use the 5483 -- Sloc of the point of insertion for the cleanup code. The Sloc will 5484 -- be updated subsequently to reference the proper line in .dg files. 5485 -- If we are not debugging generated code, use No_Location instead, 5486 -- so that no debug information is generated for the cleanup code. 5487 -- This makes the behavior of the NEXT command in GDB monotonic, and 5488 -- makes the placement of breakpoints more accurate. 5489 5490 if Debug_Generated_Code then 5491 Loc := Sloc (Scop); 5492 else 5493 Loc := No_Location; 5494 end if; 5495 5496 -- A task activation call has already been built for a task 5497 -- allocation block. 5498 5499 if not Is_Task_Allocation then 5500 Build_Task_Activation_Call (N); 5501 end if; 5502 5503 if Is_Master then 5504 Establish_Task_Master (N); 5505 end if; 5506 5507 New_Decls := New_List; 5508 5509 -- If secondary stack is in use, generate: 5510 -- 5511 -- Mnn : constant Mark_Id := SS_Mark; 5512 5513 if Needs_Sec_Stack_Mark then 5514 Mark := Make_Temporary (Loc, 'M'); 5515 5516 Append_To (New_Decls, Build_SS_Mark_Call (Loc, Mark)); 5517 Set_Uses_Sec_Stack (Scop, False); 5518 end if; 5519 5520 -- If exception handlers are present, wrap the sequence of statements 5521 -- in a block since it is not possible to have exception handlers and 5522 -- an At_End handler in the same construct. 5523 5524 if Present (Exception_Handlers (HSS)) then 5525 Wrap_HSS_In_Block; 5526 5527 -- Ensure that the First_Real_Statement field is set 5528 5529 elsif No (First_Real_Statement (HSS)) then 5530 Set_First_Real_Statement (HSS, First (Statements (HSS))); 5531 end if; 5532 5533 -- Do not move the Activation_Chain declaration in the context of 5534 -- task allocation blocks. Task allocation blocks use _chain in their 5535 -- cleanup handlers and gigi complains if it is declared in the 5536 -- sequence of statements of the scope that declares the handler. 5537 5538 if Is_Task_Allocation then 5539 declare 5540 Chain : constant Entity_Id := Activation_Chain_Entity (N); 5541 Decl : Node_Id; 5542 5543 begin 5544 Decl := First (Decls); 5545 while Nkind (Decl) /= N_Object_Declaration 5546 or else Defining_Identifier (Decl) /= Chain 5547 loop 5548 Next (Decl); 5549 5550 -- A task allocation block should always include a _chain 5551 -- declaration. 5552 5553 pragma Assert (Present (Decl)); 5554 end loop; 5555 5556 Remove (Decl); 5557 Prepend_To (New_Decls, Decl); 5558 end; 5559 end if; 5560 5561 -- Move the _postconditions subprogram declaration and its associated 5562 -- objects into the declarations section so that it is callable 5563 -- within _postconditions. 5564 5565 if Has_Postcondition then 5566 declare 5567 Decl : Node_Id; 5568 Prev_Decl : Node_Id; 5569 5570 begin 5571 Decl := 5572 Prev (Subprogram_Body 5573 (Postconditions_Proc (Current_Subprogram))); 5574 while Present (Decl) loop 5575 Prev_Decl := Prev (Decl); 5576 5577 Remove (Decl); 5578 Prepend_To (New_Decls, Decl); 5579 5580 exit when Nkind (Decl) = N_Subprogram_Declaration 5581 and then Chars (Corresponding_Body (Decl)) 5582 = Name_uPostconditions; 5583 5584 Decl := Prev_Decl; 5585 end loop; 5586 end; 5587 end if; 5588 5589 -- Ensure the presence of a declaration list in order to successfully 5590 -- append all original statements to it. 5591 5592 if No (Decls) then 5593 Set_Declarations (N, New_List); 5594 Decls := Declarations (N); 5595 end if; 5596 5597 -- Move the declarations into the sequence of statements in order to 5598 -- have them protected by the At_End handler. It may seem weird to 5599 -- put declarations in the sequence of statement but in fact nothing 5600 -- forbids that at the tree level. 5601 5602 Append_List_To (Decls, Statements (HSS)); 5603 Set_Statements (HSS, Decls); 5604 5605 -- Reset the Sloc of the handled statement sequence to properly 5606 -- reflect the new initial "statement" in the sequence. 5607 5608 Set_Sloc (HSS, Sloc (First (Decls))); 5609 5610 -- The declarations of finalizer spec and auxiliary variables replace 5611 -- the old declarations that have been moved inward. 5612 5613 Set_Declarations (N, New_Decls); 5614 Analyze_Declarations (New_Decls); 5615 5616 -- Generate finalization calls for all controlled objects appearing 5617 -- in the statements of N. Add context specific cleanup for various 5618 -- constructs. 5619 5620 Build_Finalizer 5621 (N => N, 5622 Clean_Stmts => Build_Cleanup_Statements (N, Cln), 5623 Mark_Id => Mark, 5624 Top_Decls => New_Decls, 5625 Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body 5626 or else Is_Master, 5627 Fin_Id => Fin_Id); 5628 5629 if Present (Fin_Id) then 5630 Build_Finalizer_Call (N, Fin_Id); 5631 end if; 5632 end; 5633 end Expand_Cleanup_Actions; 5634 5635 --------------------------- 5636 -- Expand_N_Package_Body -- 5637 --------------------------- 5638 5639 -- Add call to Activate_Tasks if body is an activator (actual processing 5640 -- is in chapter 9). 5641 5642 -- Generate subprogram descriptor for elaboration routine 5643 5644 -- Encode entity names in package body 5645 5646 procedure Expand_N_Package_Body (N : Node_Id) is 5647 Spec_Id : constant Entity_Id := Corresponding_Spec (N); 5648 Fin_Id : Entity_Id; 5649 5650 begin 5651 -- This is done only for non-generic packages 5652 5653 if Ekind (Spec_Id) = E_Package then 5654 Push_Scope (Spec_Id); 5655 5656 -- Build dispatch tables of library level tagged types 5657 5658 if Tagged_Type_Expansion 5659 and then Is_Library_Level_Entity (Spec_Id) 5660 then 5661 Build_Static_Dispatch_Tables (N); 5662 end if; 5663 5664 Build_Task_Activation_Call (N); 5665 5666 -- Verify the run-time semantics of pragma Initial_Condition at the 5667 -- end of the body statements. 5668 5669 Expand_Pragma_Initial_Condition (Spec_Id, N); 5670 5671 -- If this is a library-level package and unnesting is enabled, 5672 -- check for the presence of blocks with nested subprograms occurring 5673 -- in elaboration code, and generate procedures to encapsulate the 5674 -- blocks in case the nested subprograms make up-level references. 5675 5676 if Unnest_Subprogram_Mode 5677 and then 5678 Is_Library_Level_Entity (Current_Scope) 5679 then 5680 Check_Unnesting_Elaboration_Code (N); 5681 Check_Unnesting_In_Decls_Or_Stmts (Declarations (N)); 5682 Check_Unnesting_In_Handlers (N); 5683 end if; 5684 5685 Pop_Scope; 5686 end if; 5687 5688 Set_Elaboration_Flag (N, Spec_Id); 5689 Set_In_Package_Body (Spec_Id, False); 5690 5691 -- Set to encode entity names in package body before gigi is called 5692 5693 Qualify_Entity_Names (N); 5694 5695 if Ekind (Spec_Id) /= E_Generic_Package then 5696 Build_Finalizer 5697 (N => N, 5698 Clean_Stmts => No_List, 5699 Mark_Id => Empty, 5700 Top_Decls => No_List, 5701 Defer_Abort => False, 5702 Fin_Id => Fin_Id); 5703 5704 if Present (Fin_Id) then 5705 declare 5706 Body_Ent : Node_Id := Defining_Unit_Name (N); 5707 5708 begin 5709 if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then 5710 Body_Ent := Defining_Identifier (Body_Ent); 5711 end if; 5712 5713 Set_Finalizer (Body_Ent, Fin_Id); 5714 end; 5715 end if; 5716 end if; 5717 end Expand_N_Package_Body; 5718 5719 ---------------------------------- 5720 -- Expand_N_Package_Declaration -- 5721 ---------------------------------- 5722 5723 -- Add call to Activate_Tasks if there are tasks declared and the package 5724 -- has no body. Note that in Ada 83 this may result in premature activation 5725 -- of some tasks, given that we cannot tell whether a body will eventually 5726 -- appear. 5727 5728 procedure Expand_N_Package_Declaration (N : Node_Id) is 5729 Id : constant Entity_Id := Defining_Entity (N); 5730 Spec : constant Node_Id := Specification (N); 5731 Decls : List_Id; 5732 Fin_Id : Entity_Id; 5733 5734 No_Body : Boolean := False; 5735 -- True in the case of a package declaration that is a compilation 5736 -- unit and for which no associated body will be compiled in this 5737 -- compilation. 5738 5739 begin 5740 -- Case of a package declaration other than a compilation unit 5741 5742 if Nkind (Parent (N)) /= N_Compilation_Unit then 5743 null; 5744 5745 -- Case of a compilation unit that does not require a body 5746 5747 elsif not Body_Required (Parent (N)) 5748 and then not Unit_Requires_Body (Id) 5749 then 5750 No_Body := True; 5751 5752 -- Special case of generating calling stubs for a remote call interface 5753 -- package: even though the package declaration requires one, the body 5754 -- won't be processed in this compilation (so any stubs for RACWs 5755 -- declared in the package must be generated here, along with the spec). 5756 5757 elsif Parent (N) = Cunit (Main_Unit) 5758 and then Is_Remote_Call_Interface (Id) 5759 and then Distribution_Stub_Mode = Generate_Caller_Stub_Body 5760 then 5761 No_Body := True; 5762 end if; 5763 5764 -- For a nested instance, delay processing until freeze point 5765 5766 if Has_Delayed_Freeze (Id) 5767 and then Nkind (Parent (N)) /= N_Compilation_Unit 5768 then 5769 return; 5770 end if; 5771 5772 -- For a package declaration that implies no associated body, generate 5773 -- task activation call and RACW supporting bodies now (since we won't 5774 -- have a specific separate compilation unit for that). 5775 5776 if No_Body then 5777 Push_Scope (Id); 5778 5779 -- Generate RACW subprogram bodies 5780 5781 if Has_RACW (Id) then 5782 Decls := Private_Declarations (Spec); 5783 5784 if No (Decls) then 5785 Decls := Visible_Declarations (Spec); 5786 end if; 5787 5788 if No (Decls) then 5789 Decls := New_List; 5790 Set_Visible_Declarations (Spec, Decls); 5791 end if; 5792 5793 Append_RACW_Bodies (Decls, Id); 5794 Analyze_List (Decls); 5795 end if; 5796 5797 -- Generate task activation call as last step of elaboration 5798 5799 if Present (Activation_Chain_Entity (N)) then 5800 Build_Task_Activation_Call (N); 5801 end if; 5802 5803 -- Verify the run-time semantics of pragma Initial_Condition at the 5804 -- end of the private declarations when the package lacks a body. 5805 5806 Expand_Pragma_Initial_Condition (Id, N); 5807 5808 Pop_Scope; 5809 end if; 5810 5811 -- Build dispatch tables of library level tagged types 5812 5813 if Tagged_Type_Expansion 5814 and then (Is_Compilation_Unit (Id) 5815 or else (Is_Generic_Instance (Id) 5816 and then Is_Library_Level_Entity (Id))) 5817 then 5818 Build_Static_Dispatch_Tables (N); 5819 end if; 5820 5821 -- Note: it is not necessary to worry about generating a subprogram 5822 -- descriptor, since the only way to get exception handlers into a 5823 -- package spec is to include instantiations, and that would cause 5824 -- generation of subprogram descriptors to be delayed in any case. 5825 5826 -- Set to encode entity names in package spec before gigi is called 5827 5828 Qualify_Entity_Names (N); 5829 5830 if Ekind (Id) /= E_Generic_Package then 5831 Build_Finalizer 5832 (N => N, 5833 Clean_Stmts => No_List, 5834 Mark_Id => Empty, 5835 Top_Decls => No_List, 5836 Defer_Abort => False, 5837 Fin_Id => Fin_Id); 5838 5839 Set_Finalizer (Id, Fin_Id); 5840 end if; 5841 5842 -- If this is a library-level package and unnesting is enabled, 5843 -- check for the presence of blocks with nested subprograms occurring 5844 -- in elaboration code, and generate procedures to encapsulate the 5845 -- blocks in case the nested subprograms make up-level references. 5846 5847 if Unnest_Subprogram_Mode 5848 and then Is_Library_Level_Entity (Current_Scope) 5849 then 5850 Check_Unnesting_In_Decls_Or_Stmts (Visible_Declarations (Spec)); 5851 Check_Unnesting_In_Decls_Or_Stmts (Private_Declarations (Spec)); 5852 end if; 5853 end Expand_N_Package_Declaration; 5854 5855 ---------------------------- 5856 -- Find_Transient_Context -- 5857 ---------------------------- 5858 5859 function Find_Transient_Context (N : Node_Id) return Node_Id is 5860 Curr : Node_Id; 5861 Prev : Node_Id; 5862 5863 begin 5864 Curr := N; 5865 Prev := Empty; 5866 while Present (Curr) loop 5867 case Nkind (Curr) is 5868 5869 -- Declarations 5870 5871 -- Declarations act as a boundary for a transient scope even if 5872 -- they are not wrapped, see Wrap_Transient_Declaration. 5873 5874 when N_Object_Declaration 5875 | N_Object_Renaming_Declaration 5876 | N_Subtype_Declaration 5877 => 5878 return Curr; 5879 5880 -- Statements 5881 5882 -- Statements and statement-like constructs act as a boundary for 5883 -- a transient scope. 5884 5885 when N_Accept_Alternative 5886 | N_Attribute_Definition_Clause 5887 | N_Case_Statement 5888 | N_Case_Statement_Alternative 5889 | N_Code_Statement 5890 | N_Delay_Alternative 5891 | N_Delay_Until_Statement 5892 | N_Delay_Relative_Statement 5893 | N_Discriminant_Association 5894 | N_Elsif_Part 5895 | N_Entry_Body_Formal_Part 5896 | N_Exit_Statement 5897 | N_If_Statement 5898 | N_Iteration_Scheme 5899 | N_Terminate_Alternative 5900 => 5901 pragma Assert (Present (Prev)); 5902 return Prev; 5903 5904 when N_Assignment_Statement => 5905 return Curr; 5906 5907 when N_Entry_Call_Statement 5908 | N_Procedure_Call_Statement 5909 => 5910 -- When an entry or procedure call acts as the alternative of a 5911 -- conditional or timed entry call, the proper context is that 5912 -- of the alternative. 5913 5914 if Nkind (Parent (Curr)) = N_Entry_Call_Alternative 5915 and then Nkind (Parent (Parent (Curr))) in 5916 N_Conditional_Entry_Call | N_Timed_Entry_Call 5917 then 5918 return Parent (Parent (Curr)); 5919 5920 -- General case for entry or procedure calls 5921 5922 else 5923 return Curr; 5924 end if; 5925 5926 when N_Pragma => 5927 5928 -- Pragma Check is not a valid transient context in GNATprove 5929 -- mode because the pragma must remain unchanged. 5930 5931 if GNATprove_Mode 5932 and then Get_Pragma_Id (Curr) = Pragma_Check 5933 then 5934 return Empty; 5935 5936 -- General case for pragmas 5937 5938 else 5939 return Curr; 5940 end if; 5941 5942 when N_Raise_Statement => 5943 return Curr; 5944 5945 when N_Simple_Return_Statement => 5946 5947 -- A return statement is not a valid transient context when the 5948 -- function itself requires transient scope management because 5949 -- the result will be reclaimed too early. 5950 5951 if Requires_Transient_Scope (Etype 5952 (Return_Applies_To (Return_Statement_Entity (Curr)))) 5953 then 5954 return Empty; 5955 5956 -- General case for return statements 5957 5958 else 5959 return Curr; 5960 end if; 5961 5962 -- Special 5963 5964 when N_Attribute_Reference => 5965 if Is_Procedure_Attribute_Name (Attribute_Name (Curr)) then 5966 return Curr; 5967 end if; 5968 5969 -- An Ada 2012 iterator specification is not a valid context 5970 -- because Analyze_Iterator_Specification already employs special 5971 -- processing for it. 5972 5973 when N_Iterator_Specification => 5974 return Empty; 5975 5976 when N_Loop_Parameter_Specification => 5977 5978 -- An iteration scheme is not a valid context because routine 5979 -- Analyze_Iteration_Scheme already employs special processing. 5980 5981 if Nkind (Parent (Curr)) = N_Iteration_Scheme then 5982 return Empty; 5983 else 5984 return Parent (Curr); 5985 end if; 5986 5987 -- Termination 5988 5989 -- The following nodes represent "dummy contexts" which do not 5990 -- need to be wrapped. 5991 5992 when N_Component_Declaration 5993 | N_Discriminant_Specification 5994 | N_Parameter_Specification 5995 => 5996 return Empty; 5997 5998 -- If the traversal leaves a scope without having been able to 5999 -- find a construct to wrap, something is going wrong, but this 6000 -- can happen in error situations that are not detected yet (such 6001 -- as a dynamic string in a pragma Export). 6002 6003 when N_Block_Statement 6004 | N_Entry_Body 6005 | N_Package_Body 6006 | N_Package_Declaration 6007 | N_Protected_Body 6008 | N_Subprogram_Body 6009 | N_Task_Body 6010 => 6011 return Empty; 6012 6013 -- Default 6014 6015 when others => 6016 null; 6017 end case; 6018 6019 Prev := Curr; 6020 Curr := Parent (Curr); 6021 end loop; 6022 6023 return Empty; 6024 end Find_Transient_Context; 6025 6026 ---------------------------------- 6027 -- Has_New_Controlled_Component -- 6028 ---------------------------------- 6029 6030 function Has_New_Controlled_Component (E : Entity_Id) return Boolean is 6031 Comp : Entity_Id; 6032 6033 begin 6034 if not Is_Tagged_Type (E) then 6035 return Has_Controlled_Component (E); 6036 elsif not Is_Derived_Type (E) then 6037 return Has_Controlled_Component (E); 6038 end if; 6039 6040 Comp := First_Component (E); 6041 while Present (Comp) loop 6042 if Chars (Comp) = Name_uParent then 6043 null; 6044 6045 elsif Scope (Original_Record_Component (Comp)) = E 6046 and then Needs_Finalization (Etype (Comp)) 6047 then 6048 return True; 6049 end if; 6050 6051 Next_Component (Comp); 6052 end loop; 6053 6054 return False; 6055 end Has_New_Controlled_Component; 6056 6057 --------------------------------- 6058 -- Has_Simple_Protected_Object -- 6059 --------------------------------- 6060 6061 function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is 6062 begin 6063 if Has_Task (T) then 6064 return False; 6065 6066 elsif Is_Simple_Protected_Type (T) then 6067 return True; 6068 6069 elsif Is_Array_Type (T) then 6070 return Has_Simple_Protected_Object (Component_Type (T)); 6071 6072 elsif Is_Record_Type (T) then 6073 declare 6074 Comp : Entity_Id; 6075 6076 begin 6077 Comp := First_Component (T); 6078 while Present (Comp) loop 6079 if Has_Simple_Protected_Object (Etype (Comp)) then 6080 return True; 6081 end if; 6082 6083 Next_Component (Comp); 6084 end loop; 6085 6086 return False; 6087 end; 6088 6089 else 6090 return False; 6091 end if; 6092 end Has_Simple_Protected_Object; 6093 6094 ------------------------------------ 6095 -- Insert_Actions_In_Scope_Around -- 6096 ------------------------------------ 6097 6098 procedure Insert_Actions_In_Scope_Around 6099 (N : Node_Id; 6100 Clean : Boolean; 6101 Manage_SS : Boolean) 6102 is 6103 Act_Before : constant List_Id := 6104 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before); 6105 Act_After : constant List_Id := 6106 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After); 6107 Act_Cleanup : constant List_Id := 6108 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup); 6109 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack. 6110 -- Last), but this was incorrect as Process_Transients_In_Scope may 6111 -- introduce new scopes and cause a reallocation of Scope_Stack.Table. 6112 6113 procedure Process_Transients_In_Scope 6114 (First_Object : Node_Id; 6115 Last_Object : Node_Id; 6116 Related_Node : Node_Id); 6117 -- Find all transient objects in the list First_Object .. Last_Object 6118 -- and generate finalization actions for them. Related_Node denotes the 6119 -- node which created all transient objects. 6120 6121 --------------------------------- 6122 -- Process_Transients_In_Scope -- 6123 --------------------------------- 6124 6125 procedure Process_Transients_In_Scope 6126 (First_Object : Node_Id; 6127 Last_Object : Node_Id; 6128 Related_Node : Node_Id) 6129 is 6130 Must_Hook : Boolean := False; 6131 -- Flag denoting whether the context requires transient object 6132 -- export to the outer finalizer. 6133 6134 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result; 6135 -- Determine whether an arbitrary node denotes a subprogram call 6136 6137 procedure Detect_Subprogram_Call is 6138 new Traverse_Proc (Is_Subprogram_Call); 6139 6140 procedure Process_Transient_In_Scope 6141 (Obj_Decl : Node_Id; 6142 Blk_Data : Finalization_Exception_Data; 6143 Blk_Stmts : List_Id); 6144 -- Generate finalization actions for a single transient object 6145 -- denoted by object declaration Obj_Decl. Blk_Data is the 6146 -- exception data of the enclosing block. Blk_Stmts denotes the 6147 -- statements of the enclosing block. 6148 6149 ------------------------ 6150 -- Is_Subprogram_Call -- 6151 ------------------------ 6152 6153 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is 6154 begin 6155 -- A regular procedure or function call 6156 6157 if Nkind (N) in N_Subprogram_Call then 6158 Must_Hook := True; 6159 return Abandon; 6160 6161 -- Special cases 6162 6163 -- Heavy expansion may relocate function calls outside the related 6164 -- node. Inspect the original node to detect the initial placement 6165 -- of the call. 6166 6167 elsif Is_Rewrite_Substitution (N) then 6168 Detect_Subprogram_Call (Original_Node (N)); 6169 6170 if Must_Hook then 6171 return Abandon; 6172 else 6173 return OK; 6174 end if; 6175 6176 -- Generalized indexing always involves a function call 6177 6178 elsif Nkind (N) = N_Indexed_Component 6179 and then Present (Generalized_Indexing (N)) 6180 then 6181 Must_Hook := True; 6182 return Abandon; 6183 6184 -- Keep searching 6185 6186 else 6187 return OK; 6188 end if; 6189 end Is_Subprogram_Call; 6190 6191 -------------------------------- 6192 -- Process_Transient_In_Scope -- 6193 -------------------------------- 6194 6195 procedure Process_Transient_In_Scope 6196 (Obj_Decl : Node_Id; 6197 Blk_Data : Finalization_Exception_Data; 6198 Blk_Stmts : List_Id) 6199 is 6200 Loc : constant Source_Ptr := Sloc (Obj_Decl); 6201 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); 6202 Fin_Call : Node_Id; 6203 Fin_Stmts : List_Id; 6204 Hook_Assign : Node_Id; 6205 Hook_Clear : Node_Id; 6206 Hook_Decl : Node_Id; 6207 Hook_Insert : Node_Id; 6208 Ptr_Decl : Node_Id; 6209 6210 begin 6211 -- Mark the transient object as successfully processed to avoid 6212 -- double finalization. 6213 6214 Set_Is_Finalized_Transient (Obj_Id); 6215 6216 -- Construct all the pieces necessary to hook and finalize the 6217 -- transient object. 6218 6219 Build_Transient_Object_Statements 6220 (Obj_Decl => Obj_Decl, 6221 Fin_Call => Fin_Call, 6222 Hook_Assign => Hook_Assign, 6223 Hook_Clear => Hook_Clear, 6224 Hook_Decl => Hook_Decl, 6225 Ptr_Decl => Ptr_Decl); 6226 6227 -- The context contains at least one subprogram call which may 6228 -- raise an exception. This scenario employs "hooking" to pass 6229 -- transient objects to the enclosing finalizer in case of an 6230 -- exception. 6231 6232 if Must_Hook then 6233 6234 -- Add the access type which provides a reference to the 6235 -- transient object. Generate: 6236 6237 -- type Ptr_Typ is access all Desig_Typ; 6238 6239 Insert_Action (Obj_Decl, Ptr_Decl); 6240 6241 -- Add the temporary which acts as a hook to the transient 6242 -- object. Generate: 6243 6244 -- Hook : Ptr_Typ := null; 6245 6246 Insert_Action (Obj_Decl, Hook_Decl); 6247 6248 -- When the transient object is initialized by an aggregate, 6249 -- the hook must capture the object after the last aggregate 6250 -- assignment takes place. Only then is the object considered 6251 -- fully initialized. Generate: 6252 6253 -- Hook := Ptr_Typ (Obj_Id); 6254 -- <or> 6255 -- Hook := Obj_Id'Unrestricted_Access; 6256 6257 -- Similarly if we have a build in place call: we must 6258 -- initialize Hook only after the call has happened, otherwise 6259 -- Obj_Id will not be initialized yet. 6260 6261 if Ekind (Obj_Id) in E_Constant | E_Variable then 6262 if Present (Last_Aggregate_Assignment (Obj_Id)) then 6263 Hook_Insert := Last_Aggregate_Assignment (Obj_Id); 6264 elsif Present (BIP_Initialization_Call (Obj_Id)) then 6265 Hook_Insert := BIP_Initialization_Call (Obj_Id); 6266 else 6267 Hook_Insert := Obj_Decl; 6268 end if; 6269 6270 -- Otherwise the hook seizes the related object immediately 6271 6272 else 6273 Hook_Insert := Obj_Decl; 6274 end if; 6275 6276 Insert_After_And_Analyze (Hook_Insert, Hook_Assign); 6277 end if; 6278 6279 -- When exception propagation is enabled wrap the hook clear 6280 -- statement and the finalization call into a block to catch 6281 -- potential exceptions raised during finalization. Generate: 6282 6283 -- begin 6284 -- [Hook := null;] 6285 -- [Deep_]Finalize (Obj_Ref); 6286 6287 -- exception 6288 -- when others => 6289 -- if not Raised then 6290 -- Raised := True; 6291 -- Save_Occurrence 6292 -- (Enn, Get_Current_Excep.all.all); 6293 -- end if; 6294 -- end; 6295 6296 if Exceptions_OK then 6297 Fin_Stmts := New_List; 6298 6299 if Must_Hook then 6300 Append_To (Fin_Stmts, Hook_Clear); 6301 end if; 6302 6303 Append_To (Fin_Stmts, Fin_Call); 6304 6305 Prepend_To (Blk_Stmts, 6306 Make_Block_Statement (Loc, 6307 Handled_Statement_Sequence => 6308 Make_Handled_Sequence_Of_Statements (Loc, 6309 Statements => Fin_Stmts, 6310 Exception_Handlers => New_List ( 6311 Build_Exception_Handler (Blk_Data))))); 6312 6313 -- Otherwise generate: 6314 6315 -- [Hook := null;] 6316 -- [Deep_]Finalize (Obj_Ref); 6317 6318 -- Note that the statements are inserted in reverse order to 6319 -- achieve the desired final order outlined above. 6320 6321 else 6322 Prepend_To (Blk_Stmts, Fin_Call); 6323 6324 if Must_Hook then 6325 Prepend_To (Blk_Stmts, Hook_Clear); 6326 end if; 6327 end if; 6328 end Process_Transient_In_Scope; 6329 6330 -- Local variables 6331 6332 Built : Boolean := False; 6333 Blk_Data : Finalization_Exception_Data; 6334 Blk_Decl : Node_Id := Empty; 6335 Blk_Decls : List_Id := No_List; 6336 Blk_Ins : Node_Id; 6337 Blk_Stmts : List_Id := No_List; 6338 Loc : Source_Ptr := No_Location; 6339 Obj_Decl : Node_Id; 6340 6341 -- Start of processing for Process_Transients_In_Scope 6342 6343 begin 6344 -- The expansion performed by this routine is as follows: 6345 6346 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ; 6347 -- Hook_1 : Ptr_Typ_1 := null; 6348 -- Ctrl_Trans_Obj_1 : ...; 6349 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access; 6350 -- . . . 6351 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ; 6352 -- Hook_N : Ptr_Typ_N := null; 6353 -- Ctrl_Trans_Obj_N : ...; 6354 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access; 6355 6356 -- declare 6357 -- Abrt : constant Boolean := ...; 6358 -- Ex : Exception_Occurrence; 6359 -- Raised : Boolean := False; 6360 6361 -- begin 6362 -- Abort_Defer; 6363 6364 -- begin 6365 -- Hook_N := null; 6366 -- [Deep_]Finalize (Ctrl_Trans_Obj_N); 6367 6368 -- exception 6369 -- when others => 6370 -- if not Raised then 6371 -- Raised := True; 6372 -- Save_Occurrence (Ex, Get_Current_Excep.all.all); 6373 -- end; 6374 -- . . . 6375 -- begin 6376 -- Hook_1 := null; 6377 -- [Deep_]Finalize (Ctrl_Trans_Obj_1); 6378 6379 -- exception 6380 -- when others => 6381 -- if not Raised then 6382 -- Raised := True; 6383 -- Save_Occurrence (Ex, Get_Current_Excep.all.all); 6384 -- end; 6385 6386 -- Abort_Undefer; 6387 6388 -- if Raised and not Abrt then 6389 -- Raise_From_Controlled_Operation (Ex); 6390 -- end if; 6391 -- end; 6392 6393 -- Recognize a scenario where the transient context is an object 6394 -- declaration initialized by a build-in-place function call: 6395 6396 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call); 6397 6398 -- The rough expansion of the above is: 6399 6400 -- Temp : ... := Ctrl_Func_Call; 6401 -- Obj : ...; 6402 -- Res : ... := BIP_Func_Call (..., Obj, ...); 6403 6404 -- The finalization of any transient object must happen after the 6405 -- build-in-place function call is executed. 6406 6407 if Nkind (N) = N_Object_Declaration 6408 and then Present (BIP_Initialization_Call (Defining_Identifier (N))) 6409 then 6410 Must_Hook := True; 6411 Blk_Ins := BIP_Initialization_Call (Defining_Identifier (N)); 6412 6413 -- Search the context for at least one subprogram call. If found, the 6414 -- machinery exports all transient objects to the enclosing finalizer 6415 -- due to the possibility of abnormal call termination. 6416 6417 else 6418 Detect_Subprogram_Call (N); 6419 Blk_Ins := Last_Object; 6420 end if; 6421 6422 if Clean then 6423 Insert_List_After_And_Analyze (Blk_Ins, Act_Cleanup); 6424 end if; 6425 6426 -- Examine all objects in the list First_Object .. Last_Object 6427 6428 Obj_Decl := First_Object; 6429 while Present (Obj_Decl) loop 6430 if Nkind (Obj_Decl) = N_Object_Declaration 6431 and then Analyzed (Obj_Decl) 6432 and then Is_Finalizable_Transient (Obj_Decl, N) 6433 6434 -- Do not process the node to be wrapped since it will be 6435 -- handled by the enclosing finalizer. 6436 6437 and then Obj_Decl /= Related_Node 6438 then 6439 Loc := Sloc (Obj_Decl); 6440 6441 -- Before generating the cleanup code for the first transient 6442 -- object, create a wrapper block which houses all hook clear 6443 -- statements and finalization calls. This wrapper is needed by 6444 -- the back end. 6445 6446 if not Built then 6447 Built := True; 6448 Blk_Stmts := New_List; 6449 6450 -- Generate: 6451 -- Abrt : constant Boolean := ...; 6452 -- Ex : Exception_Occurrence; 6453 -- Raised : Boolean := False; 6454 6455 if Exceptions_OK then 6456 Blk_Decls := New_List; 6457 Build_Object_Declarations (Blk_Data, Blk_Decls, Loc); 6458 end if; 6459 6460 Blk_Decl := 6461 Make_Block_Statement (Loc, 6462 Declarations => Blk_Decls, 6463 Handled_Statement_Sequence => 6464 Make_Handled_Sequence_Of_Statements (Loc, 6465 Statements => Blk_Stmts)); 6466 end if; 6467 6468 -- Construct all necessary circuitry to hook and finalize a 6469 -- single transient object. 6470 6471 pragma Assert (Present (Blk_Stmts)); 6472 Process_Transient_In_Scope 6473 (Obj_Decl => Obj_Decl, 6474 Blk_Data => Blk_Data, 6475 Blk_Stmts => Blk_Stmts); 6476 end if; 6477 6478 -- Terminate the scan after the last object has been processed to 6479 -- avoid touching unrelated code. 6480 6481 if Obj_Decl = Last_Object then 6482 exit; 6483 end if; 6484 6485 Next (Obj_Decl); 6486 end loop; 6487 6488 -- Complete the decoration of the enclosing finalization block and 6489 -- insert it into the tree. 6490 6491 if Present (Blk_Decl) then 6492 6493 pragma Assert (Present (Blk_Stmts)); 6494 pragma Assert (Loc /= No_Location); 6495 6496 -- Note that this Abort_Undefer does not require a extra block or 6497 -- an AT_END handler because each finalization exception is caught 6498 -- in its own corresponding finalization block. As a result, the 6499 -- call to Abort_Defer always takes place. 6500 6501 if Abort_Allowed then 6502 Prepend_To (Blk_Stmts, 6503 Build_Runtime_Call (Loc, RE_Abort_Defer)); 6504 6505 Append_To (Blk_Stmts, 6506 Build_Runtime_Call (Loc, RE_Abort_Undefer)); 6507 end if; 6508 6509 -- Generate: 6510 -- if Raised and then not Abrt then 6511 -- Raise_From_Controlled_Operation (Ex); 6512 -- end if; 6513 6514 if Exceptions_OK then 6515 Append_To (Blk_Stmts, Build_Raise_Statement (Blk_Data)); 6516 end if; 6517 6518 Insert_After_And_Analyze (Blk_Ins, Blk_Decl); 6519 end if; 6520 end Process_Transients_In_Scope; 6521 6522 -- Local variables 6523 6524 Loc : constant Source_Ptr := Sloc (N); 6525 Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped; 6526 First_Obj : Node_Id; 6527 Last_Obj : Node_Id; 6528 Mark_Id : Entity_Id; 6529 Target : Node_Id; 6530 6531 -- Start of processing for Insert_Actions_In_Scope_Around 6532 6533 begin 6534 -- Nothing to do if the scope does not manage the secondary stack or 6535 -- does not contain meaningful actions for insertion. 6536 6537 if not Manage_SS 6538 and then No (Act_Before) 6539 and then No (Act_After) 6540 and then No (Act_Cleanup) 6541 then 6542 return; 6543 end if; 6544 6545 -- If the node to be wrapped is the trigger of an asynchronous select, 6546 -- it is not part of a statement list. The actions must be inserted 6547 -- before the select itself, which is part of some list of statements. 6548 -- Note that the triggering alternative includes the triggering 6549 -- statement and an optional statement list. If the node to be 6550 -- wrapped is part of that list, the normal insertion applies. 6551 6552 if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative 6553 and then not Is_List_Member (Node_To_Wrap) 6554 then 6555 Target := Parent (Parent (Node_To_Wrap)); 6556 else 6557 Target := N; 6558 end if; 6559 6560 First_Obj := Target; 6561 Last_Obj := Target; 6562 6563 -- Add all actions associated with a transient scope into the main tree. 6564 -- There are several scenarios here: 6565 6566 -- +--- Before ----+ +----- After ---+ 6567 -- 1) First_Obj ....... Target ........ Last_Obj 6568 6569 -- 2) First_Obj ....... Target 6570 6571 -- 3) Target ........ Last_Obj 6572 6573 -- Flag declarations are inserted before the first object 6574 6575 if Present (Act_Before) then 6576 First_Obj := First (Act_Before); 6577 Insert_List_Before (Target, Act_Before); 6578 end if; 6579 6580 -- Finalization calls are inserted after the last object 6581 6582 if Present (Act_After) then 6583 Last_Obj := Last (Act_After); 6584 Insert_List_After (Target, Act_After); 6585 end if; 6586 6587 -- Mark and release the secondary stack when the context warrants it 6588 6589 if Manage_SS then 6590 Mark_Id := Make_Temporary (Loc, 'M'); 6591 6592 -- Generate: 6593 -- Mnn : constant Mark_Id := SS_Mark; 6594 6595 Insert_Before_And_Analyze 6596 (First_Obj, Build_SS_Mark_Call (Loc, Mark_Id)); 6597 6598 -- Generate: 6599 -- SS_Release (Mnn); 6600 6601 Insert_After_And_Analyze 6602 (Last_Obj, Build_SS_Release_Call (Loc, Mark_Id)); 6603 end if; 6604 6605 -- Check for transient objects associated with Target and generate the 6606 -- appropriate finalization actions for them. 6607 6608 Process_Transients_In_Scope 6609 (First_Object => First_Obj, 6610 Last_Object => Last_Obj, 6611 Related_Node => Target); 6612 6613 -- Reset the action lists 6614 6615 Scope_Stack.Table 6616 (Scope_Stack.Last).Actions_To_Be_Wrapped (Before) := No_List; 6617 Scope_Stack.Table 6618 (Scope_Stack.Last).Actions_To_Be_Wrapped (After) := No_List; 6619 6620 if Clean then 6621 Scope_Stack.Table 6622 (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup) := No_List; 6623 end if; 6624 end Insert_Actions_In_Scope_Around; 6625 6626 ------------------------------ 6627 -- Is_Simple_Protected_Type -- 6628 ------------------------------ 6629 6630 function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is 6631 begin 6632 return 6633 Is_Protected_Type (T) 6634 and then not Uses_Lock_Free (T) 6635 and then not Has_Entries (T) 6636 and then Is_RTE (Find_Protection_Type (T), RE_Protection); 6637 end Is_Simple_Protected_Type; 6638 6639 ----------------------- 6640 -- Make_Adjust_Call -- 6641 ----------------------- 6642 6643 function Make_Adjust_Call 6644 (Obj_Ref : Node_Id; 6645 Typ : Entity_Id; 6646 Skip_Self : Boolean := False) return Node_Id 6647 is 6648 Loc : constant Source_Ptr := Sloc (Obj_Ref); 6649 Adj_Id : Entity_Id := Empty; 6650 Ref : Node_Id; 6651 Utyp : Entity_Id; 6652 6653 begin 6654 Ref := Obj_Ref; 6655 6656 -- Recover the proper type which contains Deep_Adjust 6657 6658 if Is_Class_Wide_Type (Typ) then 6659 Utyp := Root_Type (Typ); 6660 else 6661 Utyp := Typ; 6662 end if; 6663 6664 Utyp := Underlying_Type (Base_Type (Utyp)); 6665 Set_Assignment_OK (Ref); 6666 6667 -- Deal with untagged derivation of private views 6668 6669 if Present (Utyp) and then Is_Untagged_Derivation (Typ) then 6670 Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); 6671 Ref := Unchecked_Convert_To (Utyp, Ref); 6672 Set_Assignment_OK (Ref); 6673 end if; 6674 6675 -- When dealing with the completion of a private type, use the base 6676 -- type instead. 6677 6678 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then 6679 pragma Assert (Is_Private_Type (Typ)); 6680 6681 Utyp := Base_Type (Utyp); 6682 Ref := Unchecked_Convert_To (Utyp, Ref); 6683 end if; 6684 6685 -- The underlying type may not be present due to a missing full view. In 6686 -- this case freezing did not take place and there is no [Deep_]Adjust 6687 -- primitive to call. 6688 6689 if No (Utyp) then 6690 return Empty; 6691 6692 elsif Skip_Self then 6693 if Has_Controlled_Component (Utyp) then 6694 if Is_Tagged_Type (Utyp) then 6695 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); 6696 else 6697 Adj_Id := TSS (Utyp, TSS_Deep_Adjust); 6698 end if; 6699 end if; 6700 6701 -- Class-wide types, interfaces and types with controlled components 6702 6703 elsif Is_Class_Wide_Type (Typ) 6704 or else Is_Interface (Typ) 6705 or else Has_Controlled_Component (Utyp) 6706 then 6707 if Is_Tagged_Type (Utyp) then 6708 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); 6709 else 6710 Adj_Id := TSS (Utyp, TSS_Deep_Adjust); 6711 end if; 6712 6713 -- Derivations from [Limited_]Controlled 6714 6715 elsif Is_Controlled (Utyp) then 6716 if Has_Controlled_Component (Utyp) then 6717 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); 6718 else 6719 Adj_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Adjust_Case)); 6720 end if; 6721 6722 -- Tagged types 6723 6724 elsif Is_Tagged_Type (Utyp) then 6725 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); 6726 6727 else 6728 raise Program_Error; 6729 end if; 6730 6731 if Present (Adj_Id) then 6732 6733 -- If the object is unanalyzed, set its expected type for use in 6734 -- Convert_View in case an additional conversion is needed. 6735 6736 if No (Etype (Ref)) 6737 and then Nkind (Ref) /= N_Unchecked_Type_Conversion 6738 then 6739 Set_Etype (Ref, Typ); 6740 end if; 6741 6742 -- The object reference may need another conversion depending on the 6743 -- type of the formal and that of the actual. 6744 6745 if not Is_Class_Wide_Type (Typ) then 6746 Ref := Convert_View (Adj_Id, Ref); 6747 end if; 6748 6749 return 6750 Make_Call (Loc, 6751 Proc_Id => Adj_Id, 6752 Param => Ref, 6753 Skip_Self => Skip_Self); 6754 else 6755 return Empty; 6756 end if; 6757 end Make_Adjust_Call; 6758 6759 --------------- 6760 -- Make_Call -- 6761 --------------- 6762 6763 function Make_Call 6764 (Loc : Source_Ptr; 6765 Proc_Id : Entity_Id; 6766 Param : Node_Id; 6767 Skip_Self : Boolean := False) return Node_Id 6768 is 6769 Params : constant List_Id := New_List (Param); 6770 6771 begin 6772 -- Do not apply the controlled action to the object itself by signaling 6773 -- the related routine to avoid self. 6774 6775 if Skip_Self then 6776 Append_To (Params, New_Occurrence_Of (Standard_False, Loc)); 6777 end if; 6778 6779 return 6780 Make_Procedure_Call_Statement (Loc, 6781 Name => New_Occurrence_Of (Proc_Id, Loc), 6782 Parameter_Associations => Params); 6783 end Make_Call; 6784 6785 -------------------------- 6786 -- Make_Deep_Array_Body -- 6787 -------------------------- 6788 6789 function Make_Deep_Array_Body 6790 (Prim : Final_Primitives; 6791 Typ : Entity_Id) return List_Id 6792 is 6793 function Build_Adjust_Or_Finalize_Statements 6794 (Typ : Entity_Id) return List_Id; 6795 -- Create the statements necessary to adjust or finalize an array of 6796 -- controlled elements. Generate: 6797 -- 6798 -- declare 6799 -- Abort : constant Boolean := Triggered_By_Abort; 6800 -- <or> 6801 -- Abort : constant Boolean := False; -- no abort 6802 -- 6803 -- E : Exception_Occurrence; 6804 -- Raised : Boolean := False; 6805 -- 6806 -- begin 6807 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop 6808 -- ^-- in the finalization case 6809 -- ... 6810 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop 6811 -- begin 6812 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn)); 6813 -- 6814 -- exception 6815 -- when others => 6816 -- if not Raised then 6817 -- Raised := True; 6818 -- Save_Occurrence (E, Get_Current_Excep.all.all); 6819 -- end if; 6820 -- end; 6821 -- end loop; 6822 -- ... 6823 -- end loop; 6824 -- 6825 -- if Raised and then not Abort then 6826 -- Raise_From_Controlled_Operation (E); 6827 -- end if; 6828 -- end; 6829 6830 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id; 6831 -- Create the statements necessary to initialize an array of controlled 6832 -- elements. Include a mechanism to carry out partial finalization if an 6833 -- exception occurs. Generate: 6834 -- 6835 -- declare 6836 -- Counter : Integer := 0; 6837 -- 6838 -- begin 6839 -- for J1 in V'Range (1) loop 6840 -- ... 6841 -- for JN in V'Range (N) loop 6842 -- begin 6843 -- [Deep_]Initialize (V (J1, ..., JN)); 6844 -- 6845 -- Counter := Counter + 1; 6846 -- 6847 -- exception 6848 -- when others => 6849 -- declare 6850 -- Abort : constant Boolean := Triggered_By_Abort; 6851 -- <or> 6852 -- Abort : constant Boolean := False; -- no abort 6853 -- E : Exception_Occurrence; 6854 -- Raised : Boolean := False; 6855 6856 -- begin 6857 -- Counter := 6858 -- V'Length (1) * 6859 -- V'Length (2) * 6860 -- ... 6861 -- V'Length (N) - Counter; 6862 6863 -- for F1 in reverse V'Range (1) loop 6864 -- ... 6865 -- for FN in reverse V'Range (N) loop 6866 -- if Counter > 0 then 6867 -- Counter := Counter - 1; 6868 -- else 6869 -- begin 6870 -- [Deep_]Finalize (V (F1, ..., FN)); 6871 6872 -- exception 6873 -- when others => 6874 -- if not Raised then 6875 -- Raised := True; 6876 -- Save_Occurrence (E, 6877 -- Get_Current_Excep.all.all); 6878 -- end if; 6879 -- end; 6880 -- end if; 6881 -- end loop; 6882 -- ... 6883 -- end loop; 6884 -- end; 6885 -- 6886 -- if Raised and then not Abort then 6887 -- Raise_From_Controlled_Operation (E); 6888 -- end if; 6889 -- 6890 -- raise; 6891 -- end; 6892 -- end loop; 6893 -- end loop; 6894 -- end; 6895 6896 function New_References_To 6897 (L : List_Id; 6898 Loc : Source_Ptr) return List_Id; 6899 -- Given a list of defining identifiers, return a list of references to 6900 -- the original identifiers, in the same order as they appear. 6901 6902 ----------------------------------------- 6903 -- Build_Adjust_Or_Finalize_Statements -- 6904 ----------------------------------------- 6905 6906 function Build_Adjust_Or_Finalize_Statements 6907 (Typ : Entity_Id) return List_Id 6908 is 6909 Comp_Typ : constant Entity_Id := Component_Type (Typ); 6910 Index_List : constant List_Id := New_List; 6911 Loc : constant Source_Ptr := Sloc (Typ); 6912 Num_Dims : constant Int := Number_Dimensions (Typ); 6913 6914 procedure Build_Indexes; 6915 -- Generate the indexes used in the dimension loops 6916 6917 ------------------- 6918 -- Build_Indexes -- 6919 ------------------- 6920 6921 procedure Build_Indexes is 6922 begin 6923 -- Generate the following identifiers: 6924 -- Jnn - for initialization 6925 6926 for Dim in 1 .. Num_Dims loop 6927 Append_To (Index_List, 6928 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim))); 6929 end loop; 6930 end Build_Indexes; 6931 6932 -- Local variables 6933 6934 Final_Decls : List_Id := No_List; 6935 Final_Data : Finalization_Exception_Data; 6936 Block : Node_Id; 6937 Call : Node_Id; 6938 Comp_Ref : Node_Id; 6939 Core_Loop : Node_Id; 6940 Dim : Int; 6941 J : Entity_Id; 6942 Loop_Id : Entity_Id; 6943 Stmts : List_Id; 6944 6945 -- Start of processing for Build_Adjust_Or_Finalize_Statements 6946 6947 begin 6948 Final_Decls := New_List; 6949 6950 Build_Indexes; 6951 Build_Object_Declarations (Final_Data, Final_Decls, Loc); 6952 6953 Comp_Ref := 6954 Make_Indexed_Component (Loc, 6955 Prefix => Make_Identifier (Loc, Name_V), 6956 Expressions => New_References_To (Index_List, Loc)); 6957 Set_Etype (Comp_Ref, Comp_Typ); 6958 6959 -- Generate: 6960 -- [Deep_]Adjust (V (J1, ..., JN)) 6961 6962 if Prim = Adjust_Case then 6963 Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); 6964 6965 -- Generate: 6966 -- [Deep_]Finalize (V (J1, ..., JN)) 6967 6968 else pragma Assert (Prim = Finalize_Case); 6969 Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); 6970 end if; 6971 6972 if Present (Call) then 6973 6974 -- Generate the block which houses the adjust or finalize call: 6975 6976 -- begin 6977 -- <adjust or finalize call> 6978 6979 -- exception 6980 -- when others => 6981 -- if not Raised then 6982 -- Raised := True; 6983 -- Save_Occurrence (E, Get_Current_Excep.all.all); 6984 -- end if; 6985 -- end; 6986 6987 if Exceptions_OK then 6988 Core_Loop := 6989 Make_Block_Statement (Loc, 6990 Handled_Statement_Sequence => 6991 Make_Handled_Sequence_Of_Statements (Loc, 6992 Statements => New_List (Call), 6993 Exception_Handlers => New_List ( 6994 Build_Exception_Handler (Final_Data)))); 6995 else 6996 Core_Loop := Call; 6997 end if; 6998 6999 -- Generate the dimension loops starting from the innermost one 7000 7001 -- for Jnn in [reverse] V'Range (Dim) loop 7002 -- <core loop> 7003 -- end loop; 7004 7005 J := Last (Index_List); 7006 Dim := Num_Dims; 7007 while Present (J) and then Dim > 0 loop 7008 Loop_Id := J; 7009 Prev (J); 7010 Remove (Loop_Id); 7011 7012 Core_Loop := 7013 Make_Loop_Statement (Loc, 7014 Iteration_Scheme => 7015 Make_Iteration_Scheme (Loc, 7016 Loop_Parameter_Specification => 7017 Make_Loop_Parameter_Specification (Loc, 7018 Defining_Identifier => Loop_Id, 7019 Discrete_Subtype_Definition => 7020 Make_Attribute_Reference (Loc, 7021 Prefix => Make_Identifier (Loc, Name_V), 7022 Attribute_Name => Name_Range, 7023 Expressions => New_List ( 7024 Make_Integer_Literal (Loc, Dim))), 7025 7026 Reverse_Present => 7027 Prim = Finalize_Case)), 7028 7029 Statements => New_List (Core_Loop), 7030 End_Label => Empty); 7031 7032 Dim := Dim - 1; 7033 end loop; 7034 7035 -- Generate the block which contains the core loop, declarations 7036 -- of the abort flag, the exception occurrence, the raised flag 7037 -- and the conditional raise: 7038 7039 -- declare 7040 -- Abort : constant Boolean := Triggered_By_Abort; 7041 -- <or> 7042 -- Abort : constant Boolean := False; -- no abort 7043 7044 -- E : Exception_Occurrence; 7045 -- Raised : Boolean := False; 7046 7047 -- begin 7048 -- <core loop> 7049 7050 -- if Raised and then not Abort then 7051 -- Raise_From_Controlled_Operation (E); 7052 -- end if; 7053 -- end; 7054 7055 Stmts := New_List (Core_Loop); 7056 7057 if Exceptions_OK then 7058 Append_To (Stmts, Build_Raise_Statement (Final_Data)); 7059 end if; 7060 7061 Block := 7062 Make_Block_Statement (Loc, 7063 Declarations => Final_Decls, 7064 Handled_Statement_Sequence => 7065 Make_Handled_Sequence_Of_Statements (Loc, 7066 Statements => Stmts)); 7067 7068 -- Otherwise previous errors or a missing full view may prevent the 7069 -- proper freezing of the component type. If this is the case, there 7070 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call. 7071 7072 else 7073 Block := Make_Null_Statement (Loc); 7074 end if; 7075 7076 return New_List (Block); 7077 end Build_Adjust_Or_Finalize_Statements; 7078 7079 --------------------------------- 7080 -- Build_Initialize_Statements -- 7081 --------------------------------- 7082 7083 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is 7084 Comp_Typ : constant Entity_Id := Component_Type (Typ); 7085 Final_List : constant List_Id := New_List; 7086 Index_List : constant List_Id := New_List; 7087 Loc : constant Source_Ptr := Sloc (Typ); 7088 Num_Dims : constant Int := Number_Dimensions (Typ); 7089 7090 function Build_Assignment (Counter_Id : Entity_Id) return Node_Id; 7091 -- Generate the following assignment: 7092 -- Counter := V'Length (1) * 7093 -- ... 7094 -- V'Length (N) - Counter; 7095 -- 7096 -- Counter_Id denotes the entity of the counter. 7097 7098 function Build_Finalization_Call return Node_Id; 7099 -- Generate a deep finalization call for an array element 7100 7101 procedure Build_Indexes; 7102 -- Generate the initialization and finalization indexes used in the 7103 -- dimension loops. 7104 7105 function Build_Initialization_Call return Node_Id; 7106 -- Generate a deep initialization call for an array element 7107 7108 ---------------------- 7109 -- Build_Assignment -- 7110 ---------------------- 7111 7112 function Build_Assignment (Counter_Id : Entity_Id) return Node_Id is 7113 Dim : Int; 7114 Expr : Node_Id; 7115 7116 begin 7117 -- Start from the first dimension and generate: 7118 -- V'Length (1) 7119 7120 Dim := 1; 7121 Expr := 7122 Make_Attribute_Reference (Loc, 7123 Prefix => Make_Identifier (Loc, Name_V), 7124 Attribute_Name => Name_Length, 7125 Expressions => New_List (Make_Integer_Literal (Loc, Dim))); 7126 7127 -- Process the rest of the dimensions, generate: 7128 -- Expr * V'Length (N) 7129 7130 Dim := Dim + 1; 7131 while Dim <= Num_Dims loop 7132 Expr := 7133 Make_Op_Multiply (Loc, 7134 Left_Opnd => Expr, 7135 Right_Opnd => 7136 Make_Attribute_Reference (Loc, 7137 Prefix => Make_Identifier (Loc, Name_V), 7138 Attribute_Name => Name_Length, 7139 Expressions => New_List ( 7140 Make_Integer_Literal (Loc, Dim)))); 7141 7142 Dim := Dim + 1; 7143 end loop; 7144 7145 -- Generate: 7146 -- Counter := Expr - Counter; 7147 7148 return 7149 Make_Assignment_Statement (Loc, 7150 Name => New_Occurrence_Of (Counter_Id, Loc), 7151 Expression => 7152 Make_Op_Subtract (Loc, 7153 Left_Opnd => Expr, 7154 Right_Opnd => New_Occurrence_Of (Counter_Id, Loc))); 7155 end Build_Assignment; 7156 7157 ----------------------------- 7158 -- Build_Finalization_Call -- 7159 ----------------------------- 7160 7161 function Build_Finalization_Call return Node_Id is 7162 Comp_Ref : constant Node_Id := 7163 Make_Indexed_Component (Loc, 7164 Prefix => Make_Identifier (Loc, Name_V), 7165 Expressions => New_References_To (Final_List, Loc)); 7166 7167 begin 7168 Set_Etype (Comp_Ref, Comp_Typ); 7169 7170 -- Generate: 7171 -- [Deep_]Finalize (V); 7172 7173 return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); 7174 end Build_Finalization_Call; 7175 7176 ------------------- 7177 -- Build_Indexes -- 7178 ------------------- 7179 7180 procedure Build_Indexes is 7181 begin 7182 -- Generate the following identifiers: 7183 -- Jnn - for initialization 7184 -- Fnn - for finalization 7185 7186 for Dim in 1 .. Num_Dims loop 7187 Append_To (Index_List, 7188 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim))); 7189 7190 Append_To (Final_List, 7191 Make_Defining_Identifier (Loc, New_External_Name ('F', Dim))); 7192 end loop; 7193 end Build_Indexes; 7194 7195 ------------------------------- 7196 -- Build_Initialization_Call -- 7197 ------------------------------- 7198 7199 function Build_Initialization_Call return Node_Id is 7200 Comp_Ref : constant Node_Id := 7201 Make_Indexed_Component (Loc, 7202 Prefix => Make_Identifier (Loc, Name_V), 7203 Expressions => New_References_To (Index_List, Loc)); 7204 7205 begin 7206 Set_Etype (Comp_Ref, Comp_Typ); 7207 7208 -- Generate: 7209 -- [Deep_]Initialize (V (J1, ..., JN)); 7210 7211 return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); 7212 end Build_Initialization_Call; 7213 7214 -- Local variables 7215 7216 Counter_Id : Entity_Id; 7217 Dim : Int; 7218 F : Node_Id; 7219 Fin_Stmt : Node_Id; 7220 Final_Block : Node_Id; 7221 Final_Data : Finalization_Exception_Data; 7222 Final_Decls : List_Id := No_List; 7223 Final_Loop : Node_Id; 7224 Init_Block : Node_Id; 7225 Init_Call : Node_Id; 7226 Init_Loop : Node_Id; 7227 J : Node_Id; 7228 Loop_Id : Node_Id; 7229 Stmts : List_Id; 7230 7231 -- Start of processing for Build_Initialize_Statements 7232 7233 begin 7234 Counter_Id := Make_Temporary (Loc, 'C'); 7235 Final_Decls := New_List; 7236 7237 Build_Indexes; 7238 Build_Object_Declarations (Final_Data, Final_Decls, Loc); 7239 7240 -- Generate the block which houses the finalization call, the index 7241 -- guard and the handler which triggers Program_Error later on. 7242 7243 -- if Counter > 0 then 7244 -- Counter := Counter - 1; 7245 -- else 7246 -- begin 7247 -- [Deep_]Finalize (V (F1, ..., FN)); 7248 -- exception 7249 -- when others => 7250 -- if not Raised then 7251 -- Raised := True; 7252 -- Save_Occurrence (E, Get_Current_Excep.all.all); 7253 -- end if; 7254 -- end; 7255 -- end if; 7256 7257 Fin_Stmt := Build_Finalization_Call; 7258 7259 if Present (Fin_Stmt) then 7260 if Exceptions_OK then 7261 Fin_Stmt := 7262 Make_Block_Statement (Loc, 7263 Handled_Statement_Sequence => 7264 Make_Handled_Sequence_Of_Statements (Loc, 7265 Statements => New_List (Fin_Stmt), 7266 Exception_Handlers => New_List ( 7267 Build_Exception_Handler (Final_Data)))); 7268 end if; 7269 7270 -- This is the core of the loop, the dimension iterators are added 7271 -- one by one in reverse. 7272 7273 Final_Loop := 7274 Make_If_Statement (Loc, 7275 Condition => 7276 Make_Op_Gt (Loc, 7277 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), 7278 Right_Opnd => Make_Integer_Literal (Loc, 0)), 7279 7280 Then_Statements => New_List ( 7281 Make_Assignment_Statement (Loc, 7282 Name => New_Occurrence_Of (Counter_Id, Loc), 7283 Expression => 7284 Make_Op_Subtract (Loc, 7285 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), 7286 Right_Opnd => Make_Integer_Literal (Loc, 1)))), 7287 7288 Else_Statements => New_List (Fin_Stmt)); 7289 7290 -- Generate all finalization loops starting from the innermost 7291 -- dimension. 7292 7293 -- for Fnn in reverse V'Range (Dim) loop 7294 -- <final loop> 7295 -- end loop; 7296 7297 F := Last (Final_List); 7298 Dim := Num_Dims; 7299 while Present (F) and then Dim > 0 loop 7300 Loop_Id := F; 7301 Prev (F); 7302 Remove (Loop_Id); 7303 7304 Final_Loop := 7305 Make_Loop_Statement (Loc, 7306 Iteration_Scheme => 7307 Make_Iteration_Scheme (Loc, 7308 Loop_Parameter_Specification => 7309 Make_Loop_Parameter_Specification (Loc, 7310 Defining_Identifier => Loop_Id, 7311 Discrete_Subtype_Definition => 7312 Make_Attribute_Reference (Loc, 7313 Prefix => Make_Identifier (Loc, Name_V), 7314 Attribute_Name => Name_Range, 7315 Expressions => New_List ( 7316 Make_Integer_Literal (Loc, Dim))), 7317 7318 Reverse_Present => True)), 7319 7320 Statements => New_List (Final_Loop), 7321 End_Label => Empty); 7322 7323 Dim := Dim - 1; 7324 end loop; 7325 7326 -- Generate the block which contains the finalization loops, the 7327 -- declarations of the abort flag, the exception occurrence, the 7328 -- raised flag and the conditional raise. 7329 7330 -- declare 7331 -- Abort : constant Boolean := Triggered_By_Abort; 7332 -- <or> 7333 -- Abort : constant Boolean := False; -- no abort 7334 7335 -- E : Exception_Occurrence; 7336 -- Raised : Boolean := False; 7337 7338 -- begin 7339 -- Counter := 7340 -- V'Length (1) * 7341 -- ... 7342 -- V'Length (N) - Counter; 7343 7344 -- <final loop> 7345 7346 -- if Raised and then not Abort then 7347 -- Raise_From_Controlled_Operation (E); 7348 -- end if; 7349 7350 -- raise; 7351 -- end; 7352 7353 Stmts := New_List (Build_Assignment (Counter_Id), Final_Loop); 7354 7355 if Exceptions_OK then 7356 Append_To (Stmts, Build_Raise_Statement (Final_Data)); 7357 Append_To (Stmts, Make_Raise_Statement (Loc)); 7358 end if; 7359 7360 Final_Block := 7361 Make_Block_Statement (Loc, 7362 Declarations => Final_Decls, 7363 Handled_Statement_Sequence => 7364 Make_Handled_Sequence_Of_Statements (Loc, 7365 Statements => Stmts)); 7366 7367 -- Otherwise previous errors or a missing full view may prevent the 7368 -- proper freezing of the component type. If this is the case, there 7369 -- is no [Deep_]Finalize primitive to call. 7370 7371 else 7372 Final_Block := Make_Null_Statement (Loc); 7373 end if; 7374 7375 -- Generate the block which contains the initialization call and 7376 -- the partial finalization code. 7377 7378 -- begin 7379 -- [Deep_]Initialize (V (J1, ..., JN)); 7380 7381 -- Counter := Counter + 1; 7382 7383 -- exception 7384 -- when others => 7385 -- <finalization code> 7386 -- end; 7387 7388 Init_Call := Build_Initialization_Call; 7389 7390 -- Only create finalization block if there is a nontrivial call 7391 -- to initialization or a Default_Initial_Condition check to be 7392 -- performed. 7393 7394 if (Present (Init_Call) 7395 and then Nkind (Init_Call) /= N_Null_Statement) 7396 or else 7397 (Has_DIC (Comp_Typ) 7398 and then not GNATprove_Mode 7399 and then Present (DIC_Procedure (Comp_Typ)) 7400 and then not Has_Null_Body (DIC_Procedure (Comp_Typ))) 7401 then 7402 declare 7403 Init_Stmts : constant List_Id := New_List; 7404 7405 begin 7406 if Present (Init_Call) then 7407 Append_To (Init_Stmts, Init_Call); 7408 end if; 7409 7410 if Has_DIC (Comp_Typ) 7411 and then Present (DIC_Procedure (Comp_Typ)) 7412 then 7413 Append_To 7414 (Init_Stmts, 7415 Build_DIC_Call (Loc, 7416 Make_Indexed_Component (Loc, 7417 Prefix => Make_Identifier (Loc, Name_V), 7418 Expressions => New_References_To (Index_List, Loc)), 7419 Comp_Typ)); 7420 end if; 7421 7422 Init_Loop := 7423 Make_Block_Statement (Loc, 7424 Handled_Statement_Sequence => 7425 Make_Handled_Sequence_Of_Statements (Loc, 7426 Statements => Init_Stmts, 7427 Exception_Handlers => New_List ( 7428 Make_Exception_Handler (Loc, 7429 Exception_Choices => New_List ( 7430 Make_Others_Choice (Loc)), 7431 Statements => New_List (Final_Block))))); 7432 end; 7433 7434 Append_To (Statements (Handled_Statement_Sequence (Init_Loop)), 7435 Make_Assignment_Statement (Loc, 7436 Name => New_Occurrence_Of (Counter_Id, Loc), 7437 Expression => 7438 Make_Op_Add (Loc, 7439 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), 7440 Right_Opnd => Make_Integer_Literal (Loc, 1)))); 7441 7442 -- Generate all initialization loops starting from the innermost 7443 -- dimension. 7444 7445 -- for Jnn in V'Range (Dim) loop 7446 -- <init loop> 7447 -- end loop; 7448 7449 J := Last (Index_List); 7450 Dim := Num_Dims; 7451 while Present (J) and then Dim > 0 loop 7452 Loop_Id := J; 7453 Prev (J); 7454 Remove (Loop_Id); 7455 7456 Init_Loop := 7457 Make_Loop_Statement (Loc, 7458 Iteration_Scheme => 7459 Make_Iteration_Scheme (Loc, 7460 Loop_Parameter_Specification => 7461 Make_Loop_Parameter_Specification (Loc, 7462 Defining_Identifier => Loop_Id, 7463 Discrete_Subtype_Definition => 7464 Make_Attribute_Reference (Loc, 7465 Prefix => Make_Identifier (Loc, Name_V), 7466 Attribute_Name => Name_Range, 7467 Expressions => New_List ( 7468 Make_Integer_Literal (Loc, Dim))))), 7469 7470 Statements => New_List (Init_Loop), 7471 End_Label => Empty); 7472 7473 Dim := Dim - 1; 7474 end loop; 7475 7476 -- Generate the block which contains the counter variable and the 7477 -- initialization loops. 7478 7479 -- declare 7480 -- Counter : Integer := 0; 7481 -- begin 7482 -- <init loop> 7483 -- end; 7484 7485 Init_Block := 7486 Make_Block_Statement (Loc, 7487 Declarations => New_List ( 7488 Make_Object_Declaration (Loc, 7489 Defining_Identifier => Counter_Id, 7490 Object_Definition => 7491 New_Occurrence_Of (Standard_Integer, Loc), 7492 Expression => Make_Integer_Literal (Loc, 0))), 7493 7494 Handled_Statement_Sequence => 7495 Make_Handled_Sequence_Of_Statements (Loc, 7496 Statements => New_List (Init_Loop))); 7497 7498 if Debug_Generated_Code then 7499 Set_Debug_Info_Needed (Counter_Id); 7500 end if; 7501 7502 -- Otherwise previous errors or a missing full view may prevent the 7503 -- proper freezing of the component type. If this is the case, there 7504 -- is no [Deep_]Initialize primitive to call. 7505 7506 else 7507 Init_Block := Make_Null_Statement (Loc); 7508 end if; 7509 7510 return New_List (Init_Block); 7511 end Build_Initialize_Statements; 7512 7513 ----------------------- 7514 -- New_References_To -- 7515 ----------------------- 7516 7517 function New_References_To 7518 (L : List_Id; 7519 Loc : Source_Ptr) return List_Id 7520 is 7521 Refs : constant List_Id := New_List; 7522 Id : Node_Id; 7523 7524 begin 7525 Id := First (L); 7526 while Present (Id) loop 7527 Append_To (Refs, New_Occurrence_Of (Id, Loc)); 7528 Next (Id); 7529 end loop; 7530 7531 return Refs; 7532 end New_References_To; 7533 7534 -- Start of processing for Make_Deep_Array_Body 7535 7536 begin 7537 case Prim is 7538 when Address_Case => 7539 return Make_Finalize_Address_Stmts (Typ); 7540 7541 when Adjust_Case 7542 | Finalize_Case 7543 => 7544 return Build_Adjust_Or_Finalize_Statements (Typ); 7545 7546 when Initialize_Case => 7547 return Build_Initialize_Statements (Typ); 7548 end case; 7549 end Make_Deep_Array_Body; 7550 7551 -------------------- 7552 -- Make_Deep_Proc -- 7553 -------------------- 7554 7555 function Make_Deep_Proc 7556 (Prim : Final_Primitives; 7557 Typ : Entity_Id; 7558 Stmts : List_Id) return Entity_Id 7559 is 7560 Loc : constant Source_Ptr := Sloc (Typ); 7561 Formals : List_Id; 7562 Proc_Id : Entity_Id; 7563 7564 begin 7565 -- Create the object formal, generate: 7566 -- V : System.Address 7567 7568 if Prim = Address_Case then 7569 Formals := New_List ( 7570 Make_Parameter_Specification (Loc, 7571 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), 7572 Parameter_Type => 7573 New_Occurrence_Of (RTE (RE_Address), Loc))); 7574 7575 -- Default case 7576 7577 else 7578 -- V : in out Typ 7579 7580 Formals := New_List ( 7581 Make_Parameter_Specification (Loc, 7582 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), 7583 In_Present => True, 7584 Out_Present => True, 7585 Parameter_Type => New_Occurrence_Of (Typ, Loc))); 7586 7587 -- F : Boolean := True 7588 7589 if Prim = Adjust_Case 7590 or else Prim = Finalize_Case 7591 then 7592 Append_To (Formals, 7593 Make_Parameter_Specification (Loc, 7594 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F), 7595 Parameter_Type => 7596 New_Occurrence_Of (Standard_Boolean, Loc), 7597 Expression => 7598 New_Occurrence_Of (Standard_True, Loc))); 7599 end if; 7600 end if; 7601 7602 Proc_Id := 7603 Make_Defining_Identifier (Loc, 7604 Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim))); 7605 7606 -- Generate: 7607 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is 7608 -- begin 7609 -- <stmts> 7610 -- exception -- Finalize and Adjust cases only 7611 -- raise Program_Error; 7612 -- end Deep_Initialize / Adjust / Finalize; 7613 7614 -- or 7615 7616 -- procedure Finalize_Address (V : System.Address) is 7617 -- begin 7618 -- <stmts> 7619 -- end Finalize_Address; 7620 7621 Discard_Node ( 7622 Make_Subprogram_Body (Loc, 7623 Specification => 7624 Make_Procedure_Specification (Loc, 7625 Defining_Unit_Name => Proc_Id, 7626 Parameter_Specifications => Formals), 7627 7628 Declarations => Empty_List, 7629 7630 Handled_Statement_Sequence => 7631 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts))); 7632 7633 -- If there are no calls to component initialization, indicate that 7634 -- the procedure is trivial, so prevent calls to it. 7635 7636 if Is_Empty_List (Stmts) 7637 or else Nkind (First (Stmts)) = N_Null_Statement 7638 then 7639 Set_Is_Trivial_Subprogram (Proc_Id); 7640 end if; 7641 7642 return Proc_Id; 7643 end Make_Deep_Proc; 7644 7645 --------------------------- 7646 -- Make_Deep_Record_Body -- 7647 --------------------------- 7648 7649 function Make_Deep_Record_Body 7650 (Prim : Final_Primitives; 7651 Typ : Entity_Id; 7652 Is_Local : Boolean := False) return List_Id 7653 is 7654 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id; 7655 -- Build the statements necessary to adjust a record type. The type may 7656 -- have discriminants and contain variant parts. Generate: 7657 -- 7658 -- begin 7659 -- begin 7660 -- [Deep_]Adjust (V.Comp_1); 7661 -- exception 7662 -- when Id : others => 7663 -- if not Raised then 7664 -- Raised := True; 7665 -- Save_Occurrence (E, Get_Current_Excep.all.all); 7666 -- end if; 7667 -- end; 7668 -- . . . 7669 -- begin 7670 -- [Deep_]Adjust (V.Comp_N); 7671 -- exception 7672 -- when Id : others => 7673 -- if not Raised then 7674 -- Raised := True; 7675 -- Save_Occurrence (E, Get_Current_Excep.all.all); 7676 -- end if; 7677 -- end; 7678 -- 7679 -- begin 7680 -- Deep_Adjust (V._parent, False); -- If applicable 7681 -- exception 7682 -- when Id : others => 7683 -- if not Raised then 7684 -- Raised := True; 7685 -- Save_Occurrence (E, Get_Current_Excep.all.all); 7686 -- end if; 7687 -- end; 7688 -- 7689 -- if F then 7690 -- begin 7691 -- Adjust (V); -- If applicable 7692 -- exception 7693 -- when others => 7694 -- if not Raised then 7695 -- Raised := True; 7696 -- Save_Occurrence (E, Get_Current_Excep.all.all); 7697 -- end if; 7698 -- end; 7699 -- end if; 7700 -- 7701 -- if Raised and then not Abort then 7702 -- Raise_From_Controlled_Operation (E); 7703 -- end if; 7704 -- end; 7705 7706 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id; 7707 -- Build the statements necessary to finalize a record type. The type 7708 -- may have discriminants and contain variant parts. Generate: 7709 -- 7710 -- declare 7711 -- Abort : constant Boolean := Triggered_By_Abort; 7712 -- <or> 7713 -- Abort : constant Boolean := False; -- no abort 7714 -- E : Exception_Occurrence; 7715 -- Raised : Boolean := False; 7716 -- 7717 -- begin 7718 -- if F then 7719 -- begin 7720 -- Finalize (V); -- If applicable 7721 -- exception 7722 -- when others => 7723 -- if not Raised then 7724 -- Raised := True; 7725 -- Save_Occurrence (E, Get_Current_Excep.all.all); 7726 -- end if; 7727 -- end; 7728 -- end if; 7729 -- 7730 -- case Variant_1 is 7731 -- when Value_1 => 7732 -- case State_Counter_N => -- If Is_Local is enabled 7733 -- when N => . 7734 -- goto LN; . 7735 -- ... . 7736 -- when 1 => . 7737 -- goto L1; . 7738 -- when others => . 7739 -- goto L0; . 7740 -- end case; . 7741 -- 7742 -- <<LN>> -- If Is_Local is enabled 7743 -- begin 7744 -- [Deep_]Finalize (V.Comp_N); 7745 -- exception 7746 -- when others => 7747 -- if not Raised then 7748 -- Raised := True; 7749 -- Save_Occurrence (E, Get_Current_Excep.all.all); 7750 -- end if; 7751 -- end; 7752 -- . . . 7753 -- <<L1>> 7754 -- begin 7755 -- [Deep_]Finalize (V.Comp_1); 7756 -- exception 7757 -- when others => 7758 -- if not Raised then 7759 -- Raised := True; 7760 -- Save_Occurrence (E, Get_Current_Excep.all.all); 7761 -- end if; 7762 -- end; 7763 -- <<L0>> 7764 -- end case; 7765 -- 7766 -- case State_Counter_1 => -- If Is_Local is enabled 7767 -- when M => . 7768 -- goto LM; . 7769 -- ... 7770 -- 7771 -- begin 7772 -- Deep_Finalize (V._parent, False); -- If applicable 7773 -- exception 7774 -- when Id : others => 7775 -- if not Raised then 7776 -- Raised := True; 7777 -- Save_Occurrence (E, Get_Current_Excep.all.all); 7778 -- end if; 7779 -- end; 7780 -- 7781 -- if Raised and then not Abort then 7782 -- Raise_From_Controlled_Operation (E); 7783 -- end if; 7784 -- end; 7785 7786 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id; 7787 -- Given a derived tagged type Typ, traverse all components, find field 7788 -- _parent and return its type. 7789 7790 procedure Preprocess_Components 7791 (Comps : Node_Id; 7792 Num_Comps : out Nat; 7793 Has_POC : out Boolean); 7794 -- Examine all components in component list Comps, count all controlled 7795 -- components and determine whether at least one of them is per-object 7796 -- constrained. Component _parent is always skipped. 7797 7798 ----------------------------- 7799 -- Build_Adjust_Statements -- 7800 ----------------------------- 7801 7802 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is 7803 Loc : constant Source_Ptr := Sloc (Typ); 7804 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); 7805 7806 Finalizer_Data : Finalization_Exception_Data; 7807 7808 function Process_Component_List_For_Adjust 7809 (Comps : Node_Id) return List_Id; 7810 -- Build all necessary adjust statements for a single component list 7811 7812 --------------------------------------- 7813 -- Process_Component_List_For_Adjust -- 7814 --------------------------------------- 7815 7816 function Process_Component_List_For_Adjust 7817 (Comps : Node_Id) return List_Id 7818 is 7819 Stmts : constant List_Id := New_List; 7820 7821 procedure Process_Component_For_Adjust (Decl : Node_Id); 7822 -- Process the declaration of a single controlled component 7823 7824 ---------------------------------- 7825 -- Process_Component_For_Adjust -- 7826 ---------------------------------- 7827 7828 procedure Process_Component_For_Adjust (Decl : Node_Id) is 7829 Id : constant Entity_Id := Defining_Identifier (Decl); 7830 Typ : constant Entity_Id := Etype (Id); 7831 7832 Adj_Call : Node_Id; 7833 7834 begin 7835 -- begin 7836 -- [Deep_]Adjust (V.Id); 7837 7838 -- exception 7839 -- when others => 7840 -- if not Raised then 7841 -- Raised := True; 7842 -- Save_Occurrence (E, Get_Current_Excep.all.all); 7843 -- end if; 7844 -- end; 7845 7846 Adj_Call := 7847 Make_Adjust_Call ( 7848 Obj_Ref => 7849 Make_Selected_Component (Loc, 7850 Prefix => Make_Identifier (Loc, Name_V), 7851 Selector_Name => Make_Identifier (Loc, Chars (Id))), 7852 Typ => Typ); 7853 7854 -- Guard against a missing [Deep_]Adjust when the component 7855 -- type was not properly frozen. 7856 7857 if Present (Adj_Call) then 7858 if Exceptions_OK then 7859 Adj_Call := 7860 Make_Block_Statement (Loc, 7861 Handled_Statement_Sequence => 7862 Make_Handled_Sequence_Of_Statements (Loc, 7863 Statements => New_List (Adj_Call), 7864 Exception_Handlers => New_List ( 7865 Build_Exception_Handler (Finalizer_Data)))); 7866 end if; 7867 7868 Append_To (Stmts, Adj_Call); 7869 end if; 7870 end Process_Component_For_Adjust; 7871 7872 -- Local variables 7873 7874 Decl : Node_Id; 7875 Decl_Id : Entity_Id; 7876 Decl_Typ : Entity_Id; 7877 Has_POC : Boolean; 7878 Num_Comps : Nat; 7879 Var_Case : Node_Id; 7880 7881 -- Start of processing for Process_Component_List_For_Adjust 7882 7883 begin 7884 -- Perform an initial check, determine the number of controlled 7885 -- components in the current list and whether at least one of them 7886 -- is per-object constrained. 7887 7888 Preprocess_Components (Comps, Num_Comps, Has_POC); 7889 7890 -- The processing in this routine is done in the following order: 7891 -- 1) Regular components 7892 -- 2) Per-object constrained components 7893 -- 3) Variant parts 7894 7895 if Num_Comps > 0 then 7896 7897 -- Process all regular components in order of declarations 7898 7899 Decl := First_Non_Pragma (Component_Items (Comps)); 7900 while Present (Decl) loop 7901 Decl_Id := Defining_Identifier (Decl); 7902 Decl_Typ := Etype (Decl_Id); 7903 7904 -- Skip _parent as well as per-object constrained components 7905 7906 if Chars (Decl_Id) /= Name_uParent 7907 and then Needs_Finalization (Decl_Typ) 7908 then 7909 if Has_Access_Constraint (Decl_Id) 7910 and then No (Expression (Decl)) 7911 then 7912 null; 7913 else 7914 Process_Component_For_Adjust (Decl); 7915 end if; 7916 end if; 7917 7918 Next_Non_Pragma (Decl); 7919 end loop; 7920 7921 -- Process all per-object constrained components in order of 7922 -- declarations. 7923 7924 if Has_POC then 7925 Decl := First_Non_Pragma (Component_Items (Comps)); 7926 while Present (Decl) loop 7927 Decl_Id := Defining_Identifier (Decl); 7928 Decl_Typ := Etype (Decl_Id); 7929 7930 -- Skip _parent 7931 7932 if Chars (Decl_Id) /= Name_uParent 7933 and then Needs_Finalization (Decl_Typ) 7934 and then Has_Access_Constraint (Decl_Id) 7935 and then No (Expression (Decl)) 7936 then 7937 Process_Component_For_Adjust (Decl); 7938 end if; 7939 7940 Next_Non_Pragma (Decl); 7941 end loop; 7942 end if; 7943 end if; 7944 7945 -- Process all variants, if any 7946 7947 Var_Case := Empty; 7948 if Present (Variant_Part (Comps)) then 7949 declare 7950 Var_Alts : constant List_Id := New_List; 7951 Var : Node_Id; 7952 7953 begin 7954 Var := First_Non_Pragma (Variants (Variant_Part (Comps))); 7955 while Present (Var) loop 7956 7957 -- Generate: 7958 -- when <discrete choices> => 7959 -- <adjust statements> 7960 7961 Append_To (Var_Alts, 7962 Make_Case_Statement_Alternative (Loc, 7963 Discrete_Choices => 7964 New_Copy_List (Discrete_Choices (Var)), 7965 Statements => 7966 Process_Component_List_For_Adjust ( 7967 Component_List (Var)))); 7968 7969 Next_Non_Pragma (Var); 7970 end loop; 7971 7972 -- Generate: 7973 -- case V.<discriminant> is 7974 -- when <discrete choices 1> => 7975 -- <adjust statements 1> 7976 -- ... 7977 -- when <discrete choices N> => 7978 -- <adjust statements N> 7979 -- end case; 7980 7981 Var_Case := 7982 Make_Case_Statement (Loc, 7983 Expression => 7984 Make_Selected_Component (Loc, 7985 Prefix => Make_Identifier (Loc, Name_V), 7986 Selector_Name => 7987 Make_Identifier (Loc, 7988 Chars => Chars (Name (Variant_Part (Comps))))), 7989 Alternatives => Var_Alts); 7990 end; 7991 end if; 7992 7993 -- Add the variant case statement to the list of statements 7994 7995 if Present (Var_Case) then 7996 Append_To (Stmts, Var_Case); 7997 end if; 7998 7999 -- If the component list did not have any controlled components 8000 -- nor variants, return null. 8001 8002 if Is_Empty_List (Stmts) then 8003 Append_To (Stmts, Make_Null_Statement (Loc)); 8004 end if; 8005 8006 return Stmts; 8007 end Process_Component_List_For_Adjust; 8008 8009 -- Local variables 8010 8011 Bod_Stmts : List_Id := No_List; 8012 Finalizer_Decls : List_Id := No_List; 8013 Rec_Def : Node_Id; 8014 8015 -- Start of processing for Build_Adjust_Statements 8016 8017 begin 8018 Finalizer_Decls := New_List; 8019 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); 8020 8021 if Nkind (Typ_Def) = N_Derived_Type_Definition then 8022 Rec_Def := Record_Extension_Part (Typ_Def); 8023 else 8024 Rec_Def := Typ_Def; 8025 end if; 8026 8027 -- Create an adjust sequence for all record components 8028 8029 if Present (Component_List (Rec_Def)) then 8030 Bod_Stmts := 8031 Process_Component_List_For_Adjust (Component_List (Rec_Def)); 8032 end if; 8033 8034 -- A derived record type must adjust all inherited components. This 8035 -- action poses the following problem: 8036 8037 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is 8038 -- begin 8039 -- Adjust (Obj); 8040 -- ... 8041 8042 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is 8043 -- begin 8044 -- Deep_Adjust (Obj._parent); 8045 -- ... 8046 -- Adjust (Obj); 8047 -- ... 8048 8049 -- Adjusting the derived type will invoke Adjust of the parent and 8050 -- then that of the derived type. This is undesirable because both 8051 -- routines may modify shared components. Only the Adjust of the 8052 -- derived type should be invoked. 8053 8054 -- To prevent this double adjustment of shared components, 8055 -- Deep_Adjust uses a flag to control the invocation of Adjust: 8056 8057 -- procedure Deep_Adjust 8058 -- (Obj : in out Some_Type; 8059 -- Flag : Boolean := True) 8060 -- is 8061 -- begin 8062 -- if Flag then 8063 -- Adjust (Obj); 8064 -- end if; 8065 -- ... 8066 8067 -- When Deep_Adjust is invokes for field _parent, a value of False is 8068 -- provided for the flag: 8069 8070 -- Deep_Adjust (Obj._parent, False); 8071 8072 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then 8073 declare 8074 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ); 8075 Adj_Stmt : Node_Id; 8076 Call : Node_Id; 8077 8078 begin 8079 if Needs_Finalization (Par_Typ) then 8080 Call := 8081 Make_Adjust_Call 8082 (Obj_Ref => 8083 Make_Selected_Component (Loc, 8084 Prefix => Make_Identifier (Loc, Name_V), 8085 Selector_Name => 8086 Make_Identifier (Loc, Name_uParent)), 8087 Typ => Par_Typ, 8088 Skip_Self => True); 8089 8090 -- Generate: 8091 -- begin 8092 -- Deep_Adjust (V._parent, False); 8093 8094 -- exception 8095 -- when Id : others => 8096 -- if not Raised then 8097 -- Raised := True; 8098 -- Save_Occurrence (E, 8099 -- Get_Current_Excep.all.all); 8100 -- end if; 8101 -- end; 8102 8103 if Present (Call) then 8104 Adj_Stmt := Call; 8105 8106 if Exceptions_OK then 8107 Adj_Stmt := 8108 Make_Block_Statement (Loc, 8109 Handled_Statement_Sequence => 8110 Make_Handled_Sequence_Of_Statements (Loc, 8111 Statements => New_List (Adj_Stmt), 8112 Exception_Handlers => New_List ( 8113 Build_Exception_Handler (Finalizer_Data)))); 8114 end if; 8115 8116 Prepend_To (Bod_Stmts, Adj_Stmt); 8117 end if; 8118 end if; 8119 end; 8120 end if; 8121 8122 -- Adjust the object. This action must be performed last after all 8123 -- components have been adjusted. 8124 8125 if Is_Controlled (Typ) then 8126 declare 8127 Adj_Stmt : Node_Id; 8128 Proc : Entity_Id; 8129 8130 begin 8131 Proc := Find_Optional_Prim_Op (Typ, Name_Adjust); 8132 8133 -- Generate: 8134 -- if F then 8135 -- begin 8136 -- Adjust (V); 8137 8138 -- exception 8139 -- when others => 8140 -- if not Raised then 8141 -- Raised := True; 8142 -- Save_Occurrence (E, 8143 -- Get_Current_Excep.all.all); 8144 -- end if; 8145 -- end; 8146 -- end if; 8147 8148 if Present (Proc) then 8149 Adj_Stmt := 8150 Make_Procedure_Call_Statement (Loc, 8151 Name => New_Occurrence_Of (Proc, Loc), 8152 Parameter_Associations => New_List ( 8153 Make_Identifier (Loc, Name_V))); 8154 8155 if Exceptions_OK then 8156 Adj_Stmt := 8157 Make_Block_Statement (Loc, 8158 Handled_Statement_Sequence => 8159 Make_Handled_Sequence_Of_Statements (Loc, 8160 Statements => New_List (Adj_Stmt), 8161 Exception_Handlers => New_List ( 8162 Build_Exception_Handler 8163 (Finalizer_Data)))); 8164 end if; 8165 8166 Append_To (Bod_Stmts, 8167 Make_If_Statement (Loc, 8168 Condition => Make_Identifier (Loc, Name_F), 8169 Then_Statements => New_List (Adj_Stmt))); 8170 end if; 8171 end; 8172 end if; 8173 8174 -- At this point either all adjustment statements have been generated 8175 -- or the type is not controlled. 8176 8177 if Is_Empty_List (Bod_Stmts) then 8178 Append_To (Bod_Stmts, Make_Null_Statement (Loc)); 8179 8180 return Bod_Stmts; 8181 8182 -- Generate: 8183 -- declare 8184 -- Abort : constant Boolean := Triggered_By_Abort; 8185 -- <or> 8186 -- Abort : constant Boolean := False; -- no abort 8187 8188 -- E : Exception_Occurrence; 8189 -- Raised : Boolean := False; 8190 8191 -- begin 8192 -- <adjust statements> 8193 8194 -- if Raised and then not Abort then 8195 -- Raise_From_Controlled_Operation (E); 8196 -- end if; 8197 -- end; 8198 8199 else 8200 if Exceptions_OK then 8201 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data)); 8202 end if; 8203 8204 return 8205 New_List ( 8206 Make_Block_Statement (Loc, 8207 Declarations => 8208 Finalizer_Decls, 8209 Handled_Statement_Sequence => 8210 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts))); 8211 end if; 8212 end Build_Adjust_Statements; 8213 8214 ------------------------------- 8215 -- Build_Finalize_Statements -- 8216 ------------------------------- 8217 8218 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is 8219 Loc : constant Source_Ptr := Sloc (Typ); 8220 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); 8221 8222 Counter : Int := 0; 8223 Finalizer_Data : Finalization_Exception_Data; 8224 8225 function Process_Component_List_For_Finalize 8226 (Comps : Node_Id) return List_Id; 8227 -- Build all necessary finalization statements for a single component 8228 -- list. The statements may include a jump circuitry if flag Is_Local 8229 -- is enabled. 8230 8231 ----------------------------------------- 8232 -- Process_Component_List_For_Finalize -- 8233 ----------------------------------------- 8234 8235 function Process_Component_List_For_Finalize 8236 (Comps : Node_Id) return List_Id 8237 is 8238 procedure Process_Component_For_Finalize 8239 (Decl : Node_Id; 8240 Alts : List_Id; 8241 Decls : List_Id; 8242 Stmts : List_Id; 8243 Num_Comps : in out Nat); 8244 -- Process the declaration of a single controlled component. If 8245 -- flag Is_Local is enabled, create the corresponding label and 8246 -- jump circuitry. Alts is the list of case alternatives, Decls 8247 -- is the top level declaration list where labels are declared 8248 -- and Stmts is the list of finalization actions. Num_Comps 8249 -- denotes the current number of components needing finalization. 8250 8251 ------------------------------------ 8252 -- Process_Component_For_Finalize -- 8253 ------------------------------------ 8254 8255 procedure Process_Component_For_Finalize 8256 (Decl : Node_Id; 8257 Alts : List_Id; 8258 Decls : List_Id; 8259 Stmts : List_Id; 8260 Num_Comps : in out Nat) 8261 is 8262 Id : constant Entity_Id := Defining_Identifier (Decl); 8263 Typ : constant Entity_Id := Etype (Id); 8264 Fin_Call : Node_Id; 8265 8266 begin 8267 if Is_Local then 8268 declare 8269 Label : Node_Id; 8270 Label_Id : Entity_Id; 8271 8272 begin 8273 -- Generate: 8274 -- LN : label; 8275 8276 Label_Id := 8277 Make_Identifier (Loc, 8278 Chars => New_External_Name ('L', Num_Comps)); 8279 Set_Entity (Label_Id, 8280 Make_Defining_Identifier (Loc, Chars (Label_Id))); 8281 Label := Make_Label (Loc, Label_Id); 8282 8283 Append_To (Decls, 8284 Make_Implicit_Label_Declaration (Loc, 8285 Defining_Identifier => Entity (Label_Id), 8286 Label_Construct => Label)); 8287 8288 -- Generate: 8289 -- when N => 8290 -- goto LN; 8291 8292 Append_To (Alts, 8293 Make_Case_Statement_Alternative (Loc, 8294 Discrete_Choices => New_List ( 8295 Make_Integer_Literal (Loc, Num_Comps)), 8296 8297 Statements => New_List ( 8298 Make_Goto_Statement (Loc, 8299 Name => 8300 New_Occurrence_Of (Entity (Label_Id), Loc))))); 8301 8302 -- Generate: 8303 -- <<LN>> 8304 8305 Append_To (Stmts, Label); 8306 8307 -- Decrease the number of components to be processed. 8308 -- This action yields a new Label_Id in future calls. 8309 8310 Num_Comps := Num_Comps - 1; 8311 end; 8312 end if; 8313 8314 -- Generate: 8315 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation 8316 8317 -- begin -- Exception handlers allowed 8318 -- [Deep_]Finalize (V.Id); 8319 -- exception 8320 -- when others => 8321 -- if not Raised then 8322 -- Raised := True; 8323 -- Save_Occurrence (E, 8324 -- Get_Current_Excep.all.all); 8325 -- end if; 8326 -- end; 8327 8328 Fin_Call := 8329 Make_Final_Call 8330 (Obj_Ref => 8331 Make_Selected_Component (Loc, 8332 Prefix => Make_Identifier (Loc, Name_V), 8333 Selector_Name => Make_Identifier (Loc, Chars (Id))), 8334 Typ => Typ); 8335 8336 -- Guard against a missing [Deep_]Finalize when the component 8337 -- type was not properly frozen. 8338 8339 if Present (Fin_Call) then 8340 if Exceptions_OK then 8341 Fin_Call := 8342 Make_Block_Statement (Loc, 8343 Handled_Statement_Sequence => 8344 Make_Handled_Sequence_Of_Statements (Loc, 8345 Statements => New_List (Fin_Call), 8346 Exception_Handlers => New_List ( 8347 Build_Exception_Handler (Finalizer_Data)))); 8348 end if; 8349 8350 Append_To (Stmts, Fin_Call); 8351 end if; 8352 end Process_Component_For_Finalize; 8353 8354 -- Local variables 8355 8356 Alts : List_Id; 8357 Counter_Id : Entity_Id := Empty; 8358 Decl : Node_Id; 8359 Decl_Id : Entity_Id; 8360 Decl_Typ : Entity_Id; 8361 Decls : List_Id; 8362 Has_POC : Boolean; 8363 Jump_Block : Node_Id; 8364 Label : Node_Id; 8365 Label_Id : Entity_Id; 8366 Num_Comps : Nat; 8367 Stmts : List_Id; 8368 Var_Case : Node_Id; 8369 8370 -- Start of processing for Process_Component_List_For_Finalize 8371 8372 begin 8373 -- Perform an initial check, look for controlled and per-object 8374 -- constrained components. 8375 8376 Preprocess_Components (Comps, Num_Comps, Has_POC); 8377 8378 -- Create a state counter to service the current component list. 8379 -- This step is performed before the variants are inspected in 8380 -- order to generate the same state counter names as those from 8381 -- Build_Initialize_Statements. 8382 8383 if Num_Comps > 0 and then Is_Local then 8384 Counter := Counter + 1; 8385 8386 Counter_Id := 8387 Make_Defining_Identifier (Loc, 8388 Chars => New_External_Name ('C', Counter)); 8389 end if; 8390 8391 -- Process the component in the following order: 8392 -- 1) Variants 8393 -- 2) Per-object constrained components 8394 -- 3) Regular components 8395 8396 -- Start with the variant parts 8397 8398 Var_Case := Empty; 8399 if Present (Variant_Part (Comps)) then 8400 declare 8401 Var_Alts : constant List_Id := New_List; 8402 Var : Node_Id; 8403 8404 begin 8405 Var := First_Non_Pragma (Variants (Variant_Part (Comps))); 8406 while Present (Var) loop 8407 8408 -- Generate: 8409 -- when <discrete choices> => 8410 -- <finalize statements> 8411 8412 Append_To (Var_Alts, 8413 Make_Case_Statement_Alternative (Loc, 8414 Discrete_Choices => 8415 New_Copy_List (Discrete_Choices (Var)), 8416 Statements => 8417 Process_Component_List_For_Finalize ( 8418 Component_List (Var)))); 8419 8420 Next_Non_Pragma (Var); 8421 end loop; 8422 8423 -- Generate: 8424 -- case V.<discriminant> is 8425 -- when <discrete choices 1> => 8426 -- <finalize statements 1> 8427 -- ... 8428 -- when <discrete choices N> => 8429 -- <finalize statements N> 8430 -- end case; 8431 8432 Var_Case := 8433 Make_Case_Statement (Loc, 8434 Expression => 8435 Make_Selected_Component (Loc, 8436 Prefix => Make_Identifier (Loc, Name_V), 8437 Selector_Name => 8438 Make_Identifier (Loc, 8439 Chars => Chars (Name (Variant_Part (Comps))))), 8440 Alternatives => Var_Alts); 8441 end; 8442 end if; 8443 8444 -- The current component list does not have a single controlled 8445 -- component, however it may contain variants. Return the case 8446 -- statement for the variants or nothing. 8447 8448 if Num_Comps = 0 then 8449 if Present (Var_Case) then 8450 return New_List (Var_Case); 8451 else 8452 return New_List (Make_Null_Statement (Loc)); 8453 end if; 8454 end if; 8455 8456 -- Prepare all lists 8457 8458 Alts := New_List; 8459 Decls := New_List; 8460 Stmts := New_List; 8461 8462 -- Process all per-object constrained components in reverse order 8463 8464 if Has_POC then 8465 Decl := Last_Non_Pragma (Component_Items (Comps)); 8466 while Present (Decl) loop 8467 Decl_Id := Defining_Identifier (Decl); 8468 Decl_Typ := Etype (Decl_Id); 8469 8470 -- Skip _parent 8471 8472 if Chars (Decl_Id) /= Name_uParent 8473 and then Needs_Finalization (Decl_Typ) 8474 and then Has_Access_Constraint (Decl_Id) 8475 and then No (Expression (Decl)) 8476 then 8477 Process_Component_For_Finalize 8478 (Decl, Alts, Decls, Stmts, Num_Comps); 8479 end if; 8480 8481 Prev_Non_Pragma (Decl); 8482 end loop; 8483 end if; 8484 8485 -- Process the rest of the components in reverse order 8486 8487 Decl := Last_Non_Pragma (Component_Items (Comps)); 8488 while Present (Decl) loop 8489 Decl_Id := Defining_Identifier (Decl); 8490 Decl_Typ := Etype (Decl_Id); 8491 8492 -- Skip _parent 8493 8494 if Chars (Decl_Id) /= Name_uParent 8495 and then Needs_Finalization (Decl_Typ) 8496 then 8497 -- Skip per-object constrained components since they were 8498 -- handled in the above step. 8499 8500 if Has_Access_Constraint (Decl_Id) 8501 and then No (Expression (Decl)) 8502 then 8503 null; 8504 else 8505 Process_Component_For_Finalize 8506 (Decl, Alts, Decls, Stmts, Num_Comps); 8507 end if; 8508 end if; 8509 8510 Prev_Non_Pragma (Decl); 8511 end loop; 8512 8513 -- Generate: 8514 -- declare 8515 -- LN : label; -- If Is_Local is enabled 8516 -- ... . 8517 -- L0 : label; . 8518 8519 -- begin . 8520 -- case CounterX is . 8521 -- when N => . 8522 -- goto LN; . 8523 -- ... . 8524 -- when 1 => . 8525 -- goto L1; . 8526 -- when others => . 8527 -- goto L0; . 8528 -- end case; . 8529 8530 -- <<LN>> -- If Is_Local is enabled 8531 -- begin 8532 -- [Deep_]Finalize (V.CompY); 8533 -- exception 8534 -- when Id : others => 8535 -- if not Raised then 8536 -- Raised := True; 8537 -- Save_Occurrence (E, 8538 -- Get_Current_Excep.all.all); 8539 -- end if; 8540 -- end; 8541 -- ... 8542 -- <<L0>> -- If Is_Local is enabled 8543 -- end; 8544 8545 if Is_Local then 8546 8547 -- Add the declaration of default jump location L0, its 8548 -- corresponding alternative and its place in the statements. 8549 8550 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0)); 8551 Set_Entity (Label_Id, 8552 Make_Defining_Identifier (Loc, Chars (Label_Id))); 8553 Label := Make_Label (Loc, Label_Id); 8554 8555 Append_To (Decls, -- declaration 8556 Make_Implicit_Label_Declaration (Loc, 8557 Defining_Identifier => Entity (Label_Id), 8558 Label_Construct => Label)); 8559 8560 Append_To (Alts, -- alternative 8561 Make_Case_Statement_Alternative (Loc, 8562 Discrete_Choices => New_List ( 8563 Make_Others_Choice (Loc)), 8564 8565 Statements => New_List ( 8566 Make_Goto_Statement (Loc, 8567 Name => New_Occurrence_Of (Entity (Label_Id), Loc))))); 8568 8569 Append_To (Stmts, Label); -- statement 8570 8571 -- Create the jump block 8572 8573 Prepend_To (Stmts, 8574 Make_Case_Statement (Loc, 8575 Expression => Make_Identifier (Loc, Chars (Counter_Id)), 8576 Alternatives => Alts)); 8577 end if; 8578 8579 Jump_Block := 8580 Make_Block_Statement (Loc, 8581 Declarations => Decls, 8582 Handled_Statement_Sequence => 8583 Make_Handled_Sequence_Of_Statements (Loc, Stmts)); 8584 8585 if Present (Var_Case) then 8586 return New_List (Var_Case, Jump_Block); 8587 else 8588 return New_List (Jump_Block); 8589 end if; 8590 end Process_Component_List_For_Finalize; 8591 8592 -- Local variables 8593 8594 Bod_Stmts : List_Id := No_List; 8595 Finalizer_Decls : List_Id := No_List; 8596 Rec_Def : Node_Id; 8597 8598 -- Start of processing for Build_Finalize_Statements 8599 8600 begin 8601 Finalizer_Decls := New_List; 8602 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); 8603 8604 if Nkind (Typ_Def) = N_Derived_Type_Definition then 8605 Rec_Def := Record_Extension_Part (Typ_Def); 8606 else 8607 Rec_Def := Typ_Def; 8608 end if; 8609 8610 -- Create a finalization sequence for all record components 8611 8612 if Present (Component_List (Rec_Def)) then 8613 Bod_Stmts := 8614 Process_Component_List_For_Finalize (Component_List (Rec_Def)); 8615 end if; 8616 8617 -- A derived record type must finalize all inherited components. This 8618 -- action poses the following problem: 8619 8620 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is 8621 -- begin 8622 -- Finalize (Obj); 8623 -- ... 8624 8625 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is 8626 -- begin 8627 -- Deep_Finalize (Obj._parent); 8628 -- ... 8629 -- Finalize (Obj); 8630 -- ... 8631 8632 -- Finalizing the derived type will invoke Finalize of the parent and 8633 -- then that of the derived type. This is undesirable because both 8634 -- routines may modify shared components. Only the Finalize of the 8635 -- derived type should be invoked. 8636 8637 -- To prevent this double adjustment of shared components, 8638 -- Deep_Finalize uses a flag to control the invocation of Finalize: 8639 8640 -- procedure Deep_Finalize 8641 -- (Obj : in out Some_Type; 8642 -- Flag : Boolean := True) 8643 -- is 8644 -- begin 8645 -- if Flag then 8646 -- Finalize (Obj); 8647 -- end if; 8648 -- ... 8649 8650 -- When Deep_Finalize is invoked for field _parent, a value of False 8651 -- is provided for the flag: 8652 8653 -- Deep_Finalize (Obj._parent, False); 8654 8655 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then 8656 declare 8657 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ); 8658 Call : Node_Id; 8659 Fin_Stmt : Node_Id; 8660 8661 begin 8662 if Needs_Finalization (Par_Typ) then 8663 Call := 8664 Make_Final_Call 8665 (Obj_Ref => 8666 Make_Selected_Component (Loc, 8667 Prefix => Make_Identifier (Loc, Name_V), 8668 Selector_Name => 8669 Make_Identifier (Loc, Name_uParent)), 8670 Typ => Par_Typ, 8671 Skip_Self => True); 8672 8673 -- Generate: 8674 -- begin 8675 -- Deep_Finalize (V._parent, False); 8676 8677 -- exception 8678 -- when Id : others => 8679 -- if not Raised then 8680 -- Raised := True; 8681 -- Save_Occurrence (E, 8682 -- Get_Current_Excep.all.all); 8683 -- end if; 8684 -- end; 8685 8686 if Present (Call) then 8687 Fin_Stmt := Call; 8688 8689 if Exceptions_OK then 8690 Fin_Stmt := 8691 Make_Block_Statement (Loc, 8692 Handled_Statement_Sequence => 8693 Make_Handled_Sequence_Of_Statements (Loc, 8694 Statements => New_List (Fin_Stmt), 8695 Exception_Handlers => New_List ( 8696 Build_Exception_Handler 8697 (Finalizer_Data)))); 8698 end if; 8699 8700 Append_To (Bod_Stmts, Fin_Stmt); 8701 end if; 8702 end if; 8703 end; 8704 end if; 8705 8706 -- Finalize the object. This action must be performed first before 8707 -- all components have been finalized. 8708 8709 if Is_Controlled (Typ) and then not Is_Local then 8710 declare 8711 Fin_Stmt : Node_Id; 8712 Proc : Entity_Id; 8713 8714 begin 8715 Proc := Find_Optional_Prim_Op (Typ, Name_Finalize); 8716 8717 -- Generate: 8718 -- if F then 8719 -- begin 8720 -- Finalize (V); 8721 8722 -- exception 8723 -- when others => 8724 -- if not Raised then 8725 -- Raised := True; 8726 -- Save_Occurrence (E, 8727 -- Get_Current_Excep.all.all); 8728 -- end if; 8729 -- end; 8730 -- end if; 8731 8732 if Present (Proc) then 8733 Fin_Stmt := 8734 Make_Procedure_Call_Statement (Loc, 8735 Name => New_Occurrence_Of (Proc, Loc), 8736 Parameter_Associations => New_List ( 8737 Make_Identifier (Loc, Name_V))); 8738 8739 if Exceptions_OK then 8740 Fin_Stmt := 8741 Make_Block_Statement (Loc, 8742 Handled_Statement_Sequence => 8743 Make_Handled_Sequence_Of_Statements (Loc, 8744 Statements => New_List (Fin_Stmt), 8745 Exception_Handlers => New_List ( 8746 Build_Exception_Handler 8747 (Finalizer_Data)))); 8748 end if; 8749 8750 Prepend_To (Bod_Stmts, 8751 Make_If_Statement (Loc, 8752 Condition => Make_Identifier (Loc, Name_F), 8753 Then_Statements => New_List (Fin_Stmt))); 8754 end if; 8755 end; 8756 end if; 8757 8758 -- At this point either all finalization statements have been 8759 -- generated or the type is not controlled. 8760 8761 if No (Bod_Stmts) then 8762 return New_List (Make_Null_Statement (Loc)); 8763 8764 -- Generate: 8765 -- declare 8766 -- Abort : constant Boolean := Triggered_By_Abort; 8767 -- <or> 8768 -- Abort : constant Boolean := False; -- no abort 8769 8770 -- E : Exception_Occurrence; 8771 -- Raised : Boolean := False; 8772 8773 -- begin 8774 -- <finalize statements> 8775 8776 -- if Raised and then not Abort then 8777 -- Raise_From_Controlled_Operation (E); 8778 -- end if; 8779 -- end; 8780 8781 else 8782 if Exceptions_OK then 8783 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data)); 8784 end if; 8785 8786 return 8787 New_List ( 8788 Make_Block_Statement (Loc, 8789 Declarations => 8790 Finalizer_Decls, 8791 Handled_Statement_Sequence => 8792 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts))); 8793 end if; 8794 end Build_Finalize_Statements; 8795 8796 ----------------------- 8797 -- Parent_Field_Type -- 8798 ----------------------- 8799 8800 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is 8801 Field : Entity_Id; 8802 8803 begin 8804 Field := First_Entity (Typ); 8805 while Present (Field) loop 8806 if Chars (Field) = Name_uParent then 8807 return Etype (Field); 8808 end if; 8809 8810 Next_Entity (Field); 8811 end loop; 8812 8813 -- A derived tagged type should always have a parent field 8814 8815 raise Program_Error; 8816 end Parent_Field_Type; 8817 8818 --------------------------- 8819 -- Preprocess_Components -- 8820 --------------------------- 8821 8822 procedure Preprocess_Components 8823 (Comps : Node_Id; 8824 Num_Comps : out Nat; 8825 Has_POC : out Boolean) 8826 is 8827 Decl : Node_Id; 8828 Id : Entity_Id; 8829 Typ : Entity_Id; 8830 8831 begin 8832 Num_Comps := 0; 8833 Has_POC := False; 8834 8835 Decl := First_Non_Pragma (Component_Items (Comps)); 8836 while Present (Decl) loop 8837 Id := Defining_Identifier (Decl); 8838 Typ := Etype (Id); 8839 8840 -- Skip field _parent 8841 8842 if Chars (Id) /= Name_uParent 8843 and then Needs_Finalization (Typ) 8844 then 8845 Num_Comps := Num_Comps + 1; 8846 8847 if Has_Access_Constraint (Id) 8848 and then No (Expression (Decl)) 8849 then 8850 Has_POC := True; 8851 end if; 8852 end if; 8853 8854 Next_Non_Pragma (Decl); 8855 end loop; 8856 end Preprocess_Components; 8857 8858 -- Start of processing for Make_Deep_Record_Body 8859 8860 begin 8861 case Prim is 8862 when Address_Case => 8863 return Make_Finalize_Address_Stmts (Typ); 8864 8865 when Adjust_Case => 8866 return Build_Adjust_Statements (Typ); 8867 8868 when Finalize_Case => 8869 return Build_Finalize_Statements (Typ); 8870 8871 when Initialize_Case => 8872 declare 8873 Loc : constant Source_Ptr := Sloc (Typ); 8874 8875 begin 8876 if Is_Controlled (Typ) then 8877 return New_List ( 8878 Make_Procedure_Call_Statement (Loc, 8879 Name => 8880 New_Occurrence_Of 8881 (Find_Prim_Op (Typ, Name_Of (Prim)), Loc), 8882 Parameter_Associations => New_List ( 8883 Make_Identifier (Loc, Name_V)))); 8884 else 8885 return Empty_List; 8886 end if; 8887 end; 8888 end case; 8889 end Make_Deep_Record_Body; 8890 8891 ---------------------- 8892 -- Make_Final_Call -- 8893 ---------------------- 8894 8895 function Make_Final_Call 8896 (Obj_Ref : Node_Id; 8897 Typ : Entity_Id; 8898 Skip_Self : Boolean := False) return Node_Id 8899 is 8900 Loc : constant Source_Ptr := Sloc (Obj_Ref); 8901 Atyp : Entity_Id; 8902 Fin_Id : Entity_Id := Empty; 8903 Ref : Node_Id; 8904 Utyp : Entity_Id; 8905 8906 begin 8907 Ref := Obj_Ref; 8908 8909 -- Recover the proper type which contains [Deep_]Finalize 8910 8911 if Is_Class_Wide_Type (Typ) then 8912 Utyp := Root_Type (Typ); 8913 Atyp := Utyp; 8914 8915 elsif Is_Concurrent_Type (Typ) then 8916 Utyp := Corresponding_Record_Type (Typ); 8917 Atyp := Empty; 8918 Ref := Convert_Concurrent (Ref, Typ); 8919 8920 elsif Is_Private_Type (Typ) 8921 and then Present (Underlying_Type (Typ)) 8922 and then Is_Concurrent_Type (Underlying_Type (Typ)) 8923 then 8924 Utyp := Corresponding_Record_Type (Underlying_Type (Typ)); 8925 Atyp := Typ; 8926 Ref := Convert_Concurrent (Ref, Underlying_Type (Typ)); 8927 8928 else 8929 Utyp := Typ; 8930 Atyp := Typ; 8931 end if; 8932 8933 Utyp := Underlying_Type (Base_Type (Utyp)); 8934 Set_Assignment_OK (Ref); 8935 8936 -- Deal with untagged derivation of private views. If the parent type 8937 -- is a protected type, Deep_Finalize is found on the corresponding 8938 -- record of the ancestor. 8939 8940 if Is_Untagged_Derivation (Typ) then 8941 if Is_Protected_Type (Typ) then 8942 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); 8943 else 8944 Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); 8945 8946 if Is_Protected_Type (Utyp) then 8947 Utyp := Corresponding_Record_Type (Utyp); 8948 end if; 8949 end if; 8950 8951 Ref := Unchecked_Convert_To (Utyp, Ref); 8952 Set_Assignment_OK (Ref); 8953 end if; 8954 8955 -- Deal with derived private types which do not inherit primitives from 8956 -- their parents. In this case, [Deep_]Finalize can be found in the full 8957 -- view of the parent type. 8958 8959 if Present (Utyp) 8960 and then Is_Tagged_Type (Utyp) 8961 and then Is_Derived_Type (Utyp) 8962 and then Is_Empty_Elmt_List (Primitive_Operations (Utyp)) 8963 and then Is_Private_Type (Etype (Utyp)) 8964 and then Present (Full_View (Etype (Utyp))) 8965 then 8966 Utyp := Full_View (Etype (Utyp)); 8967 Ref := Unchecked_Convert_To (Utyp, Ref); 8968 Set_Assignment_OK (Ref); 8969 end if; 8970 8971 -- When dealing with the completion of a private type, use the base type 8972 -- instead. 8973 8974 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then 8975 pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp)); 8976 8977 Utyp := Base_Type (Utyp); 8978 Ref := Unchecked_Convert_To (Utyp, Ref); 8979 Set_Assignment_OK (Ref); 8980 end if; 8981 8982 -- The underlying type may not be present due to a missing full view. In 8983 -- this case freezing did not take place and there is no [Deep_]Finalize 8984 -- primitive to call. 8985 8986 if No (Utyp) then 8987 return Empty; 8988 8989 elsif Skip_Self then 8990 if Has_Controlled_Component (Utyp) then 8991 if Is_Tagged_Type (Utyp) then 8992 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); 8993 else 8994 Fin_Id := TSS (Utyp, TSS_Deep_Finalize); 8995 end if; 8996 end if; 8997 8998 -- Class-wide types, interfaces and types with controlled components 8999 9000 elsif Is_Class_Wide_Type (Typ) 9001 or else Is_Interface (Typ) 9002 or else Has_Controlled_Component (Utyp) 9003 then 9004 if Is_Tagged_Type (Utyp) then 9005 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); 9006 else 9007 Fin_Id := TSS (Utyp, TSS_Deep_Finalize); 9008 end if; 9009 9010 -- Derivations from [Limited_]Controlled 9011 9012 elsif Is_Controlled (Utyp) then 9013 if Has_Controlled_Component (Utyp) then 9014 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); 9015 else 9016 Fin_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Finalize_Case)); 9017 end if; 9018 9019 -- Tagged types 9020 9021 elsif Is_Tagged_Type (Utyp) then 9022 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); 9023 9024 -- Protected types: these also require finalization even though they 9025 -- are not marked controlled explicitly. 9026 9027 elsif Is_Protected_Type (Typ) then 9028 -- Protected objects do not need to be finalized on restricted 9029 -- runtimes. 9030 9031 if Restricted_Profile then 9032 return Empty; 9033 9034 -- ??? Only handle the simple case for now. Will not support a record 9035 -- or array containing protected objects. 9036 9037 elsif Is_Simple_Protected_Type (Typ) then 9038 Fin_Id := RTE (RE_Finalize_Protection); 9039 else 9040 raise Program_Error; 9041 end if; 9042 else 9043 raise Program_Error; 9044 end if; 9045 9046 if Present (Fin_Id) then 9047 9048 -- When finalizing a class-wide object, do not convert to the root 9049 -- type in order to produce a dispatching call. 9050 9051 if Is_Class_Wide_Type (Typ) then 9052 null; 9053 9054 -- Ensure that a finalization routine is at least decorated in order 9055 -- to inspect the object parameter. 9056 9057 elsif Analyzed (Fin_Id) 9058 or else Ekind (Fin_Id) = E_Procedure 9059 then 9060 -- In certain cases, such as the creation of Stream_Read, the 9061 -- visible entity of the type is its full view. Since Stream_Read 9062 -- will have to create an object of type Typ, the local object 9063 -- will be finalzed by the scope finalizer generated later on. The 9064 -- object parameter of Deep_Finalize will always use the private 9065 -- view of the type. To avoid such a clash between a private and a 9066 -- full view, perform an unchecked conversion of the object 9067 -- reference to the private view. 9068 9069 declare 9070 Formal_Typ : constant Entity_Id := 9071 Etype (First_Formal (Fin_Id)); 9072 begin 9073 if Is_Private_Type (Formal_Typ) 9074 and then Present (Full_View (Formal_Typ)) 9075 and then Full_View (Formal_Typ) = Utyp 9076 then 9077 Ref := Unchecked_Convert_To (Formal_Typ, Ref); 9078 end if; 9079 end; 9080 9081 -- If the object is unanalyzed, set its expected type for use in 9082 -- Convert_View in case an additional conversion is needed. 9083 9084 if No (Etype (Ref)) 9085 and then Nkind (Ref) /= N_Unchecked_Type_Conversion 9086 then 9087 Set_Etype (Ref, Typ); 9088 end if; 9089 9090 Ref := Convert_View (Fin_Id, Ref); 9091 end if; 9092 9093 return 9094 Make_Call (Loc, 9095 Proc_Id => Fin_Id, 9096 Param => Ref, 9097 Skip_Self => Skip_Self); 9098 else 9099 return Empty; 9100 end if; 9101 end Make_Final_Call; 9102 9103 -------------------------------- 9104 -- Make_Finalize_Address_Body -- 9105 -------------------------------- 9106 9107 procedure Make_Finalize_Address_Body (Typ : Entity_Id) is 9108 Is_Task : constant Boolean := 9109 Ekind (Typ) = E_Record_Type 9110 and then Is_Concurrent_Record_Type (Typ) 9111 and then Ekind (Corresponding_Concurrent_Type (Typ)) = 9112 E_Task_Type; 9113 Loc : constant Source_Ptr := Sloc (Typ); 9114 Proc_Id : Entity_Id; 9115 Stmts : List_Id; 9116 9117 begin 9118 -- The corresponding records of task types are not controlled by design. 9119 -- For the sake of completeness, create an empty Finalize_Address to be 9120 -- used in task class-wide allocations. 9121 9122 if Is_Task then 9123 null; 9124 9125 -- Nothing to do if the type is not controlled or it already has a 9126 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not 9127 -- come from source. These are usually generated for completeness and 9128 -- do not need the Finalize_Address primitive. 9129 9130 elsif not Needs_Finalization (Typ) 9131 or else Present (TSS (Typ, TSS_Finalize_Address)) 9132 or else 9133 (Is_Class_Wide_Type (Typ) 9134 and then Ekind (Root_Type (Typ)) = E_Record_Subtype 9135 and then not Comes_From_Source (Root_Type (Typ))) 9136 then 9137 return; 9138 end if; 9139 9140 -- Do not generate Finalize_Address routine for CodePeer 9141 9142 if CodePeer_Mode then 9143 return; 9144 end if; 9145 9146 Proc_Id := 9147 Make_Defining_Identifier (Loc, 9148 Make_TSS_Name (Typ, TSS_Finalize_Address)); 9149 9150 -- Generate: 9151 9152 -- procedure <Typ>FD (V : System.Address) is 9153 -- begin 9154 -- null; -- for tasks 9155 9156 -- declare -- for all other types 9157 -- type Pnn is access all Typ; 9158 -- for Pnn'Storage_Size use 0; 9159 -- begin 9160 -- [Deep_]Finalize (Pnn (V).all); 9161 -- end; 9162 -- end TypFD; 9163 9164 if Is_Task then 9165 Stmts := New_List (Make_Null_Statement (Loc)); 9166 else 9167 Stmts := Make_Finalize_Address_Stmts (Typ); 9168 end if; 9169 9170 Discard_Node ( 9171 Make_Subprogram_Body (Loc, 9172 Specification => 9173 Make_Procedure_Specification (Loc, 9174 Defining_Unit_Name => Proc_Id, 9175 9176 Parameter_Specifications => New_List ( 9177 Make_Parameter_Specification (Loc, 9178 Defining_Identifier => 9179 Make_Defining_Identifier (Loc, Name_V), 9180 Parameter_Type => 9181 New_Occurrence_Of (RTE (RE_Address), Loc)))), 9182 9183 Declarations => No_List, 9184 9185 Handled_Statement_Sequence => 9186 Make_Handled_Sequence_Of_Statements (Loc, 9187 Statements => Stmts))); 9188 9189 Set_TSS (Typ, Proc_Id); 9190 end Make_Finalize_Address_Body; 9191 9192 --------------------------------- 9193 -- Make_Finalize_Address_Stmts -- 9194 --------------------------------- 9195 9196 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is 9197 Loc : constant Source_Ptr := Sloc (Typ); 9198 9199 Decls : List_Id; 9200 Desig_Typ : Entity_Id; 9201 Fin_Block : Node_Id; 9202 Fin_Call : Node_Id; 9203 Obj_Expr : Node_Id; 9204 Ptr_Typ : Entity_Id; 9205 9206 begin 9207 if Is_Array_Type (Typ) then 9208 if Is_Constrained (First_Subtype (Typ)) then 9209 Desig_Typ := First_Subtype (Typ); 9210 else 9211 Desig_Typ := Base_Type (Typ); 9212 end if; 9213 9214 -- Class-wide types of constrained root types 9215 9216 elsif Is_Class_Wide_Type (Typ) 9217 and then Has_Discriminants (Root_Type (Typ)) 9218 and then not 9219 Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ))) 9220 then 9221 declare 9222 Parent_Typ : Entity_Id; 9223 9224 begin 9225 -- Climb the parent type chain looking for a non-constrained type 9226 9227 Parent_Typ := Root_Type (Typ); 9228 while Parent_Typ /= Etype (Parent_Typ) 9229 and then Has_Discriminants (Parent_Typ) 9230 and then not 9231 Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ)) 9232 loop 9233 Parent_Typ := Etype (Parent_Typ); 9234 end loop; 9235 9236 -- Handle views created for tagged types with unknown 9237 -- discriminants. 9238 9239 if Is_Underlying_Record_View (Parent_Typ) then 9240 Parent_Typ := Underlying_Record_View (Parent_Typ); 9241 end if; 9242 9243 Desig_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ)); 9244 end; 9245 9246 -- General case 9247 9248 else 9249 Desig_Typ := Typ; 9250 end if; 9251 9252 -- Generate: 9253 -- type Ptr_Typ is access all Typ; 9254 -- for Ptr_Typ'Storage_Size use 0; 9255 9256 Ptr_Typ := Make_Temporary (Loc, 'P'); 9257 9258 Decls := New_List ( 9259 Make_Full_Type_Declaration (Loc, 9260 Defining_Identifier => Ptr_Typ, 9261 Type_Definition => 9262 Make_Access_To_Object_Definition (Loc, 9263 All_Present => True, 9264 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))), 9265 9266 Make_Attribute_Definition_Clause (Loc, 9267 Name => New_Occurrence_Of (Ptr_Typ, Loc), 9268 Chars => Name_Storage_Size, 9269 Expression => Make_Integer_Literal (Loc, 0))); 9270 9271 Obj_Expr := Make_Identifier (Loc, Name_V); 9272 9273 -- Unconstrained arrays require special processing in order to retrieve 9274 -- the elements. To achieve this, we have to skip the dope vector which 9275 -- lays in front of the elements and then use a thin pointer to perform 9276 -- the address-to-access conversion. 9277 9278 if Is_Array_Type (Typ) 9279 and then not Is_Constrained (First_Subtype (Typ)) 9280 then 9281 declare 9282 Dope_Id : Entity_Id; 9283 9284 begin 9285 -- Ensure that Ptr_Typ a thin pointer, generate: 9286 -- for Ptr_Typ'Size use System.Address'Size; 9287 9288 Append_To (Decls, 9289 Make_Attribute_Definition_Clause (Loc, 9290 Name => New_Occurrence_Of (Ptr_Typ, Loc), 9291 Chars => Name_Size, 9292 Expression => 9293 Make_Integer_Literal (Loc, System_Address_Size))); 9294 9295 -- Generate: 9296 -- Dnn : constant Storage_Offset := 9297 -- Desig_Typ'Descriptor_Size / Storage_Unit; 9298 9299 Dope_Id := Make_Temporary (Loc, 'D'); 9300 9301 Append_To (Decls, 9302 Make_Object_Declaration (Loc, 9303 Defining_Identifier => Dope_Id, 9304 Constant_Present => True, 9305 Object_Definition => 9306 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc), 9307 Expression => 9308 Make_Op_Divide (Loc, 9309 Left_Opnd => 9310 Make_Attribute_Reference (Loc, 9311 Prefix => New_Occurrence_Of (Desig_Typ, Loc), 9312 Attribute_Name => Name_Descriptor_Size), 9313 Right_Opnd => 9314 Make_Integer_Literal (Loc, System_Storage_Unit)))); 9315 9316 -- Shift the address from the start of the dope vector to the 9317 -- start of the elements: 9318 -- 9319 -- V + Dnn 9320 -- 9321 -- Note that this is done through a wrapper routine since RTSfind 9322 -- cannot retrieve operations with string names of the form "+". 9323 9324 Obj_Expr := 9325 Make_Function_Call (Loc, 9326 Name => 9327 New_Occurrence_Of (RTE (RE_Add_Offset_To_Address), Loc), 9328 Parameter_Associations => New_List ( 9329 Obj_Expr, 9330 New_Occurrence_Of (Dope_Id, Loc))); 9331 end; 9332 end if; 9333 9334 Fin_Call := 9335 Make_Final_Call ( 9336 Obj_Ref => 9337 Make_Explicit_Dereference (Loc, 9338 Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)), 9339 Typ => Desig_Typ); 9340 9341 if Present (Fin_Call) then 9342 Fin_Block := 9343 Make_Block_Statement (Loc, 9344 Declarations => Decls, 9345 Handled_Statement_Sequence => 9346 Make_Handled_Sequence_Of_Statements (Loc, 9347 Statements => New_List (Fin_Call))); 9348 9349 -- Otherwise previous errors or a missing full view may prevent the 9350 -- proper freezing of the designated type. If this is the case, there 9351 -- is no [Deep_]Finalize primitive to call. 9352 9353 else 9354 Fin_Block := Make_Null_Statement (Loc); 9355 end if; 9356 9357 return New_List (Fin_Block); 9358 end Make_Finalize_Address_Stmts; 9359 9360 ------------------------------------- 9361 -- Make_Handler_For_Ctrl_Operation -- 9362 ------------------------------------- 9363 9364 -- Generate: 9365 9366 -- when E : others => 9367 -- Raise_From_Controlled_Operation (E); 9368 9369 -- or: 9370 9371 -- when others => 9372 -- raise Program_Error [finalize raised exception]; 9373 9374 -- depending on whether Raise_From_Controlled_Operation is available 9375 9376 function Make_Handler_For_Ctrl_Operation 9377 (Loc : Source_Ptr) return Node_Id 9378 is 9379 E_Occ : Entity_Id; 9380 -- Choice parameter (for the first case above) 9381 9382 Raise_Node : Node_Id; 9383 -- Procedure call or raise statement 9384 9385 begin 9386 -- Standard run-time: add choice parameter E and pass it to 9387 -- Raise_From_Controlled_Operation so that the original exception 9388 -- name and message can be recorded in the exception message for 9389 -- Program_Error. 9390 9391 if RTE_Available (RE_Raise_From_Controlled_Operation) then 9392 E_Occ := Make_Defining_Identifier (Loc, Name_E); 9393 Raise_Node := 9394 Make_Procedure_Call_Statement (Loc, 9395 Name => 9396 New_Occurrence_Of 9397 (RTE (RE_Raise_From_Controlled_Operation), Loc), 9398 Parameter_Associations => New_List ( 9399 New_Occurrence_Of (E_Occ, Loc))); 9400 9401 -- Restricted run-time: exception messages are not supported 9402 9403 else 9404 E_Occ := Empty; 9405 Raise_Node := 9406 Make_Raise_Program_Error (Loc, 9407 Reason => PE_Finalize_Raised_Exception); 9408 end if; 9409 9410 return 9411 Make_Implicit_Exception_Handler (Loc, 9412 Exception_Choices => New_List (Make_Others_Choice (Loc)), 9413 Choice_Parameter => E_Occ, 9414 Statements => New_List (Raise_Node)); 9415 end Make_Handler_For_Ctrl_Operation; 9416 9417 -------------------- 9418 -- Make_Init_Call -- 9419 -------------------- 9420 9421 function Make_Init_Call 9422 (Obj_Ref : Node_Id; 9423 Typ : Entity_Id) return Node_Id 9424 is 9425 Loc : constant Source_Ptr := Sloc (Obj_Ref); 9426 Is_Conc : Boolean; 9427 Proc : Entity_Id; 9428 Ref : Node_Id; 9429 Utyp : Entity_Id; 9430 9431 begin 9432 Ref := Obj_Ref; 9433 9434 -- Deal with the type and object reference. Depending on the context, an 9435 -- object reference may need several conversions. 9436 9437 if Is_Concurrent_Type (Typ) then 9438 Is_Conc := True; 9439 Utyp := Corresponding_Record_Type (Typ); 9440 Ref := Convert_Concurrent (Ref, Typ); 9441 9442 elsif Is_Private_Type (Typ) 9443 and then Present (Full_View (Typ)) 9444 and then Is_Concurrent_Type (Underlying_Type (Typ)) 9445 then 9446 Is_Conc := True; 9447 Utyp := Corresponding_Record_Type (Underlying_Type (Typ)); 9448 Ref := Convert_Concurrent (Ref, Underlying_Type (Typ)); 9449 9450 else 9451 Is_Conc := False; 9452 Utyp := Typ; 9453 end if; 9454 9455 Utyp := Underlying_Type (Base_Type (Utyp)); 9456 Set_Assignment_OK (Ref); 9457 9458 -- Deal with untagged derivation of private views 9459 9460 if Is_Untagged_Derivation (Typ) and then not Is_Conc then 9461 Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); 9462 Ref := Unchecked_Convert_To (Utyp, Ref); 9463 9464 -- The following is to prevent problems with UC see 1.156 RH ??? 9465 9466 Set_Assignment_OK (Ref); 9467 end if; 9468 9469 -- If the underlying_type is a subtype, then we are dealing with the 9470 -- completion of a private type. We need to access the base type and 9471 -- generate a conversion to it. 9472 9473 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then 9474 pragma Assert (Is_Private_Type (Typ)); 9475 Utyp := Base_Type (Utyp); 9476 Ref := Unchecked_Convert_To (Utyp, Ref); 9477 end if; 9478 9479 -- The underlying type may not be present due to a missing full view. 9480 -- In this case freezing did not take place and there is no suitable 9481 -- [Deep_]Initialize primitive to call. 9482 -- If Typ is protected then no additional processing is needed either. 9483 9484 if No (Utyp) 9485 or else Is_Protected_Type (Typ) 9486 then 9487 return Empty; 9488 end if; 9489 9490 -- Select the appropriate version of initialize 9491 9492 if Has_Controlled_Component (Utyp) then 9493 Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case)); 9494 else 9495 Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case)); 9496 Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref); 9497 end if; 9498 9499 -- If initialization procedure for an array of controlled objects is 9500 -- trivial, do not generate a useless call to it. 9501 9502 if (Is_Array_Type (Utyp) and then Is_Trivial_Subprogram (Proc)) 9503 or else 9504 (not Comes_From_Source (Proc) 9505 and then Present (Alias (Proc)) 9506 and then Is_Trivial_Subprogram (Alias (Proc))) 9507 then 9508 return Empty; 9509 end if; 9510 9511 -- The object reference may need another conversion depending on the 9512 -- type of the formal and that of the actual. 9513 9514 Ref := Convert_View (Proc, Ref); 9515 9516 -- Generate: 9517 -- [Deep_]Initialize (Ref); 9518 9519 return 9520 Make_Procedure_Call_Statement (Loc, 9521 Name => New_Occurrence_Of (Proc, Loc), 9522 Parameter_Associations => New_List (Ref)); 9523 end Make_Init_Call; 9524 9525 ------------------------------ 9526 -- Make_Local_Deep_Finalize -- 9527 ------------------------------ 9528 9529 function Make_Local_Deep_Finalize 9530 (Typ : Entity_Id; 9531 Nam : Entity_Id) return Node_Id 9532 is 9533 Loc : constant Source_Ptr := Sloc (Typ); 9534 Formals : List_Id; 9535 9536 begin 9537 Formals := New_List ( 9538 9539 -- V : in out Typ 9540 9541 Make_Parameter_Specification (Loc, 9542 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), 9543 In_Present => True, 9544 Out_Present => True, 9545 Parameter_Type => New_Occurrence_Of (Typ, Loc)), 9546 9547 -- F : Boolean := True 9548 9549 Make_Parameter_Specification (Loc, 9550 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F), 9551 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), 9552 Expression => New_Occurrence_Of (Standard_True, Loc))); 9553 9554 -- Add the necessary number of counters to represent the initialization 9555 -- state of an object. 9556 9557 return 9558 Make_Subprogram_Body (Loc, 9559 Specification => 9560 Make_Procedure_Specification (Loc, 9561 Defining_Unit_Name => Nam, 9562 Parameter_Specifications => Formals), 9563 9564 Declarations => No_List, 9565 9566 Handled_Statement_Sequence => 9567 Make_Handled_Sequence_Of_Statements (Loc, 9568 Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True))); 9569 end Make_Local_Deep_Finalize; 9570 9571 ------------------------------------ 9572 -- Make_Set_Finalize_Address_Call -- 9573 ------------------------------------ 9574 9575 function Make_Set_Finalize_Address_Call 9576 (Loc : Source_Ptr; 9577 Ptr_Typ : Entity_Id) return Node_Id 9578 is 9579 -- It is possible for Ptr_Typ to be a partial view, if the access type 9580 -- is a full view declared in the private part of a nested package, and 9581 -- the finalization actions take place when completing analysis of the 9582 -- enclosing unit. For this reason use Underlying_Type twice below. 9583 9584 Desig_Typ : constant Entity_Id := 9585 Available_View 9586 (Designated_Type (Underlying_Type (Ptr_Typ))); 9587 Fin_Addr : constant Entity_Id := Finalize_Address (Desig_Typ); 9588 Fin_Mas : constant Entity_Id := 9589 Finalization_Master (Underlying_Type (Ptr_Typ)); 9590 9591 begin 9592 -- Both the finalization master and primitive Finalize_Address must be 9593 -- available. 9594 9595 pragma Assert (Present (Fin_Addr) and Present (Fin_Mas)); 9596 9597 -- Generate: 9598 -- Set_Finalize_Address 9599 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access); 9600 9601 return 9602 Make_Procedure_Call_Statement (Loc, 9603 Name => 9604 New_Occurrence_Of (RTE (RE_Set_Finalize_Address), Loc), 9605 Parameter_Associations => New_List ( 9606 New_Occurrence_Of (Fin_Mas, Loc), 9607 9608 Make_Attribute_Reference (Loc, 9609 Prefix => New_Occurrence_Of (Fin_Addr, Loc), 9610 Attribute_Name => Name_Unrestricted_Access))); 9611 end Make_Set_Finalize_Address_Call; 9612 9613 -------------------------- 9614 -- Make_Transient_Block -- 9615 -------------------------- 9616 9617 function Make_Transient_Block 9618 (Loc : Source_Ptr; 9619 Action : Node_Id; 9620 Par : Node_Id) return Node_Id 9621 is 9622 function Manages_Sec_Stack (Id : Entity_Id) return Boolean; 9623 -- Determine whether scoping entity Id manages the secondary stack 9624 9625 function Within_Loop_Statement (N : Node_Id) return Boolean; 9626 -- Return True when N appears within a loop and no block is containing N 9627 9628 ----------------------- 9629 -- Manages_Sec_Stack -- 9630 ----------------------- 9631 9632 function Manages_Sec_Stack (Id : Entity_Id) return Boolean is 9633 begin 9634 case Ekind (Id) is 9635 9636 -- An exception handler with a choice parameter utilizes a dummy 9637 -- block to provide a declarative region. Such a block should not 9638 -- be considered because it never manifests in the tree and can 9639 -- never release the secondary stack. 9640 9641 when E_Block => 9642 return 9643 Uses_Sec_Stack (Id) and then not Is_Exception_Handler (Id); 9644 9645 when E_Entry 9646 | E_Entry_Family 9647 | E_Function 9648 | E_Procedure 9649 => 9650 return Uses_Sec_Stack (Id); 9651 9652 when others => 9653 return False; 9654 end case; 9655 end Manages_Sec_Stack; 9656 9657 --------------------------- 9658 -- Within_Loop_Statement -- 9659 --------------------------- 9660 9661 function Within_Loop_Statement (N : Node_Id) return Boolean is 9662 Par : Node_Id := Parent (N); 9663 9664 begin 9665 while Nkind (Par) not in 9666 N_Handled_Sequence_Of_Statements | N_Loop_Statement | 9667 N_Package_Specification | N_Proper_Body 9668 loop 9669 pragma Assert (Present (Par)); 9670 Par := Parent (Par); 9671 end loop; 9672 9673 return Nkind (Par) = N_Loop_Statement; 9674 end Within_Loop_Statement; 9675 9676 -- Local variables 9677 9678 Decls : constant List_Id := New_List; 9679 Instrs : constant List_Id := New_List (Action); 9680 Trans_Id : constant Entity_Id := Current_Scope; 9681 9682 Block : Node_Id; 9683 Insert : Node_Id; 9684 Scop : Entity_Id; 9685 9686 -- Start of processing for Make_Transient_Block 9687 9688 begin 9689 -- Even though the transient block is tasked with managing the secondary 9690 -- stack, the block may forgo this functionality depending on how the 9691 -- secondary stack is managed by enclosing scopes. 9692 9693 if Manages_Sec_Stack (Trans_Id) then 9694 9695 -- Determine whether an enclosing scope already manages the secondary 9696 -- stack. 9697 9698 Scop := Scope (Trans_Id); 9699 while Present (Scop) loop 9700 9701 -- It should not be possible to reach Standard without hitting one 9702 -- of the other cases first unless Standard was manually pushed. 9703 9704 if Scop = Standard_Standard then 9705 exit; 9706 9707 -- The transient block is within a function which returns on the 9708 -- secondary stack. Take a conservative approach and assume that 9709 -- the value on the secondary stack is part of the result. Note 9710 -- that it is not possible to detect this dependency without flow 9711 -- analysis which the compiler does not have. Letting the object 9712 -- live longer than the transient block will not leak any memory 9713 -- because the caller will reclaim the total storage used by the 9714 -- function. 9715 9716 elsif Ekind (Scop) = E_Function 9717 and then Sec_Stack_Needed_For_Return (Scop) 9718 then 9719 Set_Uses_Sec_Stack (Trans_Id, False); 9720 exit; 9721 9722 -- The transient block must manage the secondary stack when the 9723 -- block appears within a loop in order to reclaim the memory at 9724 -- each iteration. 9725 9726 elsif Ekind (Scop) = E_Loop then 9727 exit; 9728 9729 -- Ditto when the block appears without a block that does not 9730 -- manage the secondary stack and is located within a loop. 9731 9732 elsif Ekind (Scop) = E_Block 9733 and then not Manages_Sec_Stack (Scop) 9734 and then Present (Block_Node (Scop)) 9735 and then Within_Loop_Statement (Block_Node (Scop)) 9736 then 9737 exit; 9738 9739 -- The transient block does not need to manage the secondary stack 9740 -- when there is an enclosing construct which already does that. 9741 -- This optimization saves on SS_Mark and SS_Release calls but may 9742 -- allow objects to live a little longer than required. 9743 9744 -- The transient block must manage the secondary stack when switch 9745 -- -gnatd.s (strict management) is in effect. 9746 9747 elsif Manages_Sec_Stack (Scop) and then not Debug_Flag_Dot_S then 9748 Set_Uses_Sec_Stack (Trans_Id, False); 9749 exit; 9750 9751 -- Prevent the search from going too far because transient blocks 9752 -- are bounded by packages and subprogram scopes. 9753 9754 elsif Ekind (Scop) in E_Entry 9755 | E_Entry_Family 9756 | E_Function 9757 | E_Package 9758 | E_Procedure 9759 | E_Subprogram_Body 9760 then 9761 exit; 9762 end if; 9763 9764 Scop := Scope (Scop); 9765 end loop; 9766 end if; 9767 9768 -- Create the transient block. Set the parent now since the block itself 9769 -- is not part of the tree. The current scope is the E_Block entity that 9770 -- has been pushed by Establish_Transient_Scope. 9771 9772 pragma Assert (Ekind (Trans_Id) = E_Block); 9773 9774 Block := 9775 Make_Block_Statement (Loc, 9776 Identifier => New_Occurrence_Of (Trans_Id, Loc), 9777 Declarations => Decls, 9778 Handled_Statement_Sequence => 9779 Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs), 9780 Has_Created_Identifier => True); 9781 Set_Parent (Block, Par); 9782 9783 -- Insert actions stuck in the transient scopes as well as all freezing 9784 -- nodes needed by those actions. Do not insert cleanup actions here, 9785 -- they will be transferred to the newly created block. 9786 9787 Insert_Actions_In_Scope_Around 9788 (Action, Clean => False, Manage_SS => False); 9789 9790 Insert := Prev (Action); 9791 9792 if Present (Insert) then 9793 Freeze_All (First_Entity (Trans_Id), Insert); 9794 end if; 9795 9796 -- Transfer cleanup actions to the newly created block 9797 9798 declare 9799 Cleanup_Actions : List_Id 9800 renames Scope_Stack.Table (Scope_Stack.Last). 9801 Actions_To_Be_Wrapped (Cleanup); 9802 begin 9803 Set_Cleanup_Actions (Block, Cleanup_Actions); 9804 Cleanup_Actions := No_List; 9805 end; 9806 9807 -- When the transient scope was established, we pushed the entry for the 9808 -- transient scope onto the scope stack, so that the scope was active 9809 -- for the installation of finalizable entities etc. Now we must remove 9810 -- this entry, since we have constructed a proper block. 9811 9812 Pop_Scope; 9813 9814 return Block; 9815 end Make_Transient_Block; 9816 9817 ------------------------ 9818 -- Node_To_Be_Wrapped -- 9819 ------------------------ 9820 9821 function Node_To_Be_Wrapped return Node_Id is 9822 begin 9823 return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped; 9824 end Node_To_Be_Wrapped; 9825 9826 ---------------------------- 9827 -- Set_Node_To_Be_Wrapped -- 9828 ---------------------------- 9829 9830 procedure Set_Node_To_Be_Wrapped (N : Node_Id) is 9831 begin 9832 Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N; 9833 end Set_Node_To_Be_Wrapped; 9834 9835 ---------------------------- 9836 -- Store_Actions_In_Scope -- 9837 ---------------------------- 9838 9839 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id) is 9840 SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); 9841 Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK); 9842 9843 begin 9844 if No (Actions) then 9845 Actions := L; 9846 9847 if Is_List_Member (SE.Node_To_Be_Wrapped) then 9848 Set_Parent (L, Parent (SE.Node_To_Be_Wrapped)); 9849 else 9850 Set_Parent (L, SE.Node_To_Be_Wrapped); 9851 end if; 9852 9853 Analyze_List (L); 9854 9855 elsif AK = Before then 9856 Insert_List_After_And_Analyze (Last (Actions), L); 9857 9858 else 9859 Insert_List_Before_And_Analyze (First (Actions), L); 9860 end if; 9861 end Store_Actions_In_Scope; 9862 9863 ---------------------------------- 9864 -- Store_After_Actions_In_Scope -- 9865 ---------------------------------- 9866 9867 procedure Store_After_Actions_In_Scope (L : List_Id) is 9868 begin 9869 Store_Actions_In_Scope (After, L); 9870 end Store_After_Actions_In_Scope; 9871 9872 ----------------------------------- 9873 -- Store_Before_Actions_In_Scope -- 9874 ----------------------------------- 9875 9876 procedure Store_Before_Actions_In_Scope (L : List_Id) is 9877 begin 9878 Store_Actions_In_Scope (Before, L); 9879 end Store_Before_Actions_In_Scope; 9880 9881 ----------------------------------- 9882 -- Store_Cleanup_Actions_In_Scope -- 9883 ----------------------------------- 9884 9885 procedure Store_Cleanup_Actions_In_Scope (L : List_Id) is 9886 begin 9887 Store_Actions_In_Scope (Cleanup, L); 9888 end Store_Cleanup_Actions_In_Scope; 9889 9890 ------------------ 9891 -- Unnest_Block -- 9892 ------------------ 9893 9894 procedure Unnest_Block (Decl : Node_Id) is 9895 Loc : constant Source_Ptr := Sloc (Decl); 9896 Ent : Entity_Id; 9897 Local_Body : Node_Id; 9898 Local_Call : Node_Id; 9899 Local_Proc : Entity_Id; 9900 Local_Scop : Entity_Id; 9901 9902 begin 9903 Local_Scop := Entity (Identifier (Decl)); 9904 Ent := First_Entity (Local_Scop); 9905 9906 Local_Proc := 9907 Make_Defining_Identifier (Loc, 9908 Chars => New_Internal_Name ('P')); 9909 9910 Local_Body := 9911 Make_Subprogram_Body (Loc, 9912 Specification => 9913 Make_Procedure_Specification (Loc, 9914 Defining_Unit_Name => Local_Proc), 9915 Declarations => Declarations (Decl), 9916 Handled_Statement_Sequence => 9917 Handled_Statement_Sequence (Decl)); 9918 9919 -- Handlers in the block may contain nested subprograms that require 9920 -- unnesting. 9921 9922 Check_Unnesting_In_Handlers (Local_Body); 9923 9924 Rewrite (Decl, Local_Body); 9925 Analyze (Decl); 9926 Set_Has_Nested_Subprogram (Local_Proc); 9927 9928 Local_Call := 9929 Make_Procedure_Call_Statement (Loc, 9930 Name => New_Occurrence_Of (Local_Proc, Loc)); 9931 9932 Insert_After (Decl, Local_Call); 9933 Analyze (Local_Call); 9934 9935 -- The new subprogram has the same scope as the original block 9936 9937 Set_Scope (Local_Proc, Scope (Local_Scop)); 9938 9939 -- And the entity list of the new procedure is that of the block 9940 9941 Set_First_Entity (Local_Proc, Ent); 9942 9943 -- Reset the scopes of all the entities to the new procedure 9944 9945 while Present (Ent) loop 9946 Set_Scope (Ent, Local_Proc); 9947 Next_Entity (Ent); 9948 end loop; 9949 end Unnest_Block; 9950 9951 ------------------------- 9952 -- Unnest_If_Statement -- 9953 ------------------------- 9954 9955 procedure Unnest_If_Statement (If_Stmt : Node_Id) is 9956 9957 procedure Check_Stmts_For_Subp_Unnesting (Stmts : in out List_Id); 9958 -- A list of statements (that may be a list associated with a then, 9959 -- elsif, or else part of an if-statement) is traversed at the top 9960 -- level to determine whether it contains a subprogram body, and if so, 9961 -- the statements will be replaced with a new procedure body containing 9962 -- the statements followed by a call to the procedure. The individual 9963 -- statements may also be blocks, loops, or other if statements that 9964 -- themselves may require contain nested subprograms needing unnesting. 9965 9966 procedure Check_Stmts_For_Subp_Unnesting (Stmts : in out List_Id) is 9967 Subp_Found : Boolean := False; 9968 9969 begin 9970 if Is_Empty_List (Stmts) then 9971 return; 9972 end if; 9973 9974 declare 9975 Stmt : Node_Id := First (Stmts); 9976 begin 9977 while Present (Stmt) loop 9978 if Nkind (Stmt) = N_Subprogram_Body then 9979 Subp_Found := True; 9980 exit; 9981 end if; 9982 9983 Next (Stmt); 9984 end loop; 9985 end; 9986 9987 -- The statements themselves may be blocks, loops, etc. that in turn 9988 -- contain nested subprograms requiring an unnesting transformation. 9989 -- We perform this traversal after looking for subprogram bodies, to 9990 -- avoid considering procedures created for one of those statements 9991 -- (such as a block rewritten as a procedure) as a nested subprogram 9992 -- of the statement list (which could result in an unneeded wrapper 9993 -- procedure). 9994 9995 Check_Unnesting_In_Decls_Or_Stmts (Stmts); 9996 9997 -- If there was a top-level subprogram body in the statement list, 9998 -- then perform an unnesting transformation on the list by replacing 9999 -- the statements with a wrapper procedure body containing the 10000 -- original statements followed by a call to that procedure. 10001 10002 if Subp_Found then 10003 Unnest_Statement_List (Stmts); 10004 end if; 10005 end Check_Stmts_For_Subp_Unnesting; 10006 10007 -- Local variables 10008 10009 Then_Stmts : List_Id := Then_Statements (If_Stmt); 10010 Else_Stmts : List_Id := Else_Statements (If_Stmt); 10011 10012 -- Start of processing for Unnest_If_Statement 10013 10014 begin 10015 Check_Stmts_For_Subp_Unnesting (Then_Stmts); 10016 Set_Then_Statements (If_Stmt, Then_Stmts); 10017 10018 if not Is_Empty_List (Elsif_Parts (If_Stmt)) then 10019 declare 10020 Elsif_Part : Node_Id := 10021 First (Elsif_Parts (If_Stmt)); 10022 Elsif_Stmts : List_Id; 10023 begin 10024 while Present (Elsif_Part) loop 10025 Elsif_Stmts := Then_Statements (Elsif_Part); 10026 10027 Check_Stmts_For_Subp_Unnesting (Elsif_Stmts); 10028 Set_Then_Statements (Elsif_Part, Elsif_Stmts); 10029 10030 Next (Elsif_Part); 10031 end loop; 10032 end; 10033 end if; 10034 10035 Check_Stmts_For_Subp_Unnesting (Else_Stmts); 10036 Set_Else_Statements (If_Stmt, Else_Stmts); 10037 end Unnest_If_Statement; 10038 10039 ----------------- 10040 -- Unnest_Loop -- 10041 ----------------- 10042 10043 procedure Unnest_Loop (Loop_Stmt : Node_Id) is 10044 Loc : constant Source_Ptr := Sloc (Loop_Stmt); 10045 Ent : Entity_Id; 10046 Local_Body : Node_Id; 10047 Local_Call : Node_Id; 10048 Local_Proc : Entity_Id; 10049 Local_Scop : Entity_Id; 10050 Loop_Copy : constant Node_Id := 10051 Relocate_Node (Loop_Stmt); 10052 begin 10053 Local_Scop := Entity (Identifier (Loop_Stmt)); 10054 Ent := First_Entity (Local_Scop); 10055 10056 Local_Proc := 10057 Make_Defining_Identifier (Loc, 10058 Chars => New_Internal_Name ('P')); 10059 10060 Local_Body := 10061 Make_Subprogram_Body (Loc, 10062 Specification => 10063 Make_Procedure_Specification (Loc, 10064 Defining_Unit_Name => Local_Proc), 10065 Declarations => Empty_List, 10066 Handled_Statement_Sequence => 10067 Make_Handled_Sequence_Of_Statements (Loc, 10068 Statements => New_List (Loop_Copy))); 10069 10070 Set_First_Real_Statement 10071 (Handled_Statement_Sequence (Local_Body), Loop_Copy); 10072 10073 Rewrite (Loop_Stmt, Local_Body); 10074 Analyze (Loop_Stmt); 10075 10076 Set_Has_Nested_Subprogram (Local_Proc); 10077 10078 Local_Call := 10079 Make_Procedure_Call_Statement (Loc, 10080 Name => New_Occurrence_Of (Local_Proc, Loc)); 10081 10082 Insert_After (Loop_Stmt, Local_Call); 10083 Analyze (Local_Call); 10084 10085 -- New procedure has the same scope as the original loop, and the scope 10086 -- of the loop is the new procedure. 10087 10088 Set_Scope (Local_Proc, Scope (Local_Scop)); 10089 Set_Scope (Local_Scop, Local_Proc); 10090 10091 -- The entity list of the new procedure is that of the loop 10092 10093 Set_First_Entity (Local_Proc, Ent); 10094 10095 -- Note that the entities associated with the loop don't need to have 10096 -- their Scope fields reset, since they're still associated with the 10097 -- same loop entity that now belongs to the copied loop statement. 10098 end Unnest_Loop; 10099 10100 --------------------------- 10101 -- Unnest_Statement_List -- 10102 --------------------------- 10103 10104 procedure Unnest_Statement_List (Stmts : in out List_Id) is 10105 Loc : constant Source_Ptr := Sloc (First (Stmts)); 10106 Local_Body : Node_Id; 10107 Local_Call : Node_Id; 10108 Local_Proc : Entity_Id; 10109 New_Stmts : constant List_Id := Empty_List; 10110 10111 begin 10112 Local_Proc := 10113 Make_Defining_Identifier (Loc, 10114 Chars => New_Internal_Name ('P')); 10115 10116 Local_Body := 10117 Make_Subprogram_Body (Loc, 10118 Specification => 10119 Make_Procedure_Specification (Loc, 10120 Defining_Unit_Name => Local_Proc), 10121 Declarations => Empty_List, 10122 Handled_Statement_Sequence => 10123 Make_Handled_Sequence_Of_Statements (Loc, 10124 Statements => Stmts)); 10125 10126 Append_To (New_Stmts, Local_Body); 10127 10128 Analyze (Local_Body); 10129 10130 Set_Has_Nested_Subprogram (Local_Proc); 10131 10132 Local_Call := 10133 Make_Procedure_Call_Statement (Loc, 10134 Name => New_Occurrence_Of (Local_Proc, Loc)); 10135 10136 Append_To (New_Stmts, Local_Call); 10137 Analyze (Local_Call); 10138 10139 -- Traverse the statements, and for any that are declarations or 10140 -- subprogram bodies that have entities, set the Scope of those 10141 -- entities to the new procedure's Entity_Id. 10142 10143 declare 10144 Stmt : Node_Id := First (Stmts); 10145 10146 begin 10147 while Present (Stmt) loop 10148 case Nkind (Stmt) is 10149 when N_Declaration 10150 | N_Renaming_Declaration 10151 => 10152 Set_Scope (Defining_Identifier (Stmt), Local_Proc); 10153 10154 when N_Subprogram_Body => 10155 Set_Scope 10156 (Defining_Unit_Name (Specification (Stmt)), Local_Proc); 10157 10158 when others => 10159 null; 10160 end case; 10161 10162 Next (Stmt); 10163 end loop; 10164 end; 10165 10166 Stmts := New_Stmts; 10167 end Unnest_Statement_List; 10168 10169 -------------------------------- 10170 -- Wrap_Transient_Declaration -- 10171 -------------------------------- 10172 10173 -- If a transient scope has been established during the processing of the 10174 -- Expression of an Object_Declaration, it is not possible to wrap the 10175 -- declaration into a transient block as usual case, otherwise the object 10176 -- would be itself declared in the wrong scope. Therefore, all entities (if 10177 -- any) defined in the transient block are moved to the proper enclosing 10178 -- scope. Furthermore, if they are controlled variables they are finalized 10179 -- right after the declaration. The finalization list of the transient 10180 -- scope is defined as a renaming of the enclosing one so during their 10181 -- initialization they will be attached to the proper finalization list. 10182 -- For instance, the following declaration : 10183 10184 -- X : Typ := F (G (A), G (B)); 10185 10186 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2) 10187 -- is expanded into : 10188 10189 -- X : Typ := [ complex Expression-Action ]; 10190 -- [Deep_]Finalize (_v1); 10191 -- [Deep_]Finalize (_v2); 10192 10193 procedure Wrap_Transient_Declaration (N : Node_Id) is 10194 Curr_S : Entity_Id; 10195 Encl_S : Entity_Id; 10196 10197 begin 10198 Curr_S := Current_Scope; 10199 Encl_S := Scope (Curr_S); 10200 10201 -- Insert all actions including cleanup generated while analyzing or 10202 -- expanding the transient context back into the tree. Manage the 10203 -- secondary stack when the object declaration appears in a library 10204 -- level package [body]. 10205 10206 Insert_Actions_In_Scope_Around 10207 (N => N, 10208 Clean => True, 10209 Manage_SS => 10210 Uses_Sec_Stack (Curr_S) 10211 and then Nkind (N) = N_Object_Declaration 10212 and then Ekind (Encl_S) in E_Package | E_Package_Body 10213 and then Is_Library_Level_Entity (Encl_S)); 10214 Pop_Scope; 10215 10216 -- Relocate local entities declared within the transient scope to the 10217 -- enclosing scope. This action sets their Is_Public flag accordingly. 10218 10219 Transfer_Entities (Curr_S, Encl_S); 10220 10221 -- Mark the enclosing dynamic scope to ensure that the secondary stack 10222 -- is properly released upon exiting the said scope. 10223 10224 if Uses_Sec_Stack (Curr_S) then 10225 Curr_S := Enclosing_Dynamic_Scope (Curr_S); 10226 10227 -- Do not mark a function that returns on the secondary stack as the 10228 -- reclamation is done by the caller. 10229 10230 if Ekind (Curr_S) = E_Function 10231 and then Requires_Transient_Scope (Etype (Curr_S)) 10232 then 10233 null; 10234 10235 -- Otherwise mark the enclosing dynamic scope 10236 10237 else 10238 Set_Uses_Sec_Stack (Curr_S); 10239 Check_Restriction (No_Secondary_Stack, N); 10240 end if; 10241 end if; 10242 end Wrap_Transient_Declaration; 10243 10244 ------------------------------- 10245 -- Wrap_Transient_Expression -- 10246 ------------------------------- 10247 10248 procedure Wrap_Transient_Expression (N : Node_Id) is 10249 Loc : constant Source_Ptr := Sloc (N); 10250 Expr : Node_Id := Relocate_Node (N); 10251 Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N); 10252 Typ : constant Entity_Id := Etype (N); 10253 10254 begin 10255 -- Generate: 10256 10257 -- Temp : Typ; 10258 -- declare 10259 -- M : constant Mark_Id := SS_Mark; 10260 -- procedure Finalizer is ... (See Build_Finalizer) 10261 10262 -- begin 10263 -- Temp := <Expr>; -- general case 10264 -- Temp := (if <Expr> then True else False); -- boolean case 10265 10266 -- at end 10267 -- Finalizer; 10268 -- end; 10269 10270 -- A special case is made for Boolean expressions so that the back end 10271 -- knows to generate a conditional branch instruction, if running with 10272 -- -fpreserve-control-flow. This ensures that a control-flow change 10273 -- signaling the decision outcome occurs before the cleanup actions. 10274 10275 if Opt.Suppress_Control_Flow_Optimizations 10276 and then Is_Boolean_Type (Typ) 10277 then 10278 Expr := 10279 Make_If_Expression (Loc, 10280 Expressions => New_List ( 10281 Expr, 10282 New_Occurrence_Of (Standard_True, Loc), 10283 New_Occurrence_Of (Standard_False, Loc))); 10284 end if; 10285 10286 Insert_Actions (N, New_List ( 10287 Make_Object_Declaration (Loc, 10288 Defining_Identifier => Temp, 10289 Object_Definition => New_Occurrence_Of (Typ, Loc)), 10290 10291 Make_Transient_Block (Loc, 10292 Action => 10293 Make_Assignment_Statement (Loc, 10294 Name => New_Occurrence_Of (Temp, Loc), 10295 Expression => Expr), 10296 Par => Parent (N)))); 10297 10298 if Debug_Generated_Code then 10299 Set_Debug_Info_Needed (Temp); 10300 end if; 10301 10302 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 10303 Analyze_And_Resolve (N, Typ); 10304 end Wrap_Transient_Expression; 10305 10306 ------------------------------ 10307 -- Wrap_Transient_Statement -- 10308 ------------------------------ 10309 10310 procedure Wrap_Transient_Statement (N : Node_Id) is 10311 Loc : constant Source_Ptr := Sloc (N); 10312 New_Stmt : constant Node_Id := Relocate_Node (N); 10313 10314 begin 10315 -- Generate: 10316 -- declare 10317 -- M : constant Mark_Id := SS_Mark; 10318 -- procedure Finalizer is ... (See Build_Finalizer) 10319 -- 10320 -- begin 10321 -- <New_Stmt>; 10322 -- 10323 -- at end 10324 -- Finalizer; 10325 -- end; 10326 10327 Rewrite (N, 10328 Make_Transient_Block (Loc, 10329 Action => New_Stmt, 10330 Par => Parent (N))); 10331 10332 -- With the scope stack back to normal, we can call analyze on the 10333 -- resulting block. At this point, the transient scope is being 10334 -- treated like a perfectly normal scope, so there is nothing 10335 -- special about it. 10336 10337 -- Note: Wrap_Transient_Statement is called with the node already 10338 -- analyzed (i.e. Analyzed (N) is True). This is important, since 10339 -- otherwise we would get a recursive processing of the node when 10340 -- we do this Analyze call. 10341 10342 Analyze (N); 10343 end Wrap_Transient_Statement; 10344 10345end Exp_Ch7; 10346