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