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