1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ U N S T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2014-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Debug; use Debug; 28with Einfo; use Einfo; 29with Elists; use Elists; 30with Lib; use Lib; 31with Namet; use Namet; 32with Nlists; use Nlists; 33with Nmake; use Nmake; 34with Opt; 35with Output; use Output; 36with Rtsfind; use Rtsfind; 37with Sem; use Sem; 38with Sem_Aux; use Sem_Aux; 39with Sem_Ch8; use Sem_Ch8; 40with Sem_Mech; use Sem_Mech; 41with Sem_Res; use Sem_Res; 42with Sem_Util; use Sem_Util; 43with Sinfo; use Sinfo; 44with Sinput; use Sinput; 45with Snames; use Snames; 46with Stand; use Stand; 47with Tbuild; use Tbuild; 48with Uintp; use Uintp; 49 50package body Exp_Unst is 51 52 ----------------------- 53 -- Local Subprograms -- 54 ----------------------- 55 56 procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id); 57 -- Subp is a library-level subprogram which has nested subprograms, and 58 -- Subp_Body is the corresponding N_Subprogram_Body node. This procedure 59 -- declares the AREC types and objects, adds assignments to the AREC record 60 -- as required, defines the xxxPTR types for uplevel referenced objects, 61 -- adds the ARECP parameter to all nested subprograms which need it, and 62 -- modifies all uplevel references appropriately. 63 64 ----------- 65 -- Calls -- 66 ----------- 67 68 -- Table to record calls within the nest being analyzed. These are the 69 -- calls which may need to have an AREC actual added. This table is built 70 -- new for each subprogram nest and cleared at the end of processing each 71 -- subprogram nest. 72 73 type Call_Entry is record 74 N : Node_Id; 75 -- The actual call 76 77 Caller : Entity_Id; 78 -- Entity of the subprogram containing the call (can be at any level) 79 80 Callee : Entity_Id; 81 -- Entity of the subprogram called (always at level 2 or higher). Note 82 -- that in accordance with the basic rules of nesting, the level of To 83 -- is either less than or equal to the level of From, or one greater. 84 end record; 85 86 package Calls is new Table.Table ( 87 Table_Component_Type => Call_Entry, 88 Table_Index_Type => Nat, 89 Table_Low_Bound => 1, 90 Table_Initial => 100, 91 Table_Increment => 200, 92 Table_Name => "Unnest_Calls"); 93 -- Records each call within the outer subprogram and all nested subprograms 94 -- that are to other subprograms nested within the outer subprogram. These 95 -- are the calls that may need an additional parameter. 96 97 procedure Append_Unique_Call (Call : Call_Entry); 98 -- Append a call entry to the Calls table. A check is made to see if the 99 -- table already contains this entry and if so it has no effect. 100 101 ---------------------------------- 102 -- Subprograms For Fat Pointers -- 103 ---------------------------------- 104 105 function Build_Access_Type_Decl 106 (E : Entity_Id; 107 Scop : Entity_Id) return Node_Id; 108 -- For an uplevel reference that involves an unconstrained array type, 109 -- build an access type declaration for the corresponding activation 110 -- record component. The relevant attributes of the access type are 111 -- set here to avoid a full analysis that would require a scope stack. 112 113 function Needs_Fat_Pointer (E : Entity_Id) return Boolean; 114 -- A formal parameter of an unconstrained array type that appears in an 115 -- uplevel reference requires the construction of an access type, to be 116 -- used in the corresponding component declaration. 117 118 ----------- 119 -- Urefs -- 120 ----------- 121 122 -- Table to record explicit uplevel references to objects (variables, 123 -- constants, formal parameters). These are the references that will 124 -- need rewriting to use the activation table (AREC) pointers. Also 125 -- included are implicit and explicit uplevel references to types, but 126 -- these do not get rewritten by the front end. This table is built new 127 -- for each subprogram nest and cleared at the end of processing each 128 -- subprogram nest. 129 130 type Uref_Entry is record 131 Ref : Node_Id; 132 -- The reference itself. For objects this is always an entity reference 133 -- and the referenced entity will have its Is_Uplevel_Referenced_Entity 134 -- flag set and will appear in the Uplevel_Referenced_Entities list of 135 -- the subprogram declaring this entity. 136 137 Ent : Entity_Id; 138 -- The Entity_Id of the uplevel referenced object or type 139 140 Caller : Entity_Id; 141 -- The entity for the subprogram immediately containing this entity 142 143 Callee : Entity_Id; 144 -- The entity for the subprogram containing the referenced entity. Note 145 -- that the level of Callee must be less than the level of Caller, since 146 -- this is an uplevel reference. 147 end record; 148 149 package Urefs is new Table.Table ( 150 Table_Component_Type => Uref_Entry, 151 Table_Index_Type => Nat, 152 Table_Low_Bound => 1, 153 Table_Initial => 100, 154 Table_Increment => 200, 155 Table_Name => "Unnest_Urefs"); 156 157 ------------------------ 158 -- Append_Unique_Call -- 159 ------------------------ 160 161 procedure Append_Unique_Call (Call : Call_Entry) is 162 begin 163 for J in Calls.First .. Calls.Last loop 164 if Calls.Table (J) = Call then 165 return; 166 end if; 167 end loop; 168 169 Calls.Append (Call); 170 end Append_Unique_Call; 171 172 ----------------------------- 173 -- Build_Access_Type_Decl -- 174 ----------------------------- 175 176 function Build_Access_Type_Decl 177 (E : Entity_Id; 178 Scop : Entity_Id) return Node_Id 179 is 180 Loc : constant Source_Ptr := Sloc (E); 181 Typ : Entity_Id; 182 183 begin 184 Typ := Make_Temporary (Loc, 'S'); 185 Set_Ekind (Typ, E_General_Access_Type); 186 Set_Etype (Typ, Typ); 187 Set_Scope (Typ, Scop); 188 Set_Directly_Designated_Type (Typ, Etype (E)); 189 190 return 191 Make_Full_Type_Declaration (Loc, 192 Defining_Identifier => Typ, 193 Type_Definition => 194 Make_Access_To_Object_Definition (Loc, 195 Subtype_Indication => New_Occurrence_Of (Etype (E), Loc))); 196 end Build_Access_Type_Decl; 197 198 --------------- 199 -- Get_Level -- 200 --------------- 201 202 function Get_Level (Subp : Entity_Id; Sub : Entity_Id) return Nat is 203 Lev : Nat; 204 S : Entity_Id; 205 206 begin 207 Lev := 1; 208 S := Sub; 209 loop 210 if S = Subp then 211 return Lev; 212 else 213 Lev := Lev + 1; 214 S := Enclosing_Subprogram (S); 215 end if; 216 end loop; 217 end Get_Level; 218 219 -------------------------- 220 -- In_Synchronized_Unit -- 221 -------------------------- 222 223 function In_Synchronized_Unit (Subp : Entity_Id) return Boolean is 224 S : Entity_Id := Scope (Subp); 225 226 begin 227 while Present (S) and then S /= Standard_Standard loop 228 if Is_Concurrent_Type (S) then 229 return True; 230 231 elsif Is_Private_Type (S) 232 and then Present (Full_View (S)) 233 and then Is_Concurrent_Type (Full_View (S)) 234 then 235 return True; 236 end if; 237 238 S := Scope (S); 239 end loop; 240 241 return False; 242 end In_Synchronized_Unit; 243 244 ----------------------- 245 -- Needs_Fat_Pointer -- 246 ----------------------- 247 248 function Needs_Fat_Pointer (E : Entity_Id) return Boolean is 249 Typ : Entity_Id; 250 begin 251 if Is_Formal (E) then 252 Typ := Etype (E); 253 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 254 Typ := Full_View (Typ); 255 end if; 256 257 return Is_Array_Type (Typ) 258 and then not Is_Constrained (Typ); 259 else 260 return False; 261 end if; 262 end Needs_Fat_Pointer; 263 264 ---------------- 265 -- Subp_Index -- 266 ---------------- 267 268 function Subp_Index (Sub : Entity_Id) return SI_Type is 269 E : Entity_Id := Sub; 270 271 begin 272 pragma Assert (Is_Subprogram (E)); 273 274 if Subps_Index (E) = Uint_0 then 275 E := Ultimate_Alias (E); 276 277 -- The body of a protected operation has a different name and 278 -- has been scanned at this point, and thus has an entry in the 279 -- subprogram table. 280 281 if E = Sub and then Convention (E) = Convention_Protected then 282 E := Protected_Body_Subprogram (E); 283 end if; 284 285 if Ekind (E) = E_Function 286 and then Rewritten_For_C (E) 287 and then Present (Corresponding_Procedure (E)) 288 then 289 E := Corresponding_Procedure (E); 290 end if; 291 end if; 292 293 pragma Assert (Subps_Index (E) /= Uint_0); 294 return SI_Type (UI_To_Int (Subps_Index (E))); 295 end Subp_Index; 296 297 ----------------------- 298 -- Unnest_Subprogram -- 299 ----------------------- 300 301 procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is 302 function AREC_Name (J : Pos; S : String) return Name_Id; 303 -- Returns name for string ARECjS, where j is the decimal value of j 304 305 function Enclosing_Subp (Subp : SI_Type) return SI_Type; 306 -- Subp is the index of a subprogram which has a Lev greater than 1. 307 -- This function returns the index of the enclosing subprogram which 308 -- will have a Lev value one less than this. 309 310 function Img_Pos (N : Pos) return String; 311 -- Return image of N without leading blank 312 313 function Upref_Name 314 (Ent : Entity_Id; 315 Index : Pos; 316 Clist : List_Id) return Name_Id; 317 -- This function returns the name to be used in the activation record to 318 -- reference the variable uplevel. Clist is the list of components that 319 -- have been created in the activation record so far. Normally the name 320 -- is just a copy of the Chars field of the entity. The exception is 321 -- when the name has already been used, in which case we suffix the name 322 -- with the index value Index to avoid duplication. This happens with 323 -- declare blocks and generic parameters at least. 324 325 --------------- 326 -- AREC_Name -- 327 --------------- 328 329 function AREC_Name (J : Pos; S : String) return Name_Id is 330 begin 331 return Name_Find ("AREC" & Img_Pos (J) & S); 332 end AREC_Name; 333 334 -------------------- 335 -- Enclosing_Subp -- 336 -------------------- 337 338 function Enclosing_Subp (Subp : SI_Type) return SI_Type is 339 STJ : Subp_Entry renames Subps.Table (Subp); 340 Ret : constant SI_Type := Subp_Index (Enclosing_Subprogram (STJ.Ent)); 341 begin 342 pragma Assert (STJ.Lev > 1); 343 pragma Assert (Subps.Table (Ret).Lev = STJ.Lev - 1); 344 return Ret; 345 end Enclosing_Subp; 346 347 ------------- 348 -- Img_Pos -- 349 ------------- 350 351 function Img_Pos (N : Pos) return String is 352 Buf : String (1 .. 20); 353 Ptr : Natural; 354 NV : Nat; 355 356 begin 357 Ptr := Buf'Last; 358 NV := N; 359 while NV /= 0 loop 360 Buf (Ptr) := Character'Val (48 + NV mod 10); 361 Ptr := Ptr - 1; 362 NV := NV / 10; 363 end loop; 364 365 return Buf (Ptr + 1 .. Buf'Last); 366 end Img_Pos; 367 368 ---------------- 369 -- Upref_Name -- 370 ---------------- 371 372 function Upref_Name 373 (Ent : Entity_Id; 374 Index : Pos; 375 Clist : List_Id) return Name_Id 376 is 377 C : Node_Id; 378 begin 379 C := First (Clist); 380 loop 381 if No (C) then 382 return Chars (Ent); 383 384 elsif Chars (Defining_Identifier (C)) = Chars (Ent) then 385 return 386 Name_Find (Get_Name_String (Chars (Ent)) & Img_Pos (Index)); 387 else 388 Next (C); 389 end if; 390 end loop; 391 end Upref_Name; 392 393 -- Start of processing for Unnest_Subprogram 394 395 begin 396 -- Nothing to do inside a generic (all processing is for instance) 397 398 if Inside_A_Generic then 399 return; 400 end if; 401 402 -- If the main unit is a package body then we need to examine the spec 403 -- to determine whether the main unit is generic (the scope stack is not 404 -- present when this is called on the main unit). 405 406 if Ekind (Cunit_Entity (Main_Unit)) = E_Package_Body 407 and then Is_Generic_Unit (Spec_Entity (Cunit_Entity (Main_Unit))) 408 then 409 return; 410 end if; 411 412 -- Only unnest when generating code for the main source unit 413 414 if not In_Extended_Main_Code_Unit (Subp_Body) then 415 return; 416 end if; 417 418 -- This routine is called late, after the scope stack is gone. The 419 -- following creates a suitable dummy scope stack to be used for the 420 -- analyze/expand calls made from this routine. 421 422 Push_Scope (Subp); 423 424 -- First step, we must mark all nested subprograms that require a static 425 -- link (activation record) because either they contain explicit uplevel 426 -- references (as indicated by Is_Uplevel_Referenced_Entity being set at 427 -- this point), or they make calls to other subprograms in the same nest 428 -- that require a static link (in which case we set this flag). 429 430 -- This is a recursive definition, and to implement this, we have to 431 -- build a call graph for the set of nested subprograms, and then go 432 -- over this graph to implement recursively the invariant that if a 433 -- subprogram has a call to a subprogram requiring a static link, then 434 -- the calling subprogram requires a static link. 435 436 -- First populate the above tables 437 438 Subps_First := Subps.Last + 1; 439 Calls.Init; 440 Urefs.Init; 441 442 Build_Tables : declare 443 Current_Subprogram : Entity_Id := Empty; 444 -- When we scan a subprogram body, we set Current_Subprogram to the 445 -- corresponding entity. This gets recursively saved and restored. 446 447 function Visit_Node (N : Node_Id) return Traverse_Result; 448 -- Visit a single node in Subp 449 450 ----------- 451 -- Visit -- 452 ----------- 453 454 procedure Visit is new Traverse_Proc (Visit_Node); 455 -- Used to traverse the body of Subp, populating the tables 456 457 ---------------- 458 -- Visit_Node -- 459 ---------------- 460 461 function Visit_Node (N : Node_Id) return Traverse_Result is 462 Ent : Entity_Id; 463 Caller : Entity_Id; 464 Callee : Entity_Id; 465 466 procedure Check_Static_Type 467 (T : Entity_Id; N : Node_Id; DT : in out Boolean); 468 -- Given a type T, checks if it is a static type defined as a type 469 -- with no dynamic bounds in sight. If so, the only action is to 470 -- set Is_Static_Type True for T. If T is not a static type, then 471 -- all types with dynamic bounds associated with T are detected, 472 -- and their bounds are marked as uplevel referenced if not at the 473 -- library level, and DT is set True. If N is specified, it's the 474 -- node that will need to be replaced. If not specified, it means 475 -- we can't do a replacement because the bound is implicit. 476 477 procedure Note_Uplevel_Ref 478 (E : Entity_Id; 479 N : Node_Id; 480 Caller : Entity_Id; 481 Callee : Entity_Id); 482 -- Called when we detect an explicit or implicit uplevel reference 483 -- from within Caller to entity E declared in Callee. E can be a 484 -- an object or a type. 485 486 procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id); 487 -- Enter a subprogram whose body is visible or which is a 488 -- subprogram instance into the subprogram table. 489 490 ----------------------- 491 -- Check_Static_Type -- 492 ----------------------- 493 494 procedure Check_Static_Type 495 (T : Entity_Id; N : Node_Id; DT : in out Boolean) 496 is 497 procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id); 498 -- N is the bound of a dynamic type. This procedure notes that 499 -- this bound is uplevel referenced, it can handle references 500 -- to entities (typically _FIRST and _LAST entities), and also 501 -- attribute references of the form T'name (name is typically 502 -- FIRST or LAST) where T is the uplevel referenced bound. 503 -- Ref, if Present, is the location of the reference to 504 -- replace. 505 506 ------------------------ 507 -- Note_Uplevel_Bound -- 508 ------------------------ 509 510 procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id) is 511 begin 512 -- Entity name case. Make sure that the entity is declared 513 -- in a subprogram. This may not be the case for for a type 514 -- in a loop appearing in a precondition. 515 -- Exclude explicitly discriminants (that can appear 516 -- in bounds of discriminated components). 517 518 if Is_Entity_Name (N) then 519 if Present (Entity (N)) 520 and then not Is_Type (Entity (N)) 521 and then Present (Enclosing_Subprogram (Entity (N))) 522 and then Ekind (Entity (N)) /= E_Discriminant 523 then 524 Note_Uplevel_Ref 525 (E => Entity (N), 526 N => Empty, 527 Caller => Current_Subprogram, 528 Callee => Enclosing_Subprogram (Entity (N))); 529 end if; 530 531 -- Attribute or indexed component case 532 533 elsif Nkind_In (N, N_Attribute_Reference, 534 N_Indexed_Component) 535 then 536 Note_Uplevel_Bound (Prefix (N), Ref); 537 538 -- The indices of the indexed components, or the 539 -- associated expressions of an attribute reference, 540 -- may also involve uplevel references. 541 542 declare 543 Expr : Node_Id; 544 545 begin 546 Expr := First (Expressions (N)); 547 while Present (Expr) loop 548 Note_Uplevel_Bound (Expr, Ref); 549 Next (Expr); 550 end loop; 551 end; 552 553 -- The type of the prefix may be have an uplevel 554 -- reference if this needs bounds. 555 556 if Nkind (N) = N_Attribute_Reference then 557 declare 558 Attr : constant Attribute_Id := 559 Get_Attribute_Id (Attribute_Name (N)); 560 DT : Boolean := False; 561 562 begin 563 if (Attr = Attribute_First 564 or else Attr = Attribute_Last 565 or else Attr = Attribute_Length) 566 and then Is_Constrained (Etype (Prefix (N))) 567 then 568 Check_Static_Type 569 (Etype (Prefix (N)), Empty, DT); 570 end if; 571 end; 572 end if; 573 574 -- Binary operator cases. These can apply to arrays for 575 -- which we may need bounds. 576 577 elsif Nkind (N) in N_Binary_Op then 578 Note_Uplevel_Bound (Left_Opnd (N), Ref); 579 Note_Uplevel_Bound (Right_Opnd (N), Ref); 580 581 -- Unary operator case 582 583 elsif Nkind (N) in N_Unary_Op then 584 Note_Uplevel_Bound (Right_Opnd (N), Ref); 585 586 -- Explicit dereference and selected component case 587 588 elsif Nkind_In (N, N_Explicit_Dereference, 589 N_Selected_Component) 590 then 591 Note_Uplevel_Bound (Prefix (N), Ref); 592 593 -- Conversion case 594 595 elsif Nkind (N) = N_Type_Conversion then 596 Note_Uplevel_Bound (Expression (N), Ref); 597 end if; 598 end Note_Uplevel_Bound; 599 600 -- Start of processing for Check_Static_Type 601 602 begin 603 -- If already marked static, immediate return 604 605 if Is_Static_Type (T) then 606 return; 607 end if; 608 609 -- If the type is at library level, always consider it static, 610 -- since such uplevel references are irrelevant. 611 612 if Is_Library_Level_Entity (T) then 613 Set_Is_Static_Type (T); 614 return; 615 end if; 616 617 -- Otherwise figure out what the story is with this type 618 619 -- For a scalar type, check bounds 620 621 if Is_Scalar_Type (T) then 622 623 -- If both bounds static, then this is a static type 624 625 declare 626 LB : constant Node_Id := Type_Low_Bound (T); 627 UB : constant Node_Id := Type_High_Bound (T); 628 629 begin 630 if not Is_Static_Expression (LB) then 631 Note_Uplevel_Bound (LB, N); 632 DT := True; 633 end if; 634 635 if not Is_Static_Expression (UB) then 636 Note_Uplevel_Bound (UB, N); 637 DT := True; 638 end if; 639 end; 640 641 -- For record type, check all components and discriminant 642 -- constraints if present. 643 644 elsif Is_Record_Type (T) then 645 declare 646 C : Entity_Id; 647 D : Elmt_Id; 648 649 begin 650 C := First_Component_Or_Discriminant (T); 651 while Present (C) loop 652 Check_Static_Type (Etype (C), N, DT); 653 Next_Component_Or_Discriminant (C); 654 end loop; 655 656 if Has_Discriminants (T) 657 and then Present (Discriminant_Constraint (T)) 658 then 659 D := First_Elmt (Discriminant_Constraint (T)); 660 while Present (D) loop 661 if not Is_Static_Expression (Node (D)) then 662 Note_Uplevel_Bound (Node (D), N); 663 DT := True; 664 end if; 665 666 Next_Elmt (D); 667 end loop; 668 end if; 669 end; 670 671 -- For array type, check index types and component type 672 673 elsif Is_Array_Type (T) then 674 declare 675 IX : Node_Id; 676 begin 677 Check_Static_Type (Component_Type (T), N, DT); 678 679 IX := First_Index (T); 680 while Present (IX) loop 681 Check_Static_Type (Etype (IX), N, DT); 682 Next_Index (IX); 683 end loop; 684 end; 685 686 -- For private type, examine whether full view is static 687 688 elsif Is_Private_Type (T) and then Present (Full_View (T)) then 689 Check_Static_Type (Full_View (T), N, DT); 690 691 if Is_Static_Type (Full_View (T)) then 692 Set_Is_Static_Type (T); 693 end if; 694 695 -- For now, ignore other types 696 697 else 698 return; 699 end if; 700 701 if not DT then 702 Set_Is_Static_Type (T); 703 end if; 704 end Check_Static_Type; 705 706 ---------------------- 707 -- Note_Uplevel_Ref -- 708 ---------------------- 709 710 procedure Note_Uplevel_Ref 711 (E : Entity_Id; 712 N : Node_Id; 713 Caller : Entity_Id; 714 Callee : Entity_Id) 715 is 716 Full_E : Entity_Id := E; 717 begin 718 -- Nothing to do for static type 719 720 if Is_Static_Type (E) then 721 return; 722 end if; 723 724 -- Nothing to do if Caller and Callee are the same 725 726 if Caller = Callee then 727 return; 728 729 -- Callee may be a function that returns an array, and that has 730 -- been rewritten as a procedure. If caller is that procedure, 731 -- nothing to do either. 732 733 elsif Ekind (Callee) = E_Function 734 and then Rewritten_For_C (Callee) 735 and then Corresponding_Procedure (Callee) = Caller 736 then 737 return; 738 739 elsif Ekind_In (Callee, E_Entry, E_Entry_Family) then 740 return; 741 end if; 742 743 -- We have a new uplevel referenced entity 744 745 if Ekind (E) = E_Constant and then Present (Full_View (E)) then 746 Full_E := Full_View (E); 747 end if; 748 749 -- All we do at this stage is to add the uplevel reference to 750 -- the table. It's too early to do anything else, since this 751 -- uplevel reference may come from an unreachable subprogram 752 -- in which case the entry will be deleted. 753 754 Urefs.Append ((N, Full_E, Caller, Callee)); 755 end Note_Uplevel_Ref; 756 757 ------------------------- 758 -- Register_Subprogram -- 759 ------------------------- 760 761 procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id) is 762 L : constant Nat := Get_Level (Subp, E); 763 764 begin 765 -- Subprograms declared in tasks and protected types cannot be 766 -- eliminated because calls to them may be in other units, so 767 -- they must be treated as reachable. 768 769 Subps.Append 770 ((Ent => E, 771 Bod => Bod, 772 Lev => L, 773 Reachable => In_Synchronized_Unit (E) 774 or else Address_Taken (E), 775 Uplevel_Ref => L, 776 Declares_AREC => False, 777 Uents => No_Elist, 778 Last => 0, 779 ARECnF => Empty, 780 ARECn => Empty, 781 ARECnT => Empty, 782 ARECnPT => Empty, 783 ARECnP => Empty, 784 ARECnU => Empty)); 785 786 Set_Subps_Index (E, UI_From_Int (Subps.Last)); 787 788 -- If we marked this reachable because it's in a synchronized 789 -- unit, we have to mark all enclosing subprograms as reachable 790 -- as well. 791 792 if In_Synchronized_Unit (E) then 793 declare 794 S : Entity_Id := E; 795 796 begin 797 for J in reverse 1 .. L - 1 loop 798 S := Enclosing_Subprogram (S); 799 Subps.Table (Subp_Index (S)).Reachable := True; 800 end loop; 801 end; 802 end if; 803 end Register_Subprogram; 804 805 -- Start of processing for Visit_Node 806 807 begin 808 case Nkind (N) is 809 810 -- Record a subprogram call 811 812 when N_Function_Call 813 | N_Procedure_Call_Statement 814 => 815 -- We are only interested in direct calls, not indirect 816 -- calls (where Name (N) is an explicit dereference) at 817 -- least for now! 818 819 if Nkind (Name (N)) in N_Has_Entity then 820 Ent := Entity (Name (N)); 821 822 -- We are only interested in calls to subprograms nested 823 -- within Subp. Calls to Subp itself or to subprograms 824 -- outside the nested structure do not affect us. 825 826 if Scope_Within (Ent, Subp) 827 and then Is_Subprogram (Ent) 828 and then not Is_Imported (Ent) 829 then 830 Append_Unique_Call ((N, Current_Subprogram, Ent)); 831 end if; 832 end if; 833 834 -- For all calls where the formal is an unconstrained array 835 -- and the actual is constrained we need to check the bounds 836 -- for uplevel references. 837 838 declare 839 Actual : Entity_Id; 840 DT : Boolean := False; 841 Formal : Node_Id; 842 Subp : Entity_Id; 843 844 begin 845 if Nkind (Name (N)) = N_Explicit_Dereference then 846 Subp := Etype (Name (N)); 847 else 848 Subp := Entity (Name (N)); 849 end if; 850 851 Actual := First_Actual (N); 852 Formal := First_Formal_With_Extras (Subp); 853 while Present (Actual) loop 854 if Is_Array_Type (Etype (Formal)) 855 and then not Is_Constrained (Etype (Formal)) 856 and then Is_Constrained (Etype (Actual)) 857 then 858 Check_Static_Type (Etype (Actual), Empty, DT); 859 end if; 860 861 Next_Actual (Actual); 862 Next_Formal_With_Extras (Formal); 863 end loop; 864 end; 865 866 -- An At_End_Proc in a statement sequence indicates that there 867 -- is a call from the enclosing construct or block to that 868 -- subprogram. As above, the called entity must be local and 869 -- not imported. 870 871 when N_Handled_Sequence_Of_Statements => 872 if Present (At_End_Proc (N)) 873 and then Scope_Within (Entity (At_End_Proc (N)), Subp) 874 and then not Is_Imported (Entity (At_End_Proc (N))) 875 then 876 Append_Unique_Call 877 ((N, Current_Subprogram, Entity (At_End_Proc (N)))); 878 end if; 879 880 -- Similarly, the following constructs include a semantic 881 -- attribute Procedure_To_Call that must be handled like 882 -- other calls. Likewise for attribute Storage_Pool. 883 884 when N_Allocator 885 | N_Extended_Return_Statement 886 | N_Free_Statement 887 | N_Simple_Return_Statement 888 => 889 declare 890 Pool : constant Entity_Id := Storage_Pool (N); 891 Proc : constant Entity_Id := Procedure_To_Call (N); 892 893 begin 894 if Present (Proc) 895 and then Scope_Within (Proc, Subp) 896 and then not Is_Imported (Proc) 897 then 898 Append_Unique_Call ((N, Current_Subprogram, Proc)); 899 end if; 900 901 if Present (Pool) 902 and then not Is_Library_Level_Entity (Pool) 903 and then Scope_Within_Or_Same (Scope (Pool), Subp) 904 then 905 Caller := Current_Subprogram; 906 Callee := Enclosing_Subprogram (Pool); 907 908 if Callee /= Caller then 909 Note_Uplevel_Ref (Pool, Empty, Caller, Callee); 910 end if; 911 end if; 912 end; 913 914 -- For an allocator with a qualified expression, check type 915 -- of expression being qualified. The explicit type name is 916 -- handled as an entity reference. 917 918 if Nkind (N) = N_Allocator 919 and then Nkind (Expression (N)) = N_Qualified_Expression 920 then 921 declare 922 DT : Boolean := False; 923 begin 924 Check_Static_Type 925 (Etype (Expression (Expression (N))), Empty, DT); 926 end; 927 928 -- For a Return or Free (all other nodes we handle here), 929 -- we usually need the size of the object, so we need to be 930 -- sure that any nonstatic bounds of the expression's type 931 -- that are uplevel are handled. 932 933 elsif Nkind (N) /= N_Allocator 934 and then Present (Expression (N)) 935 then 936 declare 937 DT : Boolean := False; 938 begin 939 Check_Static_Type (Etype (Expression (N)), Empty, DT); 940 end; 941 end if; 942 943 -- A 'Access reference is a (potential) call. So is 'Address, 944 -- in particular on imported subprograms. Other attributes 945 -- require special handling. 946 947 when N_Attribute_Reference => 948 declare 949 Attr : constant Attribute_Id := 950 Get_Attribute_Id (Attribute_Name (N)); 951 begin 952 case Attr is 953 when Attribute_Access 954 | Attribute_Unchecked_Access 955 | Attribute_Unrestricted_Access 956 | Attribute_Address 957 => 958 if Nkind (Prefix (N)) in N_Has_Entity then 959 Ent := Entity (Prefix (N)); 960 961 -- We only need to examine calls to subprograms 962 -- nested within current Subp. 963 964 if Scope_Within (Ent, Subp) then 965 if Is_Imported (Ent) then 966 null; 967 968 elsif Is_Subprogram (Ent) then 969 Append_Unique_Call 970 ((N, Current_Subprogram, Ent)); 971 end if; 972 end if; 973 end if; 974 975 -- References to bounds can be uplevel references if 976 -- the type isn't static. 977 978 when Attribute_First 979 | Attribute_Last 980 | Attribute_Length 981 => 982 -- Special-case attributes of objects whose bounds 983 -- may be uplevel references. More complex prefixes 984 -- handled during full traversal. Note that if the 985 -- nominal subtype of the prefix is unconstrained, 986 -- the bound must be obtained from the object, not 987 -- from the (possibly) uplevel reference. 988 989 if Is_Constrained (Etype (Prefix (N))) then 990 declare 991 DT : Boolean := False; 992 begin 993 Check_Static_Type 994 (Etype (Prefix (N)), Empty, DT); 995 end; 996 997 return OK; 998 end if; 999 1000 when others => 1001 null; 1002 end case; 1003 end; 1004 1005 -- Component associations in aggregates are either static or 1006 -- else the aggregate will be expanded into assignments, in 1007 -- which case the expression is analyzed later and provides 1008 -- no relevant code generation. 1009 1010 when N_Component_Association => 1011 if No (Expression (N)) 1012 or else No (Etype (Expression (N))) 1013 then 1014 return Skip; 1015 end if; 1016 1017 -- Generic associations are not analyzed: the actuals are 1018 -- transferred to renaming and subtype declarations that 1019 -- are the ones that must be examined. 1020 1021 when N_Generic_Association => 1022 return Skip; 1023 1024 -- Indexed references can be uplevel if the type isn't static 1025 -- and if the lower bound (or an inner bound for a multi- 1026 -- dimensional array) is uplevel. 1027 1028 when N_Indexed_Component 1029 | N_Slice 1030 => 1031 if Is_Constrained (Etype (Prefix (N))) then 1032 declare 1033 DT : Boolean := False; 1034 begin 1035 Check_Static_Type (Etype (Prefix (N)), Empty, DT); 1036 end; 1037 end if; 1038 1039 -- A selected component can have an implicit up-level 1040 -- reference due to the bounds of previous fields in the 1041 -- record. We simplify the processing here by examining 1042 -- all components of the record. 1043 1044 -- Selected components appear as unit names and end labels 1045 -- for child units. Prefixes of these nodes denote parent 1046 -- units and carry no type information so they are skipped. 1047 1048 when N_Selected_Component => 1049 if Present (Etype (Prefix (N))) then 1050 declare 1051 DT : Boolean := False; 1052 begin 1053 Check_Static_Type (Etype (Prefix (N)), Empty, DT); 1054 end; 1055 end if; 1056 1057 -- For EQ/NE comparisons, we need the type of the operands 1058 -- in order to do the comparison, which means we need the 1059 -- bounds. 1060 1061 when N_Op_Eq 1062 | N_Op_Ne 1063 => 1064 declare 1065 DT : Boolean := False; 1066 begin 1067 Check_Static_Type (Etype (Left_Opnd (N)), Empty, DT); 1068 Check_Static_Type (Etype (Right_Opnd (N)), Empty, DT); 1069 end; 1070 1071 -- Likewise we need the sizes to compute how much to move in 1072 -- an assignment. 1073 1074 when N_Assignment_Statement => 1075 declare 1076 DT : Boolean := False; 1077 begin 1078 Check_Static_Type (Etype (Name (N)), Empty, DT); 1079 Check_Static_Type (Etype (Expression (N)), Empty, DT); 1080 end; 1081 1082 -- Record a subprogram. We record a subprogram body that acts 1083 -- as a spec. Otherwise we record a subprogram declaration, 1084 -- providing that it has a corresponding body we can get hold 1085 -- of. The case of no corresponding body being available is 1086 -- ignored for now. 1087 1088 when N_Subprogram_Body => 1089 Ent := Unique_Defining_Entity (N); 1090 1091 -- Ignore generic subprogram 1092 1093 if Is_Generic_Subprogram (Ent) then 1094 return Skip; 1095 end if; 1096 1097 -- Make new entry in subprogram table if not already made 1098 1099 Register_Subprogram (Ent, N); 1100 1101 -- We make a recursive call to scan the subprogram body, so 1102 -- that we can save and restore Current_Subprogram. 1103 1104 declare 1105 Save_CS : constant Entity_Id := Current_Subprogram; 1106 Decl : Node_Id; 1107 1108 begin 1109 Current_Subprogram := Ent; 1110 1111 -- Scan declarations 1112 1113 Decl := First (Declarations (N)); 1114 while Present (Decl) loop 1115 Visit (Decl); 1116 Next (Decl); 1117 end loop; 1118 1119 -- Scan statements 1120 1121 Visit (Handled_Statement_Sequence (N)); 1122 1123 -- Restore current subprogram setting 1124 1125 Current_Subprogram := Save_CS; 1126 end; 1127 1128 -- Now at this level, return skipping the subprogram body 1129 -- descendants, since we already took care of them! 1130 1131 return Skip; 1132 1133 -- If we have a body stub, visit the associated subunit, which 1134 -- is a semantic descendant of the stub. 1135 1136 when N_Body_Stub => 1137 Visit (Library_Unit (N)); 1138 1139 -- A declaration of a wrapper package indicates a subprogram 1140 -- instance for which there is no explicit body. Enter the 1141 -- subprogram instance in the table. 1142 1143 when N_Package_Declaration => 1144 if Is_Wrapper_Package (Defining_Entity (N)) then 1145 Register_Subprogram 1146 (Related_Instance (Defining_Entity (N)), Empty); 1147 end if; 1148 1149 -- Skip generic declarations 1150 1151 when N_Generic_Declaration => 1152 return Skip; 1153 1154 -- Skip generic package body 1155 1156 when N_Package_Body => 1157 if Present (Corresponding_Spec (N)) 1158 and then Ekind (Corresponding_Spec (N)) = E_Generic_Package 1159 then 1160 return Skip; 1161 end if; 1162 1163 -- Pragmas and component declarations are ignored. Quantified 1164 -- expressions are expanded into explicit loops and the 1165 -- original epression must be ignored. 1166 1167 when N_Component_Declaration 1168 | N_Pragma 1169 | N_Quantified_Expression 1170 => 1171 return Skip; 1172 1173 -- We want to skip the function spec for a generic function 1174 -- to avoid looking at any generic types that might be in 1175 -- its formals. 1176 1177 when N_Function_Specification => 1178 if Is_Generic_Subprogram (Unique_Defining_Entity (N)) then 1179 return Skip; 1180 end if; 1181 1182 -- Otherwise record an uplevel reference in a local identifier 1183 1184 when others => 1185 if Nkind (N) in N_Has_Entity 1186 and then Present (Entity (N)) 1187 then 1188 Ent := Entity (N); 1189 1190 -- Only interested in entities declared within our nest 1191 1192 if not Is_Library_Level_Entity (Ent) 1193 and then Scope_Within_Or_Same (Scope (Ent), Subp) 1194 1195 -- Skip entities defined in inlined subprograms 1196 1197 and then 1198 Chars (Enclosing_Subprogram (Ent)) /= Name_uParent 1199 1200 -- Constants and variables are potentially uplevel 1201 -- references to global declarations. 1202 1203 and then 1204 (Ekind_In (Ent, E_Constant, 1205 E_Loop_Parameter, 1206 E_Variable) 1207 1208 -- Formals are interesting, but not if being used 1209 -- as mere names of parameters for name notation 1210 -- calls. 1211 1212 or else 1213 (Is_Formal (Ent) 1214 and then not 1215 (Nkind (Parent (N)) = N_Parameter_Association 1216 and then Selector_Name (Parent (N)) = N)) 1217 1218 -- Types other than known Is_Static types are 1219 -- potentially interesting. 1220 1221 or else 1222 (Is_Type (Ent) and then not Is_Static_Type (Ent))) 1223 then 1224 -- Here we have a potentially interesting uplevel 1225 -- reference to examine. 1226 1227 if Is_Type (Ent) then 1228 declare 1229 DT : Boolean := False; 1230 1231 begin 1232 Check_Static_Type (Ent, N, DT); 1233 return OK; 1234 end; 1235 end if; 1236 1237 Caller := Current_Subprogram; 1238 Callee := Enclosing_Subprogram (Ent); 1239 1240 if Callee /= Caller 1241 and then (not Is_Static_Type (Ent) 1242 or else Needs_Fat_Pointer (Ent)) 1243 then 1244 Note_Uplevel_Ref (Ent, N, Caller, Callee); 1245 1246 -- Check the type of a formal parameter of the current 1247 -- subprogram, whose formal type may be an uplevel 1248 -- reference. 1249 1250 elsif Is_Formal (Ent) 1251 and then Scope (Ent) = Current_Subprogram 1252 then 1253 declare 1254 DT : Boolean := False; 1255 1256 begin 1257 Check_Static_Type (Etype (Ent), Empty, DT); 1258 end; 1259 end if; 1260 end if; 1261 end if; 1262 end case; 1263 1264 -- Fall through to continue scanning children of this node 1265 1266 return OK; 1267 end Visit_Node; 1268 1269 -- Start of processing for Build_Tables 1270 1271 begin 1272 -- Traverse the body to get subprograms, calls and uplevel references 1273 1274 Visit (Subp_Body); 1275 end Build_Tables; 1276 1277 -- Now do the first transitive closure which determines which 1278 -- subprograms in the nest are actually reachable. 1279 1280 Reachable_Closure : declare 1281 Modified : Boolean; 1282 1283 begin 1284 Subps.Table (Subps_First).Reachable := True; 1285 1286 -- We use a simple minded algorithm as follows (obviously this can 1287 -- be done more efficiently, using one of the standard algorithms 1288 -- for efficient transitive closure computation, but this is simple 1289 -- and most likely fast enough that its speed does not matter). 1290 1291 -- Repeatedly scan the list of calls. Any time we find a call from 1292 -- A to B, where A is reachable, but B is not, then B is reachable, 1293 -- and note that we have made a change by setting Modified True. We 1294 -- repeat this until we make a pass with no modifications. 1295 1296 Outer : loop 1297 Modified := False; 1298 Inner : for J in Calls.First .. Calls.Last loop 1299 declare 1300 CTJ : Call_Entry renames Calls.Table (J); 1301 1302 SINF : constant SI_Type := Subp_Index (CTJ.Caller); 1303 SINT : constant SI_Type := Subp_Index (CTJ.Callee); 1304 1305 SUBF : Subp_Entry renames Subps.Table (SINF); 1306 SUBT : Subp_Entry renames Subps.Table (SINT); 1307 1308 begin 1309 if SUBF.Reachable and then not SUBT.Reachable then 1310 SUBT.Reachable := True; 1311 Modified := True; 1312 end if; 1313 end; 1314 end loop Inner; 1315 1316 exit Outer when not Modified; 1317 end loop Outer; 1318 end Reachable_Closure; 1319 1320 -- Remove calls from unreachable subprograms 1321 1322 declare 1323 New_Index : Nat; 1324 1325 begin 1326 New_Index := 0; 1327 for J in Calls.First .. Calls.Last loop 1328 declare 1329 CTJ : Call_Entry renames Calls.Table (J); 1330 1331 SINF : constant SI_Type := Subp_Index (CTJ.Caller); 1332 SINT : constant SI_Type := Subp_Index (CTJ.Callee); 1333 1334 SUBF : Subp_Entry renames Subps.Table (SINF); 1335 SUBT : Subp_Entry renames Subps.Table (SINT); 1336 1337 begin 1338 if SUBF.Reachable then 1339 pragma Assert (SUBT.Reachable); 1340 New_Index := New_Index + 1; 1341 Calls.Table (New_Index) := Calls.Table (J); 1342 end if; 1343 end; 1344 end loop; 1345 1346 Calls.Set_Last (New_Index); 1347 end; 1348 1349 -- Remove uplevel references from unreachable subprograms 1350 1351 declare 1352 New_Index : Nat; 1353 1354 begin 1355 New_Index := 0; 1356 for J in Urefs.First .. Urefs.Last loop 1357 declare 1358 URJ : Uref_Entry renames Urefs.Table (J); 1359 1360 SINF : constant SI_Type := Subp_Index (URJ.Caller); 1361 SINT : constant SI_Type := Subp_Index (URJ.Callee); 1362 1363 SUBF : Subp_Entry renames Subps.Table (SINF); 1364 SUBT : Subp_Entry renames Subps.Table (SINT); 1365 1366 S : Entity_Id; 1367 1368 begin 1369 -- Keep reachable reference 1370 1371 if SUBF.Reachable then 1372 New_Index := New_Index + 1; 1373 Urefs.Table (New_Index) := Urefs.Table (J); 1374 1375 -- And since we know we are keeping this one, this is a good 1376 -- place to fill in information for a good reference. 1377 1378 -- Mark all enclosing subprograms need to declare AREC 1379 1380 S := URJ.Caller; 1381 loop 1382 S := Enclosing_Subprogram (S); 1383 1384 -- If we are at the top level, as can happen with 1385 -- references to formals in aspects of nested subprogram 1386 -- declarations, there are no further subprograms to mark 1387 -- as requiring activation records. 1388 1389 exit when No (S); 1390 1391 declare 1392 SUBI : Subp_Entry renames Subps.Table (Subp_Index (S)); 1393 begin 1394 SUBI.Declares_AREC := True; 1395 1396 -- If this entity was marked reachable because it is 1397 -- in a task or protected type, there may not appear 1398 -- to be any calls to it, which would normally adjust 1399 -- the levels of the parent subprograms. So we need to 1400 -- be sure that the uplevel reference of that entity 1401 -- takes into account possible calls. 1402 1403 if In_Synchronized_Unit (SUBF.Ent) 1404 and then SUBT.Lev < SUBI.Uplevel_Ref 1405 then 1406 SUBI.Uplevel_Ref := SUBT.Lev; 1407 end if; 1408 end; 1409 1410 exit when S = URJ.Callee; 1411 end loop; 1412 1413 -- Add to list of uplevel referenced entities for Callee. 1414 -- We do not add types to this list, only actual references 1415 -- to objects that will be referenced uplevel, and we use 1416 -- the flag Is_Uplevel_Referenced_Entity to avoid making 1417 -- duplicate entries in the list. Discriminants are also 1418 -- excluded, only the enclosing object can appear in the 1419 -- list. 1420 1421 if not Is_Uplevel_Referenced_Entity (URJ.Ent) 1422 and then Ekind (URJ.Ent) /= E_Discriminant 1423 then 1424 Set_Is_Uplevel_Referenced_Entity (URJ.Ent); 1425 Append_New_Elmt (URJ.Ent, SUBT.Uents); 1426 end if; 1427 1428 -- And set uplevel indication for caller 1429 1430 if SUBT.Lev < SUBF.Uplevel_Ref then 1431 SUBF.Uplevel_Ref := SUBT.Lev; 1432 end if; 1433 end if; 1434 end; 1435 end loop; 1436 1437 Urefs.Set_Last (New_Index); 1438 end; 1439 1440 -- Remove unreachable subprograms from Subps table. Note that we do 1441 -- this after eliminating entries from the other two tables, since 1442 -- those elimination steps depend on referencing the Subps table. 1443 1444 declare 1445 New_SI : SI_Type; 1446 1447 begin 1448 New_SI := Subps_First - 1; 1449 for J in Subps_First .. Subps.Last loop 1450 declare 1451 STJ : Subp_Entry renames Subps.Table (J); 1452 Spec : Node_Id; 1453 Decl : Node_Id; 1454 1455 begin 1456 -- Subprogram is reachable, copy and reset index 1457 1458 if STJ.Reachable then 1459 New_SI := New_SI + 1; 1460 Subps.Table (New_SI) := STJ; 1461 Set_Subps_Index (STJ.Ent, UI_From_Int (New_SI)); 1462 1463 -- Subprogram is not reachable 1464 1465 else 1466 -- Clear index, since no longer active 1467 1468 Set_Subps_Index (Subps.Table (J).Ent, Uint_0); 1469 1470 -- Output debug information if -gnatd.3 set 1471 1472 if Debug_Flag_Dot_3 then 1473 Write_Str ("Eliminate "); 1474 Write_Name (Chars (Subps.Table (J).Ent)); 1475 Write_Str (" at "); 1476 Write_Location (Sloc (Subps.Table (J).Ent)); 1477 Write_Str (" (not referenced)"); 1478 Write_Eol; 1479 end if; 1480 1481 -- Rewrite declaration, body, and corresponding freeze node 1482 -- to null statements. 1483 1484 -- A subprogram instantiation does not have an explicit 1485 -- body. If unused, we could remove the corresponding 1486 -- wrapper package and its body (TBD). 1487 1488 if Present (STJ.Bod) then 1489 Spec := Corresponding_Spec (STJ.Bod); 1490 1491 if Present (Spec) then 1492 Decl := Parent (Declaration_Node (Spec)); 1493 Rewrite (Decl, Make_Null_Statement (Sloc (Decl))); 1494 1495 if Present (Freeze_Node (Spec)) then 1496 Rewrite (Freeze_Node (Spec), 1497 Make_Null_Statement (Sloc (Decl))); 1498 end if; 1499 end if; 1500 1501 Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod))); 1502 end if; 1503 end if; 1504 end; 1505 end loop; 1506 1507 Subps.Set_Last (New_SI); 1508 end; 1509 1510 -- Now it is time for the second transitive closure, which follows calls 1511 -- and makes sure that A calls B, and B has uplevel references, then A 1512 -- is also marked as having uplevel references. 1513 1514 Closure_Uplevel : declare 1515 Modified : Boolean; 1516 1517 begin 1518 -- We use a simple minded algorithm as follows (obviously this can 1519 -- be done more efficiently, using one of the standard algorithms 1520 -- for efficient transitive closure computation, but this is simple 1521 -- and most likely fast enough that its speed does not matter). 1522 1523 -- Repeatedly scan the list of calls. Any time we find a call from 1524 -- A to B, where B has uplevel references, make sure that A is marked 1525 -- as having at least the same level of uplevel referencing. 1526 1527 Outer2 : loop 1528 Modified := False; 1529 Inner2 : for J in Calls.First .. Calls.Last loop 1530 declare 1531 CTJ : Call_Entry renames Calls.Table (J); 1532 SINF : constant SI_Type := Subp_Index (CTJ.Caller); 1533 SINT : constant SI_Type := Subp_Index (CTJ.Callee); 1534 SUBF : Subp_Entry renames Subps.Table (SINF); 1535 SUBT : Subp_Entry renames Subps.Table (SINT); 1536 begin 1537 if SUBT.Lev > SUBT.Uplevel_Ref 1538 and then SUBF.Uplevel_Ref > SUBT.Uplevel_Ref 1539 then 1540 SUBF.Uplevel_Ref := SUBT.Uplevel_Ref; 1541 Modified := True; 1542 end if; 1543 end; 1544 end loop Inner2; 1545 1546 exit Outer2 when not Modified; 1547 end loop Outer2; 1548 end Closure_Uplevel; 1549 1550 -- We have one more step before the tables are complete. An uplevel 1551 -- call from subprogram A to subprogram B where subprogram B has uplevel 1552 -- references is in effect an uplevel reference, and must arrange for 1553 -- the proper activation link to be passed. 1554 1555 for J in Calls.First .. Calls.Last loop 1556 declare 1557 CTJ : Call_Entry renames Calls.Table (J); 1558 1559 SINF : constant SI_Type := Subp_Index (CTJ.Caller); 1560 SINT : constant SI_Type := Subp_Index (CTJ.Callee); 1561 1562 SUBF : Subp_Entry renames Subps.Table (SINF); 1563 SUBT : Subp_Entry renames Subps.Table (SINT); 1564 1565 A : Entity_Id; 1566 1567 begin 1568 -- If callee has uplevel references 1569 1570 if SUBT.Uplevel_Ref < SUBT.Lev 1571 1572 -- And this is an uplevel call 1573 1574 and then SUBT.Lev < SUBF.Lev 1575 then 1576 -- We need to arrange for finding the uplink 1577 1578 A := CTJ.Caller; 1579 loop 1580 A := Enclosing_Subprogram (A); 1581 Subps.Table (Subp_Index (A)).Declares_AREC := True; 1582 exit when A = CTJ.Callee; 1583 1584 -- In any case exit when we get to the outer level. This 1585 -- happens in some odd cases with generics (in particular 1586 -- sem_ch3.adb does not compile without this kludge ???). 1587 1588 exit when A = Subp; 1589 end loop; 1590 end if; 1591 end; 1592 end loop; 1593 1594 -- The tables are now complete, so we can record the last index in the 1595 -- Subps table for later reference in Cprint. 1596 1597 Subps.Table (Subps_First).Last := Subps.Last; 1598 1599 -- Next step, create the entities for code we will insert. We do this 1600 -- at the start so that all the entities are defined, regardless of the 1601 -- order in which we do the code insertions. 1602 1603 Create_Entities : for J in Subps_First .. Subps.Last loop 1604 declare 1605 STJ : Subp_Entry renames Subps.Table (J); 1606 Loc : constant Source_Ptr := Sloc (STJ.Bod); 1607 1608 begin 1609 -- First we create the ARECnF entity for the additional formal for 1610 -- all subprograms which need an activation record passed. 1611 1612 if STJ.Uplevel_Ref < STJ.Lev then 1613 STJ.ARECnF := 1614 Make_Defining_Identifier (Loc, Chars => AREC_Name (J, "F")); 1615 end if; 1616 1617 -- Define the AREC entities for the activation record if needed 1618 1619 if STJ.Declares_AREC then 1620 STJ.ARECn := 1621 Make_Defining_Identifier (Loc, AREC_Name (J, "")); 1622 STJ.ARECnT := 1623 Make_Defining_Identifier (Loc, AREC_Name (J, "T")); 1624 STJ.ARECnPT := 1625 Make_Defining_Identifier (Loc, AREC_Name (J, "PT")); 1626 STJ.ARECnP := 1627 Make_Defining_Identifier (Loc, AREC_Name (J, "P")); 1628 1629 -- Define uplink component entity if inner nesting case 1630 1631 if Present (STJ.ARECnF) then 1632 STJ.ARECnU := 1633 Make_Defining_Identifier (Loc, AREC_Name (J, "U")); 1634 end if; 1635 end if; 1636 end; 1637 end loop Create_Entities; 1638 1639 -- Loop through subprograms 1640 1641 Subp_Loop : declare 1642 Addr : Entity_Id := Empty; 1643 1644 begin 1645 for J in Subps_First .. Subps.Last loop 1646 declare 1647 STJ : Subp_Entry renames Subps.Table (J); 1648 1649 begin 1650 -- First add the extra formal if needed. This applies to all 1651 -- nested subprograms that require an activation record to be 1652 -- passed, as indicated by ARECnF being defined. 1653 1654 if Present (STJ.ARECnF) then 1655 1656 -- Here we need the extra formal. We do the expansion and 1657 -- analysis of this manually, since it is fairly simple, 1658 -- and it is not obvious how we can get what we want if we 1659 -- try to use the normal Analyze circuit. 1660 1661 Add_Extra_Formal : declare 1662 Encl : constant SI_Type := Enclosing_Subp (J); 1663 STJE : Subp_Entry renames Subps.Table (Encl); 1664 -- Index and Subp_Entry for enclosing routine 1665 1666 Form : constant Entity_Id := STJ.ARECnF; 1667 -- The formal to be added. Note that n here is one less 1668 -- than the level of the subprogram itself (STJ.Ent). 1669 1670 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id); 1671 -- S is an N_Function/Procedure_Specification node, and F 1672 -- is the new entity to add to this subprogramn spec as 1673 -- the last Extra_Formal. 1674 1675 ---------------------- 1676 -- Add_Form_To_Spec -- 1677 ---------------------- 1678 1679 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is 1680 Sub : constant Entity_Id := Defining_Entity (S); 1681 Ent : Entity_Id; 1682 1683 begin 1684 -- Case of at least one Extra_Formal is present, set 1685 -- ARECnF as the new last entry in the list. 1686 1687 if Present (Extra_Formals (Sub)) then 1688 Ent := Extra_Formals (Sub); 1689 while Present (Extra_Formal (Ent)) loop 1690 Ent := Extra_Formal (Ent); 1691 end loop; 1692 1693 Set_Extra_Formal (Ent, F); 1694 1695 -- No Extra formals present 1696 1697 else 1698 Set_Extra_Formals (Sub, F); 1699 Ent := Last_Formal (Sub); 1700 1701 if Present (Ent) then 1702 Set_Extra_Formal (Ent, F); 1703 end if; 1704 end if; 1705 end Add_Form_To_Spec; 1706 1707 -- Start of processing for Add_Extra_Formal 1708 1709 begin 1710 -- Decorate the new formal entity 1711 1712 Set_Scope (Form, STJ.Ent); 1713 Set_Ekind (Form, E_In_Parameter); 1714 Set_Etype (Form, STJE.ARECnPT); 1715 Set_Mechanism (Form, By_Copy); 1716 Set_Never_Set_In_Source (Form, True); 1717 Set_Analyzed (Form, True); 1718 Set_Comes_From_Source (Form, False); 1719 Set_Is_Activation_Record (Form, True); 1720 1721 -- Case of only body present 1722 1723 if Acts_As_Spec (STJ.Bod) then 1724 Add_Form_To_Spec (Form, Specification (STJ.Bod)); 1725 1726 -- Case of separate spec 1727 1728 else 1729 Add_Form_To_Spec (Form, Parent (STJ.Ent)); 1730 end if; 1731 end Add_Extra_Formal; 1732 end if; 1733 1734 -- Processing for subprograms that declare an activation record 1735 1736 if Present (STJ.ARECn) then 1737 1738 -- Local declarations for one such subprogram 1739 1740 declare 1741 Loc : constant Source_Ptr := Sloc (STJ.Bod); 1742 1743 Decls : constant List_Id := New_List; 1744 -- List of new declarations we create 1745 1746 Clist : List_Id; 1747 Comp : Entity_Id; 1748 1749 Decl_Assign : Node_Id; 1750 -- Assigment to set uplink, Empty if none 1751 1752 Decl_ARECnT : Node_Id; 1753 Decl_ARECnPT : Node_Id; 1754 Decl_ARECn : Node_Id; 1755 Decl_ARECnP : Node_Id; 1756 -- Declaration nodes for the AREC entities we build 1757 1758 begin 1759 -- Build list of component declarations for ARECnT and 1760 -- load System.Address. 1761 1762 Clist := Empty_List; 1763 1764 if No (Addr) then 1765 Addr := RTE (RE_Address); 1766 end if; 1767 1768 -- If we are in a subprogram that has a static link that 1769 -- is passed in (as indicated by ARECnF being defined), 1770 -- then include ARECnU : ARECmPT where ARECmPT comes from 1771 -- the level one higher than the current level, and the 1772 -- entity ARECnPT comes from the enclosing subprogram. 1773 1774 if Present (STJ.ARECnF) then 1775 declare 1776 STJE : Subp_Entry 1777 renames Subps.Table (Enclosing_Subp (J)); 1778 begin 1779 Append_To (Clist, 1780 Make_Component_Declaration (Loc, 1781 Defining_Identifier => STJ.ARECnU, 1782 Component_Definition => 1783 Make_Component_Definition (Loc, 1784 Subtype_Indication => 1785 New_Occurrence_Of (STJE.ARECnPT, Loc)))); 1786 end; 1787 end if; 1788 1789 -- Add components for uplevel referenced entities 1790 1791 if Present (STJ.Uents) then 1792 declare 1793 Elmt : Elmt_Id; 1794 Ptr_Decl : Node_Id; 1795 Uent : Entity_Id; 1796 1797 Indx : Nat; 1798 -- 1's origin of index in list of elements. This is 1799 -- used to uniquify names if needed in Upref_Name. 1800 1801 begin 1802 Elmt := First_Elmt (STJ.Uents); 1803 Indx := 0; 1804 while Present (Elmt) loop 1805 Uent := Node (Elmt); 1806 Indx := Indx + 1; 1807 1808 Comp := 1809 Make_Defining_Identifier (Loc, 1810 Chars => Upref_Name (Uent, Indx, Clist)); 1811 1812 Set_Activation_Record_Component 1813 (Uent, Comp); 1814 1815 if Needs_Fat_Pointer (Uent) then 1816 1817 -- Build corresponding access type 1818 1819 Ptr_Decl := 1820 Build_Access_Type_Decl 1821 (Etype (Uent), STJ.Ent); 1822 Append_To (Decls, Ptr_Decl); 1823 1824 -- And use its type in the corresponding 1825 -- component. 1826 1827 Append_To (Clist, 1828 Make_Component_Declaration (Loc, 1829 Defining_Identifier => Comp, 1830 Component_Definition => 1831 Make_Component_Definition (Loc, 1832 Subtype_Indication => 1833 New_Occurrence_Of 1834 (Defining_Identifier (Ptr_Decl), 1835 Loc)))); 1836 else 1837 Append_To (Clist, 1838 Make_Component_Declaration (Loc, 1839 Defining_Identifier => Comp, 1840 Component_Definition => 1841 Make_Component_Definition (Loc, 1842 Subtype_Indication => 1843 New_Occurrence_Of (Addr, Loc)))); 1844 end if; 1845 Next_Elmt (Elmt); 1846 end loop; 1847 end; 1848 end if; 1849 1850 -- Now we can insert the AREC declarations into the body 1851 -- type ARECnT is record .. end record; 1852 -- pragma Suppress_Initialization (ARECnT); 1853 1854 -- Note that we need to set the Suppress_Initialization 1855 -- flag after Decl_ARECnT has been analyzed. 1856 1857 Decl_ARECnT := 1858 Make_Full_Type_Declaration (Loc, 1859 Defining_Identifier => STJ.ARECnT, 1860 Type_Definition => 1861 Make_Record_Definition (Loc, 1862 Component_List => 1863 Make_Component_List (Loc, 1864 Component_Items => Clist))); 1865 Append_To (Decls, Decl_ARECnT); 1866 1867 -- type ARECnPT is access all ARECnT; 1868 1869 Decl_ARECnPT := 1870 Make_Full_Type_Declaration (Loc, 1871 Defining_Identifier => STJ.ARECnPT, 1872 Type_Definition => 1873 Make_Access_To_Object_Definition (Loc, 1874 All_Present => True, 1875 Subtype_Indication => 1876 New_Occurrence_Of (STJ.ARECnT, Loc))); 1877 Append_To (Decls, Decl_ARECnPT); 1878 1879 -- ARECn : aliased ARECnT; 1880 1881 Decl_ARECn := 1882 Make_Object_Declaration (Loc, 1883 Defining_Identifier => STJ.ARECn, 1884 Aliased_Present => True, 1885 Object_Definition => 1886 New_Occurrence_Of (STJ.ARECnT, Loc)); 1887 Append_To (Decls, Decl_ARECn); 1888 1889 -- ARECnP : constant ARECnPT := ARECn'Access; 1890 1891 Decl_ARECnP := 1892 Make_Object_Declaration (Loc, 1893 Defining_Identifier => STJ.ARECnP, 1894 Constant_Present => True, 1895 Object_Definition => 1896 New_Occurrence_Of (STJ.ARECnPT, Loc), 1897 Expression => 1898 Make_Attribute_Reference (Loc, 1899 Prefix => 1900 New_Occurrence_Of (STJ.ARECn, Loc), 1901 Attribute_Name => Name_Access)); 1902 Append_To (Decls, Decl_ARECnP); 1903 1904 -- If we are in a subprogram that has a static link that 1905 -- is passed in (as indicated by ARECnF being defined), 1906 -- then generate ARECn.ARECmU := ARECmF where m is 1907 -- one less than the current level to set the uplink. 1908 1909 if Present (STJ.ARECnF) then 1910 Decl_Assign := 1911 Make_Assignment_Statement (Loc, 1912 Name => 1913 Make_Selected_Component (Loc, 1914 Prefix => 1915 New_Occurrence_Of (STJ.ARECn, Loc), 1916 Selector_Name => 1917 New_Occurrence_Of (STJ.ARECnU, Loc)), 1918 Expression => 1919 New_Occurrence_Of (STJ.ARECnF, Loc)); 1920 Append_To (Decls, Decl_Assign); 1921 1922 else 1923 Decl_Assign := Empty; 1924 end if; 1925 1926 if No (Declarations (STJ.Bod)) then 1927 Set_Declarations (STJ.Bod, Decls); 1928 else 1929 Prepend_List_To (Declarations (STJ.Bod), Decls); 1930 end if; 1931 1932 -- Analyze the newly inserted declarations. Note that we 1933 -- do not need to establish the whole scope stack, since 1934 -- we have already set all entity fields (so there will 1935 -- be no searching of upper scopes to resolve names). But 1936 -- we do set the scope of the current subprogram, so that 1937 -- newly created entities go in the right entity chain. 1938 1939 -- We analyze with all checks suppressed (since we do 1940 -- not expect any exceptions). 1941 1942 Push_Scope (STJ.Ent); 1943 Analyze (Decl_ARECnT, Suppress => All_Checks); 1944 1945 -- Note that we need to call Set_Suppress_Initialization 1946 -- after Decl_ARECnT has been analyzed, but before 1947 -- analyzing Decl_ARECnP so that the flag is properly 1948 -- taking into account. 1949 1950 Set_Suppress_Initialization (STJ.ARECnT); 1951 1952 Analyze (Decl_ARECnPT, Suppress => All_Checks); 1953 Analyze (Decl_ARECn, Suppress => All_Checks); 1954 Analyze (Decl_ARECnP, Suppress => All_Checks); 1955 1956 if Present (Decl_Assign) then 1957 Analyze (Decl_Assign, Suppress => All_Checks); 1958 end if; 1959 1960 Pop_Scope; 1961 1962 -- Next step, for each uplevel referenced entity, add 1963 -- assignment operations to set the component in the 1964 -- activation record. 1965 1966 if Present (STJ.Uents) then 1967 declare 1968 Elmt : Elmt_Id; 1969 1970 begin 1971 Elmt := First_Elmt (STJ.Uents); 1972 while Present (Elmt) loop 1973 declare 1974 Ent : constant Entity_Id := Node (Elmt); 1975 Loc : constant Source_Ptr := Sloc (Ent); 1976 Dec : constant Node_Id := 1977 Declaration_Node (Ent); 1978 1979 Asn : Node_Id; 1980 Attr : Name_Id; 1981 Comp : Entity_Id; 1982 Ins : Node_Id; 1983 Rhs : Node_Id; 1984 1985 begin 1986 -- For parameters, we insert the assignment 1987 -- right after the declaration of ARECnP. 1988 -- For all other entities, we insert the 1989 -- assignment immediately after the 1990 -- declaration of the entity or after the 1991 -- freeze node if present. 1992 1993 -- Note: we don't need to mark the entity 1994 -- as being aliased, because the address 1995 -- attribute will mark it as Address_Taken, 1996 -- and that is good enough. 1997 1998 if Is_Formal (Ent) then 1999 Ins := Decl_ARECnP; 2000 2001 elsif Has_Delayed_Freeze (Ent) then 2002 Ins := Freeze_Node (Ent); 2003 2004 else 2005 Ins := Dec; 2006 end if; 2007 2008 -- Build and insert the assignment: 2009 -- ARECn.nam := nam'Address 2010 -- or else 'Access for unconstrained array 2011 2012 if Needs_Fat_Pointer (Ent) then 2013 Attr := Name_Access; 2014 else 2015 Attr := Name_Address; 2016 end if; 2017 2018 Rhs := 2019 Make_Attribute_Reference (Loc, 2020 Prefix => 2021 New_Occurrence_Of (Ent, Loc), 2022 Attribute_Name => Attr); 2023 2024 -- If the entity is an unconstrained formal 2025 -- we wrap the attribute reference in an 2026 -- unchecked conversion to the type of the 2027 -- activation record component, to prevent 2028 -- spurious subtype conformance errors within 2029 -- instances. 2030 2031 if Is_Formal (Ent) 2032 and then not Is_Constrained (Etype (Ent)) 2033 then 2034 -- Find target component and its type 2035 2036 Comp := First_Component (STJ.ARECnT); 2037 while Chars (Comp) /= Chars (Ent) loop 2038 Comp := Next_Component (Comp); 2039 end loop; 2040 2041 Rhs := 2042 Unchecked_Convert_To (Etype (Comp), Rhs); 2043 end if; 2044 2045 Asn := 2046 Make_Assignment_Statement (Loc, 2047 Name => 2048 Make_Selected_Component (Loc, 2049 Prefix => 2050 New_Occurrence_Of (STJ.ARECn, Loc), 2051 Selector_Name => 2052 New_Occurrence_Of 2053 (Activation_Record_Component 2054 (Ent), 2055 Loc)), 2056 Expression => Rhs); 2057 2058 -- If we have a loop parameter, we have 2059 -- to insert before the first statement 2060 -- of the loop. Ins points to the 2061 -- N_Loop_Parameter_Specification or to 2062 -- an N_Iterator_Specification. 2063 2064 if Nkind_In 2065 (Ins, N_Iterator_Specification, 2066 N_Loop_Parameter_Specification) 2067 then 2068 -- Quantified expression are rewritten as 2069 -- loops during expansion. 2070 2071 if Nkind (Parent (Ins)) = 2072 N_Quantified_Expression 2073 then 2074 null; 2075 2076 else 2077 Ins := 2078 First 2079 (Statements 2080 (Parent (Parent (Ins)))); 2081 Insert_Before (Ins, Asn); 2082 end if; 2083 2084 else 2085 Insert_After (Ins, Asn); 2086 end if; 2087 2088 -- Analyze the assignment statement. We do 2089 -- not need to establish the relevant scope 2090 -- stack entries here, because we have 2091 -- already set the correct entity references, 2092 -- so no name resolution is required, and no 2093 -- new entities are created, so we don't even 2094 -- need to set the current scope. 2095 2096 -- We analyze with all checks suppressed 2097 -- (since we do not expect any exceptions). 2098 2099 Analyze (Asn, Suppress => All_Checks); 2100 end; 2101 2102 Next_Elmt (Elmt); 2103 end loop; 2104 end; 2105 end if; 2106 end; 2107 end if; 2108 end; 2109 end loop; 2110 end Subp_Loop; 2111 2112 -- Next step, process uplevel references. This has to be done in a 2113 -- separate pass, after completing the processing in Sub_Loop because we 2114 -- need all the AREC declarations generated, inserted, and analyzed so 2115 -- that the uplevel references can be successfully analyzed. 2116 2117 Uplev_Refs : for J in Urefs.First .. Urefs.Last loop 2118 declare 2119 UPJ : Uref_Entry renames Urefs.Table (J); 2120 2121 begin 2122 -- Ignore type references, these are implicit references that do 2123 -- not need rewriting (e.g. the appearence in a conversion). 2124 -- Also ignore if no reference was specified or if the rewriting 2125 -- has already been done (this can happen if the N_Identifier 2126 -- occurs more than one time in the tree). 2127 2128 if No (UPJ.Ref) 2129 or else not Is_Entity_Name (UPJ.Ref) 2130 or else not Present (Entity (UPJ.Ref)) 2131 then 2132 goto Continue; 2133 end if; 2134 2135 -- Rewrite one reference 2136 2137 Rewrite_One_Ref : declare 2138 Loc : constant Source_Ptr := Sloc (UPJ.Ref); 2139 -- Source location for the reference 2140 2141 Typ : constant Entity_Id := Etype (UPJ.Ent); 2142 -- The type of the referenced entity 2143 2144 Atyp : Entity_Id; 2145 -- The actual subtype of the reference 2146 2147 RS_Caller : constant SI_Type := Subp_Index (UPJ.Caller); 2148 -- Subp_Index for caller containing reference 2149 2150 STJR : Subp_Entry renames Subps.Table (RS_Caller); 2151 -- Subp_Entry for subprogram containing reference 2152 2153 RS_Callee : constant SI_Type := Subp_Index (UPJ.Callee); 2154 -- Subp_Index for subprogram containing referenced entity 2155 2156 STJE : Subp_Entry renames Subps.Table (RS_Callee); 2157 -- Subp_Entry for subprogram containing referenced entity 2158 2159 Pfx : Node_Id; 2160 Comp : Entity_Id; 2161 SI : SI_Type; 2162 2163 begin 2164 Atyp := Etype (UPJ.Ref); 2165 2166 if Ekind (Atyp) /= E_Record_Subtype then 2167 Atyp := Get_Actual_Subtype (UPJ.Ref); 2168 end if; 2169 2170 -- Ignore if no ARECnF entity for enclosing subprogram which 2171 -- probably happens as a result of not properly treating 2172 -- instance bodies. To be examined ??? 2173 2174 -- If this test is omitted, then the compilation of freeze.adb 2175 -- and inline.adb fail in unnesting mode. 2176 2177 if No (STJR.ARECnF) then 2178 goto Continue; 2179 end if; 2180 2181 -- If this is a reference to a global constant, use its value 2182 -- rather than create a reference. It is more efficient and 2183 -- furthermore indispensable if the context requires a 2184 -- constant, such as a branch of a case statement. 2185 2186 if Ekind (UPJ.Ent) = E_Constant 2187 and then Is_True_Constant (UPJ.Ent) 2188 and then Present (Constant_Value (UPJ.Ent)) 2189 and then Is_Static_Expression (Constant_Value (UPJ.Ent)) 2190 then 2191 Rewrite (UPJ.Ref, 2192 New_Copy_Tree (Constant_Value (UPJ.Ent))); 2193 goto Continue; 2194 end if; 2195 2196 -- Push the current scope, so that the pointer type Tnn, and 2197 -- any subsidiary entities resulting from the analysis of the 2198 -- rewritten reference, go in the right entity chain. 2199 2200 Push_Scope (STJR.Ent); 2201 2202 -- Now we need to rewrite the reference. We have a reference 2203 -- from level STJR.Lev to level STJE.Lev. The general form of 2204 -- the rewritten reference for entity X is: 2205 2206 -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECmU.X) 2207 2208 -- where a,b,c,d .. m = 2209 -- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev 2210 2211 pragma Assert (STJR.Lev > STJE.Lev); 2212 2213 -- Compute the prefix of X. Here are examples to make things 2214 -- clear (with parens to show groupings, the prefix is 2215 -- everything except the .X at the end). 2216 2217 -- level 2 to level 1 2218 2219 -- AREC1F.X 2220 2221 -- level 3 to level 1 2222 2223 -- (AREC2F.AREC1U).X 2224 2225 -- level 4 to level 1 2226 2227 -- ((AREC3F.AREC2U).AREC1U).X 2228 2229 -- level 6 to level 2 2230 2231 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X 2232 2233 -- In the above, ARECnF and ARECnU are pointers, so there are 2234 -- explicit dereferences required for these occurrences. 2235 2236 Pfx := 2237 Make_Explicit_Dereference (Loc, 2238 Prefix => New_Occurrence_Of (STJR.ARECnF, Loc)); 2239 SI := RS_Caller; 2240 for L in STJE.Lev .. STJR.Lev - 2 loop 2241 SI := Enclosing_Subp (SI); 2242 Pfx := 2243 Make_Explicit_Dereference (Loc, 2244 Prefix => 2245 Make_Selected_Component (Loc, 2246 Prefix => Pfx, 2247 Selector_Name => 2248 New_Occurrence_Of (Subps.Table (SI).ARECnU, Loc))); 2249 end loop; 2250 2251 -- Get activation record component (must exist) 2252 2253 Comp := Activation_Record_Component (UPJ.Ent); 2254 pragma Assert (Present (Comp)); 2255 2256 -- Do the replacement. If the component type is an access type, 2257 -- this is an uplevel reference for an entity that requires a 2258 -- fat pointer, so dereference the component. 2259 2260 if Is_Access_Type (Etype (Comp)) then 2261 Rewrite (UPJ.Ref, 2262 Make_Explicit_Dereference (Loc, 2263 Prefix => 2264 Make_Selected_Component (Loc, 2265 Prefix => Pfx, 2266 Selector_Name => 2267 New_Occurrence_Of (Comp, Loc)))); 2268 2269 else 2270 Rewrite (UPJ.Ref, 2271 Make_Attribute_Reference (Loc, 2272 Prefix => New_Occurrence_Of (Atyp, Loc), 2273 Attribute_Name => Name_Deref, 2274 Expressions => New_List ( 2275 Make_Selected_Component (Loc, 2276 Prefix => Pfx, 2277 Selector_Name => 2278 New_Occurrence_Of (Comp, Loc))))); 2279 end if; 2280 2281 -- Analyze and resolve the new expression. We do not need to 2282 -- establish the relevant scope stack entries here, because we 2283 -- have already set all the correct entity references, so no 2284 -- name resolution is needed. We have already set the current 2285 -- scope, so that any new entities created will be in the right 2286 -- scope. 2287 2288 -- We analyze with all checks suppressed (since we do not 2289 -- expect any exceptions) 2290 2291 Analyze_And_Resolve (UPJ.Ref, Typ, Suppress => All_Checks); 2292 Pop_Scope; 2293 end Rewrite_One_Ref; 2294 end; 2295 2296 <<Continue>> 2297 null; 2298 end loop Uplev_Refs; 2299 2300 -- Finally, loop through all calls adding extra actual for the 2301 -- activation record where it is required. 2302 2303 Adjust_Calls : for J in Calls.First .. Calls.Last loop 2304 2305 -- Process a single call, we are only interested in a call to a 2306 -- subprogram that actually needs a pointer to an activation record, 2307 -- as indicated by the ARECnF entity being set. This excludes the 2308 -- top level subprogram, and any subprogram not having uplevel refs. 2309 2310 Adjust_One_Call : declare 2311 CTJ : Call_Entry renames Calls.Table (J); 2312 STF : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Caller)); 2313 STT : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Callee)); 2314 2315 Loc : constant Source_Ptr := Sloc (CTJ.N); 2316 2317 Extra : Node_Id; 2318 ExtraP : Node_Id; 2319 SubX : SI_Type; 2320 Act : Node_Id; 2321 2322 begin 2323 if Present (STT.ARECnF) 2324 and then Nkind (CTJ.N) in N_Subprogram_Call 2325 then 2326 -- CTJ.N is a call to a subprogram which may require a pointer 2327 -- to an activation record. The subprogram containing the call 2328 -- is CTJ.From and the subprogram being called is CTJ.To, so we 2329 -- have a call from level STF.Lev to level STT.Lev. 2330 2331 -- There are three possibilities: 2332 2333 -- For a call to the same level, we just pass the activation 2334 -- record passed to the calling subprogram. 2335 2336 if STF.Lev = STT.Lev then 2337 Extra := New_Occurrence_Of (STF.ARECnF, Loc); 2338 2339 -- For a call that goes down a level, we pass a pointer to the 2340 -- activation record constructed within the caller (which may 2341 -- be the outer-level subprogram, but also may be a more deeply 2342 -- nested caller). 2343 2344 elsif STT.Lev = STF.Lev + 1 then 2345 Extra := New_Occurrence_Of (STF.ARECnP, Loc); 2346 2347 -- Otherwise we must have an upcall (STT.Lev < STF.LEV), 2348 -- since it is not possible to do a downcall of more than 2349 -- one level. 2350 2351 -- For a call from level STF.Lev to level STT.Lev, we 2352 -- have to find the activation record needed by the 2353 -- callee. This is as follows: 2354 2355 -- ARECaF.ARECbU.ARECcU....ARECmU 2356 2357 -- where a,b,c .. m = 2358 -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev 2359 2360 else 2361 pragma Assert (STT.Lev < STF.Lev); 2362 2363 Extra := New_Occurrence_Of (STF.ARECnF, Loc); 2364 SubX := Subp_Index (CTJ.Caller); 2365 for K in reverse STT.Lev .. STF.Lev - 1 loop 2366 SubX := Enclosing_Subp (SubX); 2367 Extra := 2368 Make_Selected_Component (Loc, 2369 Prefix => Extra, 2370 Selector_Name => 2371 New_Occurrence_Of 2372 (Subps.Table (SubX).ARECnU, Loc)); 2373 end loop; 2374 end if; 2375 2376 -- Extra is the additional parameter to be added. Build a 2377 -- parameter association that we can append to the actuals. 2378 2379 ExtraP := 2380 Make_Parameter_Association (Loc, 2381 Selector_Name => 2382 New_Occurrence_Of (STT.ARECnF, Loc), 2383 Explicit_Actual_Parameter => Extra); 2384 2385 if No (Parameter_Associations (CTJ.N)) then 2386 Set_Parameter_Associations (CTJ.N, Empty_List); 2387 end if; 2388 2389 Append (ExtraP, Parameter_Associations (CTJ.N)); 2390 2391 -- We need to deal with the actual parameter chain as well. The 2392 -- newly added parameter is always the last actual. 2393 2394 Act := First_Named_Actual (CTJ.N); 2395 2396 if No (Act) then 2397 Set_First_Named_Actual (CTJ.N, Extra); 2398 2399 -- If call has been relocated (as with an expression in 2400 -- an aggregate), set First_Named pointer in original node 2401 -- as well, because that's the parent of the parameter list. 2402 2403 Set_First_Named_Actual 2404 (Parent (List_Containing (ExtraP)), Extra); 2405 2406 -- Here we must follow the chain and append the new entry 2407 2408 else 2409 loop 2410 declare 2411 PAN : Node_Id; 2412 NNA : Node_Id; 2413 2414 begin 2415 PAN := Parent (Act); 2416 pragma Assert (Nkind (PAN) = N_Parameter_Association); 2417 NNA := Next_Named_Actual (PAN); 2418 2419 if No (NNA) then 2420 Set_Next_Named_Actual (PAN, Extra); 2421 exit; 2422 end if; 2423 2424 Act := NNA; 2425 end; 2426 end loop; 2427 end if; 2428 2429 -- Analyze and resolve the new actual. We do not need to 2430 -- establish the relevant scope stack entries here, because 2431 -- we have already set all the correct entity references, so 2432 -- no name resolution is needed. 2433 2434 -- We analyze with all checks suppressed (since we do not 2435 -- expect any exceptions, and also we temporarily turn off 2436 -- Unested_Subprogram_Mode to avoid trying to mark uplevel 2437 -- references (not needed at this stage, and in fact causes 2438 -- a bit of recursive chaos). 2439 2440 Opt.Unnest_Subprogram_Mode := False; 2441 Analyze_And_Resolve 2442 (Extra, Etype (STT.ARECnF), Suppress => All_Checks); 2443 Opt.Unnest_Subprogram_Mode := True; 2444 end if; 2445 end Adjust_One_Call; 2446 end loop Adjust_Calls; 2447 2448 return; 2449 end Unnest_Subprogram; 2450 2451 ------------------------ 2452 -- Unnest_Subprograms -- 2453 ------------------------ 2454 2455 procedure Unnest_Subprograms (N : Node_Id) is 2456 function Search_Subprograms (N : Node_Id) return Traverse_Result; 2457 -- Tree visitor that search for outer level procedures with nested 2458 -- subprograms and invokes Unnest_Subprogram() 2459 2460 --------------- 2461 -- Do_Search -- 2462 --------------- 2463 2464 procedure Do_Search is new Traverse_Proc (Search_Subprograms); 2465 -- Subtree visitor instantiation 2466 2467 ------------------------ 2468 -- Search_Subprograms -- 2469 ------------------------ 2470 2471 function Search_Subprograms (N : Node_Id) return Traverse_Result is 2472 begin 2473 if Nkind_In (N, N_Subprogram_Body, N_Subprogram_Body_Stub) then 2474 declare 2475 Spec_Id : constant Entity_Id := Unique_Defining_Entity (N); 2476 2477 begin 2478 -- We are only interested in subprograms (not generic 2479 -- subprograms), that have nested subprograms. 2480 2481 if Is_Subprogram (Spec_Id) 2482 and then Has_Nested_Subprogram (Spec_Id) 2483 and then Is_Library_Level_Entity (Spec_Id) 2484 then 2485 Unnest_Subprogram (Spec_Id, N); 2486 end if; 2487 end; 2488 2489 -- The proper body of a stub may contain nested subprograms, and 2490 -- therefore must be visited explicitly. Nested stubs are examined 2491 -- recursively in Visit_Node. 2492 2493 elsif Nkind (N) in N_Body_Stub then 2494 Do_Search (Library_Unit (N)); 2495 2496 -- Skip generic packages 2497 2498 elsif Nkind (N) = N_Package_Body 2499 and then Ekind (Corresponding_Spec (N)) = E_Generic_Package 2500 then 2501 return Skip; 2502 end if; 2503 2504 return OK; 2505 end Search_Subprograms; 2506 2507 -- Start of processing for Unnest_Subprograms 2508 2509 begin 2510 if not Opt.Unnest_Subprogram_Mode or not Opt.Expander_Active then 2511 return; 2512 end if; 2513 2514 -- A specification will contain bodies if it contains instantiations so 2515 -- examine package or subprogram declaration of the main unit, when it 2516 -- is present. 2517 2518 if Nkind (Unit (N)) = N_Package_Body 2519 or else (Nkind (Unit (N)) = N_Subprogram_Body 2520 and then not Acts_As_Spec (N)) 2521 then 2522 Do_Search (Library_Unit (N)); 2523 end if; 2524 2525 Do_Search (N); 2526 end Unnest_Subprograms; 2527 2528end Exp_Unst; 2529