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