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