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-2018, 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 Tbuild; use Tbuild; 47with Uintp; use Uintp; 48 49package body Exp_Unst is 50 51 ----------------------- 52 -- Local Subprograms -- 53 ----------------------- 54 55 procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id); 56 -- Subp is a library-level subprogram which has nested subprograms, and 57 -- Subp_Body is the corresponding N_Subprogram_Body node. This procedure 58 -- declares the AREC types and objects, adds assignments to the AREC record 59 -- as required, defines the xxxPTR types for uplevel referenced objects, 60 -- adds the ARECP parameter to all nested subprograms which need it, and 61 -- modifies all uplevel references appropriately. 62 63 ----------- 64 -- Calls -- 65 ----------- 66 67 -- Table to record calls within the nest being analyzed. These are the 68 -- calls which may need to have an AREC actual added. This table is built 69 -- new for each subprogram nest and cleared at the end of processing each 70 -- subprogram nest. 71 72 type Call_Entry is record 73 N : Node_Id; 74 -- The actual call 75 76 Caller : Entity_Id; 77 -- Entity of the subprogram containing the call (can be at any level) 78 79 Callee : Entity_Id; 80 -- Entity of the subprogram called (always at level 2 or higher). Note 81 -- that in accordance with the basic rules of nesting, the level of To 82 -- is either less than or equal to the level of From, or one greater. 83 end record; 84 85 package Calls is new Table.Table ( 86 Table_Component_Type => Call_Entry, 87 Table_Index_Type => Nat, 88 Table_Low_Bound => 1, 89 Table_Initial => 100, 90 Table_Increment => 200, 91 Table_Name => "Unnest_Calls"); 92 -- Records each call within the outer subprogram and all nested subprograms 93 -- that are to other subprograms nested within the outer subprogram. These 94 -- are the calls that may need an additional parameter. 95 96 procedure Append_Unique_Call (Call : Call_Entry); 97 -- Append a call entry to the Calls table. A check is made to see if the 98 -- table already contains this entry and if so it has no effect. 99 100 ----------- 101 -- Urefs -- 102 ----------- 103 104 -- Table to record explicit uplevel references to objects (variables, 105 -- constants, formal parameters). These are the references that will 106 -- need rewriting to use the activation table (AREC) pointers. Also 107 -- included are implicit and explicit uplevel references to types, but 108 -- these do not get rewritten by the front end. This table is built new 109 -- for each subprogram nest and cleared at the end of processing each 110 -- subprogram nest. 111 112 type Uref_Entry is record 113 Ref : Node_Id; 114 -- The reference itself. For objects this is always an entity reference 115 -- and the referenced entity will have its Is_Uplevel_Referenced_Entity 116 -- flag set and will appear in the Uplevel_Referenced_Entities list of 117 -- the subprogram declaring this entity. 118 119 Ent : Entity_Id; 120 -- The Entity_Id of the uplevel referenced object or type 121 122 Caller : Entity_Id; 123 -- The entity for the subprogram immediately containing this entity 124 125 Callee : Entity_Id; 126 -- The entity for the subprogram containing the referenced entity. Note 127 -- that the level of Callee must be less than the level of Caller, since 128 -- this is an uplevel reference. 129 end record; 130 131 package Urefs is new Table.Table ( 132 Table_Component_Type => Uref_Entry, 133 Table_Index_Type => Nat, 134 Table_Low_Bound => 1, 135 Table_Initial => 100, 136 Table_Increment => 200, 137 Table_Name => "Unnest_Urefs"); 138 139 ------------------------ 140 -- Append_Unique_Call -- 141 ------------------------ 142 143 procedure Append_Unique_Call (Call : Call_Entry) is 144 begin 145 for J in Calls.First .. Calls.Last loop 146 if Calls.Table (J) = Call then 147 return; 148 end if; 149 end loop; 150 151 Calls.Append (Call); 152 end Append_Unique_Call; 153 154 --------------- 155 -- Get_Level -- 156 --------------- 157 158 function Get_Level (Subp : Entity_Id; Sub : Entity_Id) return Nat is 159 Lev : Nat; 160 S : Entity_Id; 161 162 begin 163 Lev := 1; 164 S := Sub; 165 loop 166 if S = Subp then 167 return Lev; 168 else 169 Lev := Lev + 1; 170 S := Enclosing_Subprogram (S); 171 end if; 172 end loop; 173 end Get_Level; 174 175 ---------------- 176 -- Subp_Index -- 177 ---------------- 178 179 function Subp_Index (Sub : Entity_Id) return SI_Type is 180 E : Entity_Id := Sub; 181 182 begin 183 pragma Assert (Is_Subprogram (E)); 184 185 if Subps_Index (E) = Uint_0 then 186 E := Ultimate_Alias (E); 187 188 if Ekind (E) = E_Function 189 and then Rewritten_For_C (E) 190 and then Present (Corresponding_Procedure (E)) 191 then 192 E := Corresponding_Procedure (E); 193 end if; 194 end if; 195 196 pragma Assert (Subps_Index (E) /= Uint_0); 197 return SI_Type (UI_To_Int (Subps_Index (E))); 198 end Subp_Index; 199 200 ----------------------- 201 -- Unnest_Subprogram -- 202 ----------------------- 203 204 procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is 205 function AREC_Name (J : Pos; S : String) return Name_Id; 206 -- Returns name for string ARECjS, where j is the decimal value of j 207 208 function Enclosing_Subp (Subp : SI_Type) return SI_Type; 209 -- Subp is the index of a subprogram which has a Lev greater than 1. 210 -- This function returns the index of the enclosing subprogram which 211 -- will have a Lev value one less than this. 212 213 function Img_Pos (N : Pos) return String; 214 -- Return image of N without leading blank 215 216 function Upref_Name 217 (Ent : Entity_Id; 218 Index : Pos; 219 Clist : List_Id) return Name_Id; 220 -- This function returns the name to be used in the activation record to 221 -- reference the variable uplevel. Clist is the list of components that 222 -- have been created in the activation record so far. Normally the name 223 -- is just a copy of the Chars field of the entity. The exception is 224 -- when the name has already been used, in which case we suffix the name 225 -- with the index value Index to avoid duplication. This happens with 226 -- declare blocks and generic parameters at least. 227 228 --------------- 229 -- AREC_Name -- 230 --------------- 231 232 function AREC_Name (J : Pos; S : String) return Name_Id is 233 begin 234 return Name_Find ("AREC" & Img_Pos (J) & S); 235 end AREC_Name; 236 237 -------------------- 238 -- Enclosing_Subp -- 239 -------------------- 240 241 function Enclosing_Subp (Subp : SI_Type) return SI_Type is 242 STJ : Subp_Entry renames Subps.Table (Subp); 243 Ret : constant SI_Type := Subp_Index (Enclosing_Subprogram (STJ.Ent)); 244 begin 245 pragma Assert (STJ.Lev > 1); 246 pragma Assert (Subps.Table (Ret).Lev = STJ.Lev - 1); 247 return Ret; 248 end Enclosing_Subp; 249 250 ------------- 251 -- Img_Pos -- 252 ------------- 253 254 function Img_Pos (N : Pos) return String is 255 Buf : String (1 .. 20); 256 Ptr : Natural; 257 NV : Nat; 258 259 begin 260 Ptr := Buf'Last; 261 NV := N; 262 while NV /= 0 loop 263 Buf (Ptr) := Character'Val (48 + NV mod 10); 264 Ptr := Ptr - 1; 265 NV := NV / 10; 266 end loop; 267 268 return Buf (Ptr + 1 .. Buf'Last); 269 end Img_Pos; 270 271 ---------------- 272 -- Upref_Name -- 273 ---------------- 274 275 function Upref_Name 276 (Ent : Entity_Id; 277 Index : Pos; 278 Clist : List_Id) return Name_Id 279 is 280 C : Node_Id; 281 begin 282 C := First (Clist); 283 loop 284 if No (C) then 285 return Chars (Ent); 286 287 elsif Chars (Defining_Identifier (C)) = Chars (Ent) then 288 return 289 Name_Find (Get_Name_String (Chars (Ent)) & Img_Pos (Index)); 290 else 291 Next (C); 292 end if; 293 end loop; 294 end Upref_Name; 295 296 -- Start of processing for Unnest_Subprogram 297 298 begin 299 -- Nothing to do inside a generic (all processing is for instance) 300 301 if Inside_A_Generic then 302 return; 303 end if; 304 305 -- If the main unit is a package body then we need to examine the spec 306 -- to determine whether the main unit is generic (the scope stack is not 307 -- present when this is called on the main unit). 308 309 if Ekind (Cunit_Entity (Main_Unit)) = E_Package_Body 310 and then Is_Generic_Unit (Spec_Entity (Cunit_Entity (Main_Unit))) 311 then 312 return; 313 end if; 314 315 -- At least for now, do not unnest anything but main source unit 316 317 if not In_Extended_Main_Source_Unit (Subp_Body) then 318 return; 319 end if; 320 321 -- This routine is called late, after the scope stack is gone. The 322 -- following creates a suitable dummy scope stack to be used for the 323 -- analyze/expand calls made from this routine. 324 325 Push_Scope (Subp); 326 327 -- First step, we must mark all nested subprograms that require a static 328 -- link (activation record) because either they contain explicit uplevel 329 -- references (as indicated by Is_Uplevel_Referenced_Entity being set at 330 -- this point), or they make calls to other subprograms in the same nest 331 -- that require a static link (in which case we set this flag). 332 333 -- This is a recursive definition, and to implement this, we have to 334 -- build a call graph for the set of nested subprograms, and then go 335 -- over this graph to implement recursively the invariant that if a 336 -- subprogram has a call to a subprogram requiring a static link, then 337 -- the calling subprogram requires a static link. 338 339 -- First populate the above tables 340 341 Subps_First := Subps.Last + 1; 342 Calls.Init; 343 Urefs.Init; 344 345 Build_Tables : declare 346 Current_Subprogram : Entity_Id; 347 -- When we scan a subprogram body, we set Current_Subprogram to the 348 -- corresponding entity. This gets recursively saved and restored. 349 350 function Visit_Node (N : Node_Id) return Traverse_Result; 351 -- Visit a single node in Subp 352 353 ----------- 354 -- Visit -- 355 ----------- 356 357 procedure Visit is new Traverse_Proc (Visit_Node); 358 -- Used to traverse the body of Subp, populating the tables 359 360 ---------------- 361 -- Visit_Node -- 362 ---------------- 363 364 function Visit_Node (N : Node_Id) return Traverse_Result is 365 Ent : Entity_Id; 366 Caller : Entity_Id; 367 Callee : Entity_Id; 368 369 procedure Check_Static_Type (T : Entity_Id; DT : in out Boolean); 370 -- Given a type T, checks if it is a static type defined as a type 371 -- with no dynamic bounds in sight. If so, the only action is to 372 -- set Is_Static_Type True for T. If T is not a static type, then 373 -- all types with dynamic bounds associated with T are detected, 374 -- and their bounds are marked as uplevel referenced if not at the 375 -- library level, and DT is set True. 376 377 procedure Note_Uplevel_Ref 378 (E : Entity_Id; 379 Caller : Entity_Id; 380 Callee : Entity_Id); 381 -- Called when we detect an explicit or implicit uplevel reference 382 -- from within Caller to entity E declared in Callee. E can be a 383 -- an object or a type. 384 385 ----------------------- 386 -- Check_Static_Type -- 387 ----------------------- 388 389 procedure Check_Static_Type (T : Entity_Id; DT : in out Boolean) is 390 procedure Note_Uplevel_Bound (N : Node_Id); 391 -- N is the bound of a dynamic type. This procedure notes that 392 -- this bound is uplevel referenced, it can handle references 393 -- to entities (typically _FIRST and _LAST entities), and also 394 -- attribute references of the form T'name (name is typically 395 -- FIRST or LAST) where T is the uplevel referenced bound. 396 397 ------------------------ 398 -- Note_Uplevel_Bound -- 399 ------------------------ 400 401 procedure Note_Uplevel_Bound (N : Node_Id) is 402 begin 403 -- Entity name case 404 405 if Is_Entity_Name (N) then 406 if Present (Entity (N)) then 407 Note_Uplevel_Ref 408 (E => Entity (N), 409 Caller => Current_Subprogram, 410 Callee => Enclosing_Subprogram (Entity (N))); 411 end if; 412 413 -- Attribute case 414 415 elsif Nkind (N) = N_Attribute_Reference then 416 Note_Uplevel_Bound (Prefix (N)); 417 end if; 418 end Note_Uplevel_Bound; 419 420 -- Start of processing for Check_Static_Type 421 422 begin 423 -- If already marked static, immediate return 424 425 if Is_Static_Type (T) then 426 return; 427 end if; 428 429 -- If the type is at library level, always consider it static, 430 -- since such uplevel references are irrelevant. 431 432 if Is_Library_Level_Entity (T) then 433 Set_Is_Static_Type (T); 434 return; 435 end if; 436 437 -- Otherwise figure out what the story is with this type 438 439 -- For a scalar type, check bounds 440 441 if Is_Scalar_Type (T) then 442 443 -- If both bounds static, then this is a static type 444 445 declare 446 LB : constant Node_Id := Type_Low_Bound (T); 447 UB : constant Node_Id := Type_High_Bound (T); 448 449 begin 450 if not Is_Static_Expression (LB) then 451 Note_Uplevel_Bound (LB); 452 DT := True; 453 end if; 454 455 if not Is_Static_Expression (UB) then 456 Note_Uplevel_Bound (UB); 457 DT := True; 458 end if; 459 end; 460 461 -- For record type, check all components 462 463 elsif Is_Record_Type (T) then 464 declare 465 C : Entity_Id; 466 begin 467 C := First_Component_Or_Discriminant (T); 468 while Present (C) loop 469 Check_Static_Type (Etype (C), DT); 470 Next_Component_Or_Discriminant (C); 471 end loop; 472 end; 473 474 -- For array type, check index types and component type 475 476 elsif Is_Array_Type (T) then 477 declare 478 IX : Node_Id; 479 begin 480 Check_Static_Type (Component_Type (T), DT); 481 482 IX := First_Index (T); 483 while Present (IX) loop 484 Check_Static_Type (Etype (IX), DT); 485 Next_Index (IX); 486 end loop; 487 end; 488 489 -- For private type, examine whether full view is static 490 491 elsif Is_Private_Type (T) and then Present (Full_View (T)) then 492 Check_Static_Type (Full_View (T), DT); 493 494 if Is_Static_Type (Full_View (T)) then 495 Set_Is_Static_Type (T); 496 end if; 497 498 -- For now, ignore other types 499 500 else 501 return; 502 end if; 503 504 if not DT then 505 Set_Is_Static_Type (T); 506 end if; 507 end Check_Static_Type; 508 509 ---------------------- 510 -- Note_Uplevel_Ref -- 511 ---------------------- 512 513 procedure Note_Uplevel_Ref 514 (E : Entity_Id; 515 Caller : Entity_Id; 516 Callee : Entity_Id) 517 is 518 begin 519 -- Nothing to do for static type 520 521 if Is_Static_Type (E) then 522 return; 523 end if; 524 525 -- Nothing to do if Caller and Callee are the same 526 527 if Caller = Callee then 528 return; 529 530 -- Callee may be a function that returns an array, and that has 531 -- been rewritten as a procedure. If caller is that procedure, 532 -- nothing to do either. 533 534 elsif Ekind (Callee) = E_Function 535 and then Rewritten_For_C (Callee) 536 and then Corresponding_Procedure (Callee) = Caller 537 then 538 return; 539 end if; 540 541 -- We have a new uplevel referenced entity 542 543 -- All we do at this stage is to add the uplevel reference to 544 -- the table. It's too early to do anything else, since this 545 -- uplevel reference may come from an unreachable subprogram 546 -- in which case the entry will be deleted. 547 548 Urefs.Append ((N, E, Caller, Callee)); 549 end Note_Uplevel_Ref; 550 551 -- Start of processing for Visit_Node 552 553 begin 554 -- Record a call 555 556 if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) 557 558 -- We are only interested in direct calls, not indirect calls 559 -- (where Name (N) is an explicit dereference) at least for now! 560 561 and then Nkind (Name (N)) in N_Has_Entity 562 then 563 Ent := Entity (Name (N)); 564 565 -- We are only interested in calls to subprograms nested 566 -- within Subp. Calls to Subp itself or to subprograms 567 -- that are outside the nested structure do not affect us. 568 569 if Scope_Within (Ent, Subp) then 570 571 -- Ignore calls to imported routines 572 573 if Is_Imported (Ent) then 574 null; 575 576 -- Here we have a call to keep and analyze 577 578 else 579 -- Both caller and callee must be subprograms 580 581 if Is_Subprogram (Ent) then 582 Append_Unique_Call ((N, Current_Subprogram, Ent)); 583 end if; 584 end if; 585 end if; 586 587 -- Record a 'Access as a (potential) call 588 589 elsif Nkind (N) = N_Attribute_Reference then 590 declare 591 Attr : constant Attribute_Id := 592 Get_Attribute_Id (Attribute_Name (N)); 593 begin 594 case Attr is 595 when Attribute_Access 596 | Attribute_Unchecked_Access 597 | Attribute_Unrestricted_Access 598 => 599 if Nkind (Prefix (N)) in N_Has_Entity then 600 Ent := Entity (Prefix (N)); 601 602 -- We are only interested in calls to subprograms 603 -- nested within Subp. 604 605 if Scope_Within (Ent, Subp) then 606 if Is_Imported (Ent) then 607 null; 608 609 elsif Is_Subprogram (Ent) then 610 Append_Unique_Call 611 ((N, Current_Subprogram, Ent)); 612 end if; 613 end if; 614 end if; 615 616 when others => 617 null; 618 end case; 619 end; 620 621 -- Record a subprogram. We record a subprogram body that acts as 622 -- a spec. Otherwise we record a subprogram declaration, providing 623 -- that it has a corresponding body we can get hold of. The case 624 -- of no corresponding body being available is ignored for now. 625 626 elsif Nkind (N) = N_Subprogram_Body then 627 Ent := Unique_Defining_Entity (N); 628 629 -- Ignore generic subprogram 630 631 if Is_Generic_Subprogram (Ent) then 632 return Skip; 633 end if; 634 635 -- Make new entry in subprogram table if not already made 636 637 declare 638 L : constant Nat := Get_Level (Subp, Ent); 639 begin 640 Subps.Append 641 ((Ent => Ent, 642 Bod => N, 643 Lev => L, 644 Reachable => False, 645 Uplevel_Ref => L, 646 Declares_AREC => False, 647 Uents => No_Elist, 648 Last => 0, 649 ARECnF => Empty, 650 ARECn => Empty, 651 ARECnT => Empty, 652 ARECnPT => Empty, 653 ARECnP => Empty, 654 ARECnU => Empty)); 655 Set_Subps_Index (Ent, UI_From_Int (Subps.Last)); 656 end; 657 658 -- We make a recursive call to scan the subprogram body, so 659 -- that we can save and restore Current_Subprogram. 660 661 declare 662 Save_CS : constant Entity_Id := Current_Subprogram; 663 Decl : Node_Id; 664 665 begin 666 Current_Subprogram := Ent; 667 668 -- Scan declarations 669 670 Decl := First (Declarations (N)); 671 while Present (Decl) loop 672 Visit (Decl); 673 Next (Decl); 674 end loop; 675 676 -- Scan statements 677 678 Visit (Handled_Statement_Sequence (N)); 679 680 -- Restore current subprogram setting 681 682 Current_Subprogram := Save_CS; 683 end; 684 685 -- Now at this level, return skipping the subprogram body 686 -- descendants, since we already took care of them! 687 688 return Skip; 689 690 -- Record an uplevel reference 691 692 elsif Nkind (N) in N_Has_Entity and then Present (Entity (N)) then 693 Ent := Entity (N); 694 695 -- Only interested in entities declared within our nest 696 697 if not Is_Library_Level_Entity (Ent) 698 and then Scope_Within_Or_Same (Scope (Ent), Subp) 699 700 -- Skip entities defined in inlined subprograms 701 702 and then Chars (Enclosing_Subprogram (Ent)) /= Name_uParent 703 and then 704 705 -- Constants and variables are interesting 706 707 (Ekind_In (Ent, E_Constant, E_Variable) 708 709 -- Formals are interesting, but not if being used as mere 710 -- names of parameters for name notation calls. 711 712 or else 713 (Is_Formal (Ent) 714 and then not 715 (Nkind (Parent (N)) = N_Parameter_Association 716 and then Selector_Name (Parent (N)) = N)) 717 718 -- Types other than known Is_Static types are interesting 719 720 or else (Is_Type (Ent) 721 and then not Is_Static_Type (Ent))) 722 then 723 -- Here we have a possible interesting uplevel reference 724 725 if Is_Type (Ent) then 726 declare 727 DT : Boolean := False; 728 729 begin 730 Check_Static_Type (Ent, DT); 731 732 if Is_Static_Type (Ent) then 733 return OK; 734 end if; 735 end; 736 end if; 737 738 Caller := Current_Subprogram; 739 Callee := Enclosing_Subprogram (Ent); 740 741 if Callee /= Caller and then not Is_Static_Type (Ent) then 742 Note_Uplevel_Ref (Ent, Caller, Callee); 743 end if; 744 end if; 745 746 -- If we have a body stub, visit the associated subunit 747 748 elsif Nkind (N) in N_Body_Stub then 749 Visit (Library_Unit (N)); 750 751 -- Skip generic declarations 752 753 elsif Nkind (N) in N_Generic_Declaration then 754 return Skip; 755 756 -- Skip generic package body 757 758 elsif Nkind (N) = N_Package_Body 759 and then Present (Corresponding_Spec (N)) 760 and then Ekind (Corresponding_Spec (N)) = E_Generic_Package 761 then 762 return Skip; 763 end if; 764 765 -- Fall through to continue scanning children of this node 766 767 return OK; 768 end Visit_Node; 769 770 -- Start of processing for Build_Tables 771 772 begin 773 -- Traverse the body to get subprograms, calls and uplevel references 774 775 Visit (Subp_Body); 776 end Build_Tables; 777 778 -- Now do the first transitive closure which determines which 779 -- subprograms in the nest are actually reachable. 780 781 Reachable_Closure : declare 782 Modified : Boolean; 783 784 begin 785 Subps.Table (Subps_First).Reachable := True; 786 787 -- We use a simple minded algorithm as follows (obviously this can 788 -- be done more efficiently, using one of the standard algorithms 789 -- for efficient transitive closure computation, but this is simple 790 -- and most likely fast enough that its speed does not matter). 791 792 -- Repeatedly scan the list of calls. Any time we find a call from 793 -- A to B, where A is reachable, but B is not, then B is reachable, 794 -- and note that we have made a change by setting Modified True. We 795 -- repeat this until we make a pass with no modifications. 796 797 Outer : loop 798 Modified := False; 799 Inner : for J in Calls.First .. Calls.Last loop 800 declare 801 CTJ : Call_Entry renames Calls.Table (J); 802 803 SINF : constant SI_Type := Subp_Index (CTJ.Caller); 804 SINT : constant SI_Type := Subp_Index (CTJ.Callee); 805 806 SUBF : Subp_Entry renames Subps.Table (SINF); 807 SUBT : Subp_Entry renames Subps.Table (SINT); 808 809 begin 810 if SUBF.Reachable and then not SUBT.Reachable then 811 SUBT.Reachable := True; 812 Modified := True; 813 end if; 814 end; 815 end loop Inner; 816 817 exit Outer when not Modified; 818 end loop Outer; 819 end Reachable_Closure; 820 821 -- Remove calls from unreachable subprograms 822 823 declare 824 New_Index : Nat; 825 826 begin 827 New_Index := 0; 828 for J in Calls.First .. Calls.Last loop 829 declare 830 CTJ : Call_Entry renames Calls.Table (J); 831 832 SINF : constant SI_Type := Subp_Index (CTJ.Caller); 833 SINT : constant SI_Type := Subp_Index (CTJ.Callee); 834 835 SUBF : Subp_Entry renames Subps.Table (SINF); 836 SUBT : Subp_Entry renames Subps.Table (SINT); 837 838 begin 839 if SUBF.Reachable then 840 pragma Assert (SUBT.Reachable); 841 New_Index := New_Index + 1; 842 Calls.Table (New_Index) := Calls.Table (J); 843 end if; 844 end; 845 end loop; 846 847 Calls.Set_Last (New_Index); 848 end; 849 850 -- Remove uplevel references from unreachable subprograms 851 852 declare 853 New_Index : Nat; 854 855 begin 856 New_Index := 0; 857 for J in Urefs.First .. Urefs.Last loop 858 declare 859 URJ : Uref_Entry renames Urefs.Table (J); 860 861 SINF : constant SI_Type := Subp_Index (URJ.Caller); 862 SINT : constant SI_Type := Subp_Index (URJ.Callee); 863 864 SUBF : Subp_Entry renames Subps.Table (SINF); 865 SUBT : Subp_Entry renames Subps.Table (SINT); 866 867 S : Entity_Id; 868 869 begin 870 -- Keep reachable reference 871 872 if SUBF.Reachable then 873 New_Index := New_Index + 1; 874 Urefs.Table (New_Index) := Urefs.Table (J); 875 876 -- And since we know we are keeping this one, this is a good 877 -- place to fill in information for a good reference. 878 879 -- Mark all enclosing subprograms need to declare AREC 880 881 S := URJ.Caller; 882 loop 883 S := Enclosing_Subprogram (S); 884 885 -- if we are at the top level, as can happen with 886 -- references to formals in aspects of nested subprogram 887 -- declarations, there are no further subprograms to 888 -- mark as requiring activation records. 889 890 exit when No (S); 891 Subps.Table (Subp_Index (S)).Declares_AREC := True; 892 exit when S = URJ.Callee; 893 end loop; 894 895 -- Add to list of uplevel referenced entities for Callee. 896 -- We do not add types to this list, only actual references 897 -- to objects that will be referenced uplevel, and we use 898 -- the flag Is_Uplevel_Referenced_Entity to avoid making 899 -- duplicate entries in the list. 900 901 if not Is_Uplevel_Referenced_Entity (URJ.Ent) then 902 Set_Is_Uplevel_Referenced_Entity (URJ.Ent); 903 904 if not Is_Type (URJ.Ent) then 905 Append_New_Elmt (URJ.Ent, SUBT.Uents); 906 end if; 907 end if; 908 909 -- And set uplevel indication for caller 910 911 if SUBT.Lev < SUBF.Uplevel_Ref then 912 SUBF.Uplevel_Ref := SUBT.Lev; 913 end if; 914 end if; 915 end; 916 end loop; 917 918 Urefs.Set_Last (New_Index); 919 end; 920 921 -- Remove unreachable subprograms from Subps table. Note that we do 922 -- this after eliminating entries from the other two tables, since 923 -- those elimination steps depend on referencing the Subps table. 924 925 declare 926 New_SI : SI_Type; 927 928 begin 929 New_SI := Subps_First - 1; 930 for J in Subps_First .. Subps.Last loop 931 declare 932 STJ : Subp_Entry renames Subps.Table (J); 933 Spec : Node_Id; 934 Decl : Node_Id; 935 936 begin 937 -- Subprogram is reachable, copy and reset index 938 939 if STJ.Reachable then 940 New_SI := New_SI + 1; 941 Subps.Table (New_SI) := STJ; 942 Set_Subps_Index (STJ.Ent, UI_From_Int (New_SI)); 943 944 -- Subprogram is not reachable 945 946 else 947 -- Clear index, since no longer active 948 949 Set_Subps_Index (Subps.Table (J).Ent, Uint_0); 950 951 -- Output debug information if -gnatd.3 set 952 953 if Debug_Flag_Dot_3 then 954 Write_Str ("Eliminate "); 955 Write_Name (Chars (Subps.Table (J).Ent)); 956 Write_Str (" at "); 957 Write_Location (Sloc (Subps.Table (J).Ent)); 958 Write_Str (" (not referenced)"); 959 Write_Eol; 960 end if; 961 962 -- Rewrite declaration and body to null statements 963 964 Spec := Corresponding_Spec (STJ.Bod); 965 966 if Present (Spec) then 967 Decl := Parent (Declaration_Node (Spec)); 968 Rewrite (Decl, Make_Null_Statement (Sloc (Decl))); 969 end if; 970 971 Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod))); 972 end if; 973 end; 974 end loop; 975 976 Subps.Set_Last (New_SI); 977 end; 978 979 -- Now it is time for the second transitive closure, which follows calls 980 -- and makes sure that A calls B, and B has uplevel references, then A 981 -- is also marked as having uplevel references. 982 983 Closure_Uplevel : declare 984 Modified : Boolean; 985 986 begin 987 -- We use a simple minded algorithm as follows (obviously this can 988 -- be done more efficiently, using one of the standard algorithms 989 -- for efficient transitive closure computation, but this is simple 990 -- and most likely fast enough that its speed does not matter). 991 992 -- Repeatedly scan the list of calls. Any time we find a call from 993 -- A to B, where B has uplevel references, make sure that A is marked 994 -- as having at least the same level of uplevel referencing. 995 996 Outer2 : loop 997 Modified := False; 998 Inner2 : for J in Calls.First .. Calls.Last loop 999 declare 1000 CTJ : Call_Entry renames Calls.Table (J); 1001 SINF : constant SI_Type := Subp_Index (CTJ.Caller); 1002 SINT : constant SI_Type := Subp_Index (CTJ.Callee); 1003 SUBF : Subp_Entry renames Subps.Table (SINF); 1004 SUBT : Subp_Entry renames Subps.Table (SINT); 1005 begin 1006 if SUBT.Lev > SUBT.Uplevel_Ref 1007 and then SUBF.Uplevel_Ref > SUBT.Uplevel_Ref 1008 then 1009 SUBF.Uplevel_Ref := SUBT.Uplevel_Ref; 1010 Modified := True; 1011 end if; 1012 end; 1013 end loop Inner2; 1014 1015 exit Outer2 when not Modified; 1016 end loop Outer2; 1017 end Closure_Uplevel; 1018 1019 -- We have one more step before the tables are complete. An uplevel 1020 -- call from subprogram A to subprogram B where subprogram B has uplevel 1021 -- references is in effect an uplevel reference, and must arrange for 1022 -- the proper activation link to be passed. 1023 1024 for J in Calls.First .. Calls.Last loop 1025 declare 1026 CTJ : Call_Entry renames Calls.Table (J); 1027 1028 SINF : constant SI_Type := Subp_Index (CTJ.Caller); 1029 SINT : constant SI_Type := Subp_Index (CTJ.Callee); 1030 1031 SUBF : Subp_Entry renames Subps.Table (SINF); 1032 SUBT : Subp_Entry renames Subps.Table (SINT); 1033 1034 A : Entity_Id; 1035 1036 begin 1037 -- If callee has uplevel references 1038 1039 if SUBT.Uplevel_Ref < SUBT.Lev 1040 1041 -- And this is an uplevel call 1042 1043 and then SUBT.Lev < SUBF.Lev 1044 then 1045 -- We need to arrange for finding the uplink 1046 1047 A := CTJ.Caller; 1048 loop 1049 A := Enclosing_Subprogram (A); 1050 Subps.Table (Subp_Index (A)).Declares_AREC := True; 1051 exit when A = CTJ.Callee; 1052 1053 -- In any case exit when we get to the outer level. This 1054 -- happens in some odd cases with generics (in particular 1055 -- sem_ch3.adb does not compile without this kludge ???). 1056 1057 exit when A = Subp; 1058 end loop; 1059 end if; 1060 end; 1061 end loop; 1062 1063 -- The tables are now complete, so we can record the last index in the 1064 -- Subps table for later reference in Cprint. 1065 1066 Subps.Table (Subps_First).Last := Subps.Last; 1067 1068 -- Next step, create the entities for code we will insert. We do this 1069 -- at the start so that all the entities are defined, regardless of the 1070 -- order in which we do the code insertions. 1071 1072 Create_Entities : for J in Subps_First .. Subps.Last loop 1073 declare 1074 STJ : Subp_Entry renames Subps.Table (J); 1075 Loc : constant Source_Ptr := Sloc (STJ.Bod); 1076 1077 begin 1078 -- First we create the ARECnF entity for the additional formal for 1079 -- all subprograms which need an activation record passed. 1080 1081 if STJ.Uplevel_Ref < STJ.Lev then 1082 STJ.ARECnF := 1083 Make_Defining_Identifier (Loc, Chars => AREC_Name (J, "F")); 1084 end if; 1085 1086 -- Define the AREC entities for the activation record if needed 1087 1088 if STJ.Declares_AREC then 1089 STJ.ARECn := 1090 Make_Defining_Identifier (Loc, AREC_Name (J, "")); 1091 STJ.ARECnT := 1092 Make_Defining_Identifier (Loc, AREC_Name (J, "T")); 1093 STJ.ARECnPT := 1094 Make_Defining_Identifier (Loc, AREC_Name (J, "PT")); 1095 STJ.ARECnP := 1096 Make_Defining_Identifier (Loc, AREC_Name (J, "P")); 1097 1098 -- Define uplink component entity if inner nesting case 1099 1100 if Present (STJ.ARECnF) then 1101 STJ.ARECnU := 1102 Make_Defining_Identifier (Loc, AREC_Name (J, "U")); 1103 end if; 1104 end if; 1105 end; 1106 end loop Create_Entities; 1107 1108 -- Loop through subprograms 1109 1110 Subp_Loop : declare 1111 Addr : constant Entity_Id := RTE (RE_Address); 1112 1113 begin 1114 for J in Subps_First .. Subps.Last loop 1115 declare 1116 STJ : Subp_Entry renames Subps.Table (J); 1117 1118 begin 1119 -- First add the extra formal if needed. This applies to all 1120 -- nested subprograms that require an activation record to be 1121 -- passed, as indicated by ARECnF being defined. 1122 1123 if Present (STJ.ARECnF) then 1124 1125 -- Here we need the extra formal. We do the expansion and 1126 -- analysis of this manually, since it is fairly simple, 1127 -- and it is not obvious how we can get what we want if we 1128 -- try to use the normal Analyze circuit. 1129 1130 Add_Extra_Formal : declare 1131 Encl : constant SI_Type := Enclosing_Subp (J); 1132 STJE : Subp_Entry renames Subps.Table (Encl); 1133 -- Index and Subp_Entry for enclosing routine 1134 1135 Form : constant Entity_Id := STJ.ARECnF; 1136 -- The formal to be added. Note that n here is one less 1137 -- than the level of the subprogram itself (STJ.Ent). 1138 1139 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id); 1140 -- S is an N_Function/Procedure_Specification node, and F 1141 -- is the new entity to add to this subprogramn spec as 1142 -- the last Extra_Formal. 1143 1144 ---------------------- 1145 -- Add_Form_To_Spec -- 1146 ---------------------- 1147 1148 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is 1149 Sub : constant Entity_Id := Defining_Entity (S); 1150 Ent : Entity_Id; 1151 1152 begin 1153 -- Case of at least one Extra_Formal is present, set 1154 -- ARECnF as the new last entry in the list. 1155 1156 if Present (Extra_Formals (Sub)) then 1157 Ent := Extra_Formals (Sub); 1158 while Present (Extra_Formal (Ent)) loop 1159 Ent := Extra_Formal (Ent); 1160 end loop; 1161 1162 Set_Extra_Formal (Ent, F); 1163 1164 -- No Extra formals present 1165 1166 else 1167 Set_Extra_Formals (Sub, F); 1168 Ent := Last_Formal (Sub); 1169 1170 if Present (Ent) then 1171 Set_Extra_Formal (Ent, F); 1172 end if; 1173 end if; 1174 end Add_Form_To_Spec; 1175 1176 -- Start of processing for Add_Extra_Formal 1177 1178 begin 1179 -- Decorate the new formal entity 1180 1181 Set_Scope (Form, STJ.Ent); 1182 Set_Ekind (Form, E_In_Parameter); 1183 Set_Etype (Form, STJE.ARECnPT); 1184 Set_Mechanism (Form, By_Copy); 1185 Set_Never_Set_In_Source (Form, True); 1186 Set_Analyzed (Form, True); 1187 Set_Comes_From_Source (Form, False); 1188 1189 -- Case of only body present 1190 1191 if Acts_As_Spec (STJ.Bod) then 1192 Add_Form_To_Spec (Form, Specification (STJ.Bod)); 1193 1194 -- Case of separate spec 1195 1196 else 1197 Add_Form_To_Spec (Form, Parent (STJ.Ent)); 1198 end if; 1199 end Add_Extra_Formal; 1200 end if; 1201 1202 -- Processing for subprograms that declare an activation record 1203 1204 if Present (STJ.ARECn) then 1205 1206 -- Local declarations for one such subprogram 1207 1208 declare 1209 Loc : constant Source_Ptr := Sloc (STJ.Bod); 1210 Clist : List_Id; 1211 Comp : Entity_Id; 1212 1213 Decl_ARECnT : Node_Id; 1214 Decl_ARECnPT : Node_Id; 1215 Decl_ARECn : Node_Id; 1216 Decl_ARECnP : Node_Id; 1217 -- Declaration nodes for the AREC entities we build 1218 1219 Decl_Assign : Node_Id; 1220 -- Assigment to set uplink, Empty if none 1221 1222 Decls : List_Id; 1223 -- List of new declarations we create 1224 1225 begin 1226 -- Build list of component declarations for ARECnT 1227 1228 Clist := Empty_List; 1229 1230 -- If we are in a subprogram that has a static link that 1231 -- is passed in (as indicated by ARECnF being defined), 1232 -- then include ARECnU : ARECmPT where ARECmPT comes from 1233 -- the level one higher than the current level, and the 1234 -- entity ARECnPT comes from the enclosing subprogram. 1235 1236 if Present (STJ.ARECnF) then 1237 declare 1238 STJE : Subp_Entry 1239 renames Subps.Table (Enclosing_Subp (J)); 1240 begin 1241 Append_To (Clist, 1242 Make_Component_Declaration (Loc, 1243 Defining_Identifier => STJ.ARECnU, 1244 Component_Definition => 1245 Make_Component_Definition (Loc, 1246 Subtype_Indication => 1247 New_Occurrence_Of (STJE.ARECnPT, Loc)))); 1248 end; 1249 end if; 1250 1251 -- Add components for uplevel referenced entities 1252 1253 if Present (STJ.Uents) then 1254 declare 1255 Elmt : Elmt_Id; 1256 Uent : Entity_Id; 1257 1258 Indx : Nat; 1259 -- 1's origin of index in list of elements. This is 1260 -- used to uniquify names if needed in Upref_Name. 1261 1262 begin 1263 Elmt := First_Elmt (STJ.Uents); 1264 Indx := 0; 1265 while Present (Elmt) loop 1266 Uent := Node (Elmt); 1267 Indx := Indx + 1; 1268 1269 Comp := 1270 Make_Defining_Identifier (Loc, 1271 Chars => Upref_Name (Uent, Indx, Clist)); 1272 1273 Set_Activation_Record_Component 1274 (Uent, Comp); 1275 1276 Append_To (Clist, 1277 Make_Component_Declaration (Loc, 1278 Defining_Identifier => Comp, 1279 Component_Definition => 1280 Make_Component_Definition (Loc, 1281 Subtype_Indication => 1282 New_Occurrence_Of (Addr, Loc)))); 1283 1284 Next_Elmt (Elmt); 1285 end loop; 1286 end; 1287 end if; 1288 1289 -- Now we can insert the AREC declarations into the body 1290 1291 -- type ARECnT is record .. end record; 1292 -- pragma Suppress_Initialization (ARECnT); 1293 1294 -- Note that we need to set the Suppress_Initialization 1295 -- flag after Decl_ARECnT has been analyzed. 1296 1297 Decl_ARECnT := 1298 Make_Full_Type_Declaration (Loc, 1299 Defining_Identifier => STJ.ARECnT, 1300 Type_Definition => 1301 Make_Record_Definition (Loc, 1302 Component_List => 1303 Make_Component_List (Loc, 1304 Component_Items => Clist))); 1305 Decls := New_List (Decl_ARECnT); 1306 1307 -- type ARECnPT is access all ARECnT; 1308 1309 Decl_ARECnPT := 1310 Make_Full_Type_Declaration (Loc, 1311 Defining_Identifier => STJ.ARECnPT, 1312 Type_Definition => 1313 Make_Access_To_Object_Definition (Loc, 1314 All_Present => True, 1315 Subtype_Indication => 1316 New_Occurrence_Of (STJ.ARECnT, Loc))); 1317 Append_To (Decls, Decl_ARECnPT); 1318 1319 -- ARECn : aliased ARECnT; 1320 1321 Decl_ARECn := 1322 Make_Object_Declaration (Loc, 1323 Defining_Identifier => STJ.ARECn, 1324 Aliased_Present => True, 1325 Object_Definition => 1326 New_Occurrence_Of (STJ.ARECnT, Loc)); 1327 Append_To (Decls, Decl_ARECn); 1328 1329 -- ARECnP : constant ARECnPT := ARECn'Access; 1330 1331 Decl_ARECnP := 1332 Make_Object_Declaration (Loc, 1333 Defining_Identifier => STJ.ARECnP, 1334 Constant_Present => True, 1335 Object_Definition => 1336 New_Occurrence_Of (STJ.ARECnPT, Loc), 1337 Expression => 1338 Make_Attribute_Reference (Loc, 1339 Prefix => 1340 New_Occurrence_Of (STJ.ARECn, Loc), 1341 Attribute_Name => Name_Access)); 1342 Append_To (Decls, Decl_ARECnP); 1343 1344 -- If we are in a subprogram that has a static link that 1345 -- is passed in (as indicated by ARECnF being defined), 1346 -- then generate ARECn.ARECmU := ARECmF where m is 1347 -- one less than the current level to set the uplink. 1348 1349 if Present (STJ.ARECnF) then 1350 Decl_Assign := 1351 Make_Assignment_Statement (Loc, 1352 Name => 1353 Make_Selected_Component (Loc, 1354 Prefix => 1355 New_Occurrence_Of (STJ.ARECn, Loc), 1356 Selector_Name => 1357 New_Occurrence_Of (STJ.ARECnU, Loc)), 1358 Expression => 1359 New_Occurrence_Of (STJ.ARECnF, Loc)); 1360 Append_To (Decls, Decl_Assign); 1361 1362 else 1363 Decl_Assign := Empty; 1364 end if; 1365 1366 Prepend_List_To (Declarations (STJ.Bod), Decls); 1367 1368 -- Analyze the newly inserted declarations. Note that we 1369 -- do not need to establish the whole scope stack, since 1370 -- we have already set all entity fields (so there will 1371 -- be no searching of upper scopes to resolve names). But 1372 -- we do set the scope of the current subprogram, so that 1373 -- newly created entities go in the right entity chain. 1374 1375 -- We analyze with all checks suppressed (since we do 1376 -- not expect any exceptions). 1377 1378 Push_Scope (STJ.Ent); 1379 Analyze (Decl_ARECnT, Suppress => All_Checks); 1380 1381 -- Note that we need to call Set_Suppress_Initialization 1382 -- after Decl_ARECnT has been analyzed, but before 1383 -- analyzing Decl_ARECnP so that the flag is properly 1384 -- taking into account. 1385 1386 Set_Suppress_Initialization (STJ.ARECnT); 1387 1388 Analyze (Decl_ARECnPT, Suppress => All_Checks); 1389 Analyze (Decl_ARECn, Suppress => All_Checks); 1390 Analyze (Decl_ARECnP, Suppress => All_Checks); 1391 1392 if Present (Decl_Assign) then 1393 Analyze (Decl_Assign, Suppress => All_Checks); 1394 end if; 1395 1396 Pop_Scope; 1397 1398 -- Next step, for each uplevel referenced entity, add 1399 -- assignment operations to set the component in the 1400 -- activation record. 1401 1402 if Present (STJ.Uents) then 1403 declare 1404 Elmt : Elmt_Id; 1405 1406 begin 1407 Elmt := First_Elmt (STJ.Uents); 1408 while Present (Elmt) loop 1409 declare 1410 Ent : constant Entity_Id := Node (Elmt); 1411 Loc : constant Source_Ptr := Sloc (Ent); 1412 Dec : constant Node_Id := 1413 Declaration_Node (Ent); 1414 Ins : Node_Id; 1415 Asn : Node_Id; 1416 1417 begin 1418 -- For parameters, we insert the assignment 1419 -- right after the declaration of ARECnP. 1420 -- For all other entities, we insert 1421 -- the assignment immediately after 1422 -- the declaration of the entity. 1423 1424 -- Note: we don't need to mark the entity 1425 -- as being aliased, because the address 1426 -- attribute will mark it as Address_Taken, 1427 -- and that is good enough. 1428 1429 if Is_Formal (Ent) then 1430 Ins := Decl_ARECnP; 1431 else 1432 Ins := Dec; 1433 end if; 1434 1435 -- Build and insert the assignment: 1436 -- ARECn.nam := nam'Address 1437 1438 Asn := 1439 Make_Assignment_Statement (Loc, 1440 Name => 1441 Make_Selected_Component (Loc, 1442 Prefix => 1443 New_Occurrence_Of (STJ.ARECn, Loc), 1444 Selector_Name => 1445 New_Occurrence_Of 1446 (Activation_Record_Component 1447 (Ent), 1448 Loc)), 1449 1450 Expression => 1451 Make_Attribute_Reference (Loc, 1452 Prefix => 1453 New_Occurrence_Of (Ent, Loc), 1454 Attribute_Name => Name_Address)); 1455 1456 Insert_After (Ins, Asn); 1457 1458 -- Analyze the assignment statement. We do 1459 -- not need to establish the relevant scope 1460 -- stack entries here, because we have 1461 -- already set the correct entity references, 1462 -- so no name resolution is required, and no 1463 -- new entities are created, so we don't even 1464 -- need to set the current scope. 1465 1466 -- We analyze with all checks suppressed 1467 -- (since we do not expect any exceptions). 1468 1469 Analyze (Asn, Suppress => All_Checks); 1470 end; 1471 1472 Next_Elmt (Elmt); 1473 end loop; 1474 end; 1475 end if; 1476 end; 1477 end if; 1478 end; 1479 end loop; 1480 end Subp_Loop; 1481 1482 -- Next step, process uplevel references. This has to be done in a 1483 -- separate pass, after completing the processing in Sub_Loop because we 1484 -- need all the AREC declarations generated, inserted, and analyzed so 1485 -- that the uplevel references can be successfully analyzed. 1486 1487 Uplev_Refs : for J in Urefs.First .. Urefs.Last loop 1488 declare 1489 UPJ : Uref_Entry renames Urefs.Table (J); 1490 1491 begin 1492 -- Ignore type references, these are implicit references that do 1493 -- not need rewriting (e.g. the appearence in a conversion). 1494 1495 if Is_Type (UPJ.Ent) then 1496 goto Continue; 1497 end if; 1498 1499 -- Also ignore uplevel references to bounds of types that come 1500 -- from the original type reference. 1501 1502 if Is_Entity_Name (UPJ.Ref) 1503 and then Present (Entity (UPJ.Ref)) 1504 and then Is_Type (Entity (UPJ.Ref)) 1505 then 1506 goto Continue; 1507 end if; 1508 1509 -- Rewrite one reference 1510 1511 Rewrite_One_Ref : declare 1512 Loc : constant Source_Ptr := Sloc (UPJ.Ref); 1513 -- Source location for the reference 1514 1515 Typ : constant Entity_Id := Etype (UPJ.Ent); 1516 -- The type of the referenced entity 1517 1518 Atyp : constant Entity_Id := Get_Actual_Subtype (UPJ.Ref); 1519 -- The actual subtype of the reference 1520 1521 RS_Caller : constant SI_Type := Subp_Index (UPJ.Caller); 1522 -- Subp_Index for caller containing reference 1523 1524 STJR : Subp_Entry renames Subps.Table (RS_Caller); 1525 -- Subp_Entry for subprogram containing reference 1526 1527 RS_Callee : constant SI_Type := Subp_Index (UPJ.Callee); 1528 -- Subp_Index for subprogram containing referenced entity 1529 1530 STJE : Subp_Entry renames Subps.Table (RS_Callee); 1531 -- Subp_Entry for subprogram containing referenced entity 1532 1533 Pfx : Node_Id; 1534 Comp : Entity_Id; 1535 SI : SI_Type; 1536 1537 begin 1538 -- Ignore if no ARECnF entity for enclosing subprogram which 1539 -- probably happens as a result of not properly treating 1540 -- instance bodies. To be examined ??? 1541 1542 -- If this test is omitted, then the compilation of freeze.adb 1543 -- and inline.adb fail in unnesting mode. 1544 1545 if No (STJR.ARECnF) then 1546 goto Continue; 1547 end if; 1548 1549 -- Push the current scope, so that the pointer type Tnn, and 1550 -- any subsidiary entities resulting from the analysis of the 1551 -- rewritten reference, go in the right entity chain. 1552 1553 Push_Scope (STJR.Ent); 1554 1555 -- Now we need to rewrite the reference. We have a reference 1556 -- from level STJR.Lev to level STJE.Lev. The general form of 1557 -- the rewritten reference for entity X is: 1558 1559 -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X) 1560 1561 -- where a,b,c,d .. m = 1562 -- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev 1563 1564 pragma Assert (STJR.Lev > STJE.Lev); 1565 1566 -- Compute the prefix of X. Here are examples to make things 1567 -- clear (with parens to show groupings, the prefix is 1568 -- everything except the .X at the end). 1569 1570 -- level 2 to level 1 1571 1572 -- AREC1F.X 1573 1574 -- level 3 to level 1 1575 1576 -- (AREC2F.AREC1U).X 1577 1578 -- level 4 to level 1 1579 1580 -- ((AREC3F.AREC2U).AREC1U).X 1581 1582 -- level 6 to level 2 1583 1584 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X 1585 1586 -- In the above, ARECnF and ARECnU are pointers, so there are 1587 -- explicit dereferences required for these occurrences. 1588 1589 Pfx := 1590 Make_Explicit_Dereference (Loc, 1591 Prefix => New_Occurrence_Of (STJR.ARECnF, Loc)); 1592 SI := RS_Caller; 1593 for L in STJE.Lev .. STJR.Lev - 2 loop 1594 SI := Enclosing_Subp (SI); 1595 Pfx := 1596 Make_Explicit_Dereference (Loc, 1597 Prefix => 1598 Make_Selected_Component (Loc, 1599 Prefix => Pfx, 1600 Selector_Name => 1601 New_Occurrence_Of (Subps.Table (SI).ARECnU, Loc))); 1602 end loop; 1603 1604 -- Get activation record component (must exist) 1605 1606 Comp := Activation_Record_Component (UPJ.Ent); 1607 pragma Assert (Present (Comp)); 1608 1609 -- Do the replacement 1610 1611 Rewrite (UPJ.Ref, 1612 Make_Attribute_Reference (Loc, 1613 Prefix => New_Occurrence_Of (Atyp, Loc), 1614 Attribute_Name => Name_Deref, 1615 Expressions => New_List ( 1616 Make_Selected_Component (Loc, 1617 Prefix => Pfx, 1618 Selector_Name => 1619 New_Occurrence_Of (Comp, Loc))))); 1620 1621 -- Analyze and resolve the new expression. We do not need to 1622 -- establish the relevant scope stack entries here, because we 1623 -- have already set all the correct entity references, so no 1624 -- name resolution is needed. We have already set the current 1625 -- scope, so that any new entities created will be in the right 1626 -- scope. 1627 1628 -- We analyze with all checks suppressed (since we do not 1629 -- expect any exceptions) 1630 1631 Analyze_And_Resolve (UPJ.Ref, Typ, Suppress => All_Checks); 1632 Pop_Scope; 1633 end Rewrite_One_Ref; 1634 end; 1635 1636 <<Continue>> 1637 null; 1638 end loop Uplev_Refs; 1639 1640 -- Finally, loop through all calls adding extra actual for the 1641 -- activation record where it is required. 1642 1643 Adjust_Calls : for J in Calls.First .. Calls.Last loop 1644 1645 -- Process a single call, we are only interested in a call to a 1646 -- subprogram that actually needs a pointer to an activation record, 1647 -- as indicated by the ARECnF entity being set. This excludes the 1648 -- top level subprogram, and any subprogram not having uplevel refs. 1649 1650 Adjust_One_Call : declare 1651 CTJ : Call_Entry renames Calls.Table (J); 1652 STF : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Caller)); 1653 STT : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Callee)); 1654 1655 Loc : constant Source_Ptr := Sloc (CTJ.N); 1656 1657 Extra : Node_Id; 1658 ExtraP : Node_Id; 1659 SubX : SI_Type; 1660 Act : Node_Id; 1661 1662 begin 1663 if Present (STT.ARECnF) 1664 and then Nkind (CTJ.N) /= N_Attribute_Reference 1665 then 1666 -- CTJ.N is a call to a subprogram which may require a pointer 1667 -- to an activation record. The subprogram containing the call 1668 -- is CTJ.From and the subprogram being called is CTJ.To, so we 1669 -- have a call from level STF.Lev to level STT.Lev. 1670 1671 -- There are three possibilities: 1672 1673 -- For a call to the same level, we just pass the activation 1674 -- record passed to the calling subprogram. 1675 1676 if STF.Lev = STT.Lev then 1677 Extra := New_Occurrence_Of (STF.ARECnF, Loc); 1678 1679 -- For a call that goes down a level, we pass a pointer to the 1680 -- activation record constructed within the caller (which may 1681 -- be the outer-level subprogram, but also may be a more deeply 1682 -- nested caller). 1683 1684 elsif STT.Lev = STF.Lev + 1 then 1685 Extra := New_Occurrence_Of (STF.ARECnP, Loc); 1686 1687 -- Otherwise we must have an upcall (STT.Lev < STF.LEV), 1688 -- since it is not possible to do a downcall of more than 1689 -- one level. 1690 1691 -- For a call from level STF.Lev to level STT.Lev, we 1692 -- have to find the activation record needed by the 1693 -- callee. This is as follows: 1694 1695 -- ARECaF.ARECbU.ARECcU....ARECm 1696 1697 -- where a,b,c .. m = 1698 -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev 1699 1700 else 1701 pragma Assert (STT.Lev < STF.Lev); 1702 1703 Extra := New_Occurrence_Of (STF.ARECnF, Loc); 1704 SubX := Subp_Index (CTJ.Caller); 1705 for K in reverse STT.Lev .. STF.Lev - 1 loop 1706 SubX := Enclosing_Subp (SubX); 1707 Extra := 1708 Make_Selected_Component (Loc, 1709 Prefix => Extra, 1710 Selector_Name => 1711 New_Occurrence_Of 1712 (Subps.Table (SubX).ARECnU, Loc)); 1713 end loop; 1714 end if; 1715 1716 -- Extra is the additional parameter to be added. Build a 1717 -- parameter association that we can append to the actuals. 1718 1719 ExtraP := 1720 Make_Parameter_Association (Loc, 1721 Selector_Name => 1722 New_Occurrence_Of (STT.ARECnF, Loc), 1723 Explicit_Actual_Parameter => Extra); 1724 1725 if No (Parameter_Associations (CTJ.N)) then 1726 Set_Parameter_Associations (CTJ.N, Empty_List); 1727 end if; 1728 1729 Append (ExtraP, Parameter_Associations (CTJ.N)); 1730 1731 -- We need to deal with the actual parameter chain as well. The 1732 -- newly added parameter is always the last actual. 1733 1734 Act := First_Named_Actual (CTJ.N); 1735 1736 if No (Act) then 1737 Set_First_Named_Actual (CTJ.N, Extra); 1738 1739 -- Here we must follow the chain and append the new entry 1740 1741 else 1742 loop 1743 declare 1744 PAN : Node_Id; 1745 NNA : Node_Id; 1746 1747 begin 1748 PAN := Parent (Act); 1749 pragma Assert (Nkind (PAN) = N_Parameter_Association); 1750 NNA := Next_Named_Actual (PAN); 1751 1752 if No (NNA) then 1753 Set_Next_Named_Actual (PAN, Extra); 1754 exit; 1755 end if; 1756 1757 Act := NNA; 1758 end; 1759 end loop; 1760 end if; 1761 1762 -- Analyze and resolve the new actual. We do not need to 1763 -- establish the relevant scope stack entries here, because 1764 -- we have already set all the correct entity references, so 1765 -- no name resolution is needed. 1766 1767 -- We analyze with all checks suppressed (since we do not 1768 -- expect any exceptions, and also we temporarily turn off 1769 -- Unested_Subprogram_Mode to avoid trying to mark uplevel 1770 -- references (not needed at this stage, and in fact causes 1771 -- a bit of recursive chaos). 1772 1773 Opt.Unnest_Subprogram_Mode := False; 1774 Analyze_And_Resolve 1775 (Extra, Etype (STT.ARECnF), Suppress => All_Checks); 1776 Opt.Unnest_Subprogram_Mode := True; 1777 end if; 1778 end Adjust_One_Call; 1779 end loop Adjust_Calls; 1780 1781 return; 1782 end Unnest_Subprogram; 1783 1784 ------------------------ 1785 -- Unnest_Subprograms -- 1786 ------------------------ 1787 1788 procedure Unnest_Subprograms (N : Node_Id) is 1789 function Search_Subprograms (N : Node_Id) return Traverse_Result; 1790 -- Tree visitor that search for outer level procedures with nested 1791 -- subprograms and invokes Unnest_Subprogram() 1792 1793 ------------------------ 1794 -- Search_Subprograms -- 1795 ------------------------ 1796 1797 function Search_Subprograms (N : Node_Id) return Traverse_Result is 1798 begin 1799 if Nkind_In (N, N_Subprogram_Body, N_Subprogram_Body_Stub) then 1800 declare 1801 Spec_Id : constant Entity_Id := Unique_Defining_Entity (N); 1802 1803 begin 1804 -- We are only interested in subprograms (not generic 1805 -- subprograms), that have nested subprograms. 1806 1807 if Is_Subprogram (Spec_Id) 1808 and then Has_Nested_Subprogram (Spec_Id) 1809 and then Is_Library_Level_Entity (Spec_Id) 1810 then 1811 Unnest_Subprogram (Spec_Id, N); 1812 end if; 1813 end; 1814 end if; 1815 1816 return OK; 1817 end Search_Subprograms; 1818 1819 --------------- 1820 -- Do_Search -- 1821 --------------- 1822 1823 procedure Do_Search is new Traverse_Proc (Search_Subprograms); 1824 -- Subtree visitor instantiation 1825 1826 -- Start of processing for Unnest_Subprograms 1827 1828 begin 1829 if not Opt.Unnest_Subprogram_Mode then 1830 return; 1831 end if; 1832 1833 Do_Search (N); 1834 end Unnest_Subprograms; 1835 1836end Exp_Unst; 1837