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