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