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 Einfo; use Einfo; 28with Elists; use Elists; 29with Exp_Util; use Exp_Util; 30with Lib; use Lib; 31with Namet; use Namet; 32with Nlists; use Nlists; 33with Nmake; use Nmake; 34with Opt; use Opt; 35with Rtsfind; use Rtsfind; 36with Sinput; use Sinput; 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 Snames; use Snames; 44with Table; 45with Tbuild; use Tbuild; 46with Uintp; use Uintp; 47 48package body Exp_Unst is 49 50 -- Tables used by Unnest_Subprogram 51 52 type Subp_Entry is record 53 Ent : Entity_Id; 54 -- Entity of the subprogram 55 56 Bod : Node_Id; 57 -- Subprogram_Body node for this subprogram 58 59 Lev : Nat; 60 -- Subprogram level (1 = outer subprogram (Subp argument), 2 = nested 61 -- immediately within this outer subprogram etc.) 62 63 Urefs : Elist_Id; 64 -- This is a copy of the Uplevel_References field from the entity for 65 -- the subprogram. Copy this to reuse the field for Subps_Index. 66 67 ARECnF : Entity_Id; 68 -- This entity is defined for all subprograms with uplevel references 69 -- except for the top-level subprogram (Subp itself). It is the entity 70 -- for the formal which is added to the parameter list to pass the 71 -- pointer to the activation record. Note that for this entity, n is 72 -- one less than the current level. 73 74 ARECn : Entity_Id; 75 ARECnT : Entity_Id; 76 ARECnPT : Entity_Id; 77 ARECnP : Entity_Id; 78 -- These AREC entities are defined only for subprograms for which we 79 -- generate an activation record declaration, i.e. for subprograms 80 -- with at least one nested subprogram that have uplevel referennces. 81 -- They are set to Empty for all other cases. 82 83 ARECnU : Entity_Id; 84 -- This AREC entity is the uplink component. It is other than Empty only 85 -- for nested subprograms that themselves have nested subprograms and 86 -- have uplevel references. Note that the n here is one less than the 87 -- level of the subprogram defining the activation record. 88 89 end record; 90 91 subtype SI_Type is Nat; 92 93 package Subps is new Table.Table ( 94 Table_Component_Type => Subp_Entry, 95 Table_Index_Type => SI_Type, 96 Table_Low_Bound => 1, 97 Table_Initial => 100, 98 Table_Increment => 200, 99 Table_Name => "Unnest_Subps"); 100 -- Records the subprograms in the nest whose outer subprogram is Subp 101 102 type Call_Entry is record 103 N : Node_Id; 104 -- The actual call 105 106 From : Entity_Id; 107 -- Entity of the subprogram containing the call 108 109 To : Entity_Id; 110 -- Entity of the subprogram called 111 end record; 112 113 package Calls is new Table.Table ( 114 Table_Component_Type => Call_Entry, 115 Table_Index_Type => Nat, 116 Table_Low_Bound => 1, 117 Table_Initial => 100, 118 Table_Increment => 200, 119 Table_Name => "Unnest_Calls"); 120 -- Records each call within the outer subprogram and all nested subprograms 121 -- that are to other subprograms nested within the outer subprogram. These 122 -- are the calls that may need an additional parameter. 123 124 ------------------------------------- 125 -- Check_Uplevel_Reference_To_Type -- 126 ------------------------------------- 127 128 procedure Check_Uplevel_Reference_To_Type (Typ : Entity_Id) is 129 function Check_Dynamic_Type (T : Entity_Id) return Boolean; 130 -- This is an internal recursive routine that checks if T or any of 131 -- its subsdidiary types are dynamic. If so, then the original Typ is 132 -- marked as having an uplevel reference, as is the subsidiary type in 133 -- question, and any referenced dynamic bounds are also marked as having 134 -- an uplevel reference, and True is returned. If the type is a static 135 -- type, then False is returned; 136 137 ------------------------ 138 -- Check_Dynamic_Type -- 139 ------------------------ 140 141 function Check_Dynamic_Type (T : Entity_Id) return Boolean is 142 DT : Boolean := False; 143 144 begin 145 -- If it's a static type, nothing to do 146 147 if Is_Static_Type (T) then 148 return False; 149 150 -- If the type is uplevel referenced, then it must be dynamic 151 152 elsif Has_Uplevel_Reference (T) then 153 Set_Has_Uplevel_Reference (Typ); 154 return True; 155 156 -- If the type is at library level, always consider it static, since 157 -- uplevel references do not matter in this case. 158 159 elsif Is_Library_Level_Entity (T) then 160 Set_Is_Static_Type (T); 161 return False; 162 163 -- Otherwise we need to figure out what the story is with this type 164 165 else 166 DT := False; 167 168 -- For a scalar type, check bounds 169 170 if Is_Scalar_Type (T) then 171 172 -- If both bounds static, then this is a static type 173 174 declare 175 LB : constant Node_Id := Type_Low_Bound (T); 176 UB : constant Node_Id := Type_High_Bound (T); 177 178 begin 179 if not Is_Static_Expression (LB) then 180 Set_Has_Uplevel_Reference (Entity (LB)); 181 DT := True; 182 end if; 183 184 if not Is_Static_Expression (UB) then 185 Set_Has_Uplevel_Reference (Entity (UB)); 186 DT := True; 187 end if; 188 end; 189 190 -- For record type, check all components 191 192 elsif Is_Record_Type (T) then 193 declare 194 C : Entity_Id; 195 196 begin 197 C := First_Component_Or_Discriminant (T); 198 while Present (C) loop 199 if Check_Dynamic_Type (Etype (C)) then 200 DT := True; 201 end if; 202 203 Next_Component_Or_Discriminant (C); 204 end loop; 205 end; 206 207 -- For array type, check index types and component type 208 209 elsif Is_Array_Type (T) then 210 declare 211 IX : Node_Id; 212 213 begin 214 if Check_Dynamic_Type (Component_Type (T)) then 215 DT := True; 216 end if; 217 218 IX := First_Index (T); 219 while Present (IX) loop 220 if Check_Dynamic_Type (Etype (IX)) then 221 DT := True; 222 end if; 223 224 Next_Index (IX); 225 end loop; 226 end; 227 228 -- For now, ignore other types 229 230 else 231 return False; 232 end if; 233 234 -- See if we marked that type as dynamic 235 236 if DT then 237 Set_Has_Uplevel_Reference (T); 238 Set_Has_Uplevel_Reference (Typ); 239 return True; 240 241 -- If not mark it as static 242 243 else 244 Set_Is_Static_Type (T); 245 return False; 246 end if; 247 end if; 248 end Check_Dynamic_Type; 249 250 -- Start of processing for Check_Uplevel_Reference_To_Type 251 252 begin 253 -- Nothing to do inside a generic (all processing is for instance) 254 255 if Inside_A_Generic then 256 return; 257 258 -- Nothing to do if we know this is a static type 259 260 elsif Is_Static_Type (Typ) then 261 return; 262 263 -- Nothing to do if already marked as uplevel referenced 264 265 elsif Has_Uplevel_Reference (Typ) then 266 return; 267 268 -- Otherwise check if we have a dynamic type 269 270 else 271 if Check_Dynamic_Type (Typ) then 272 Set_Has_Uplevel_Reference (Typ); 273 end if; 274 end if; 275 276 null; 277 end Check_Uplevel_Reference_To_Type; 278 279 ---------------------------- 280 -- Note_Uplevel_Reference -- 281 ---------------------------- 282 283 procedure Note_Uplevel_Reference (N : Node_Id; Subp : Entity_Id) is 284 Elmt : Elmt_Id; 285 286 begin 287 -- Nothing to do inside a generic (all processing is for instance) 288 289 if Inside_A_Generic then 290 return; 291 end if; 292 293 -- Nothing to do if reference has no entity field 294 295 if Nkind (N) not in N_Has_Entity then 296 return; 297 end if; 298 299 -- Establish list if first call for Uplevel_References 300 301 if No (Uplevel_References (Subp)) then 302 Set_Uplevel_References (Subp, New_Elmt_List); 303 end if; 304 305 -- Ignore if node is already in the list. This is a bit inefficient, 306 -- but we can definitely get duplicates that cause trouble! 307 308 Elmt := First_Elmt (Uplevel_References (Subp)); 309 while Present (Elmt) loop 310 if N = Node (Elmt) then 311 return; 312 else 313 Next_Elmt (Elmt); 314 end if; 315 end loop; 316 317 -- Add new entry to Uplevel_References. Each entry is two elements of 318 -- the list. The first is the actual reference, the second is the 319 -- enclosing subprogram at the point of reference 320 321 Append_Elmt (N, Uplevel_References (Subp)); 322 323 if Is_Subprogram (Current_Scope) then 324 Append_Elmt (Current_Scope, Uplevel_References (Subp)); 325 else 326 Append_Elmt 327 (Enclosing_Subprogram (Current_Scope), Uplevel_References (Subp)); 328 end if; 329 330 Set_Has_Uplevel_Reference (Entity (N)); 331 Set_Has_Uplevel_Reference (Subp); 332 end Note_Uplevel_Reference; 333 334 ----------------------- 335 -- Unnest_Subprogram -- 336 ----------------------- 337 338 procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is 339 function Actual_Ref (N : Node_Id) return Node_Id; 340 -- This function is applied to an element in the Uplevel_References 341 -- list, and it finds the actual reference. Often this is just N itself, 342 -- but in some cases it gets rewritten, e.g. as a Type_Conversion, and 343 -- this function digs out the actual reference 344 345 function AREC_String (Lev : Pos) return String; 346 -- Given a level value, 1, 2, ... returns the string AREC, AREC2, ... 347 348 function Enclosing_Subp (Subp : SI_Type) return SI_Type; 349 -- Subp is the index of a subprogram which has a Lev greater than 1. 350 -- This function returns the index of the enclosing subprogram which 351 -- will have a Lev value one less than this. 352 353 function Get_Level (Sub : Entity_Id) return Nat; 354 -- Sub is either Subp itself, or a subprogram nested within Subp. This 355 -- function returns the level of nesting (Subp = 1, subprograms that 356 -- are immediately nested within Subp = 2, etc). 357 358 function Subp_Index (Sub : Entity_Id) return SI_Type; 359 -- Given the entity for a subprogram, return corresponding Subps index 360 361 ---------------- 362 -- Actual_Ref -- 363 ---------------- 364 365 function Actual_Ref (N : Node_Id) return Node_Id is 366 begin 367 case Nkind (N) is 368 369 -- If we have an entity reference, then this is the actual ref 370 371 when N_Has_Entity => 372 return N; 373 374 -- For a type conversion, go get the expression 375 376 when N_Type_Conversion => 377 return Expression (N); 378 379 -- For an explicit dereference, get the prefix 380 381 when N_Explicit_Dereference => 382 return Prefix (N); 383 384 -- No other possibilities should exist 385 386 when others => 387 raise Program_Error; 388 end case; 389 end Actual_Ref; 390 391 ----------------- 392 -- AREC_String -- 393 ----------------- 394 395 function AREC_String (Lev : Pos) return String is 396 begin 397 if Lev > 9 then 398 return AREC_String (Lev / 10) & Character'Val (Lev mod 10 + 48); 399 else 400 return "AREC" & Character'Val (Lev + 48); 401 end if; 402 end AREC_String; 403 404 -------------------- 405 -- Enclosing_Subp -- 406 -------------------- 407 408 function Enclosing_Subp (Subp : SI_Type) return SI_Type is 409 STJ : Subp_Entry renames Subps.Table (Subp); 410 Ret : constant SI_Type := Subp_Index (Enclosing_Subprogram (STJ.Ent)); 411 begin 412 pragma Assert (STJ.Lev > 1); 413 pragma Assert (Subps.Table (Ret).Lev = STJ.Lev - 1); 414 return Ret; 415 end Enclosing_Subp; 416 417 --------------- 418 -- Get_Level -- 419 --------------- 420 421 function Get_Level (Sub : Entity_Id) return Nat is 422 Lev : Nat; 423 S : Entity_Id; 424 425 begin 426 Lev := 1; 427 S := Sub; 428 loop 429 if S = Subp then 430 return Lev; 431 else 432 S := Enclosing_Subprogram (S); 433 Lev := Lev + 1; 434 end if; 435 end loop; 436 end Get_Level; 437 438 ---------------- 439 -- Subp_Index -- 440 ---------------- 441 442 function Subp_Index (Sub : Entity_Id) return SI_Type is 443 begin 444 pragma Assert (Is_Subprogram (Sub)); 445 return SI_Type (UI_To_Int (Subps_Index (Sub))); 446 end Subp_Index; 447 448 -- Start of processing for Unnest_Subprogram 449 450 begin 451 -- Nothing to do inside a generic (all processing is for instance) 452 453 if Inside_A_Generic then 454 return; 455 end if; 456 -- At least for now, do not unnest anything but main source unit 457 458 if not In_Extended_Main_Source_Unit (Subp_Body) then 459 return; 460 end if; 461 462 -- First step, we must mark all nested subprograms that require a static 463 -- link (activation record) because either they contain explicit uplevel 464 -- references (as indicated by Has_Uplevel_Reference being set at this 465 -- point), or they make calls to other subprograms in the same nest that 466 -- require a static link (in which case we set this flag). 467 468 -- This is a recursive definition, and to implement this, we have to 469 -- build a call graph for the set of nested subprograms, and then go 470 -- over this graph to implement recursively the invariant that if a 471 -- subprogram has a call to a subprogram requiring a static link, then 472 -- the calling subprogram requires a static link. 473 474 -- First populate the above tables 475 476 Subps.Init; 477 Calls.Init; 478 479 Build_Tables : declare 480 function Visit_Node (N : Node_Id) return Traverse_Result; 481 -- Visit a single node in Subp 482 483 ---------------- 484 -- Visit_Node -- 485 ---------------- 486 487 function Visit_Node (N : Node_Id) return Traverse_Result is 488 Ent : Entity_Id; 489 Csub : Entity_Id; 490 491 function Find_Current_Subprogram return Entity_Id; 492 -- Finds the current subprogram containing the call N 493 494 ----------------------------- 495 -- Find_Current_Subprogram -- 496 ----------------------------- 497 498 function Find_Current_Subprogram return Entity_Id is 499 Nod : Node_Id; 500 501 begin 502 Nod := N; 503 loop 504 Nod := Parent (Nod); 505 506 if Nkind (Nod) = N_Subprogram_Body then 507 if Acts_As_Spec (Nod) then 508 return Defining_Entity (Specification (Nod)); 509 else 510 return Corresponding_Spec (Nod); 511 end if; 512 end if; 513 end loop; 514 end Find_Current_Subprogram; 515 516 -- Start of processing for Visit_Node 517 518 begin 519 -- Record a call 520 521 if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) 522 523 -- We are only interested in direct calls, not indirect calls 524 -- (where Name (N) is an explicit dereference) at least for now! 525 526 and then Nkind (Name (N)) in N_Has_Entity 527 then 528 Ent := Entity (Name (N)); 529 530 -- We are only interested in calls to subprograms nested 531 -- within Subp. Calls to Subp itself or to subprograms that 532 -- are outside the nested structure do not affect us. 533 534 if Scope_Within (Ent, Subp) then 535 536 -- For now, ignore calls to generic instances. Seems to be 537 -- some problem there which we will investigate later ??? 538 539 if Original_Location (Sloc (Ent)) /= Sloc (Ent) 540 or else Is_Generic_Instance (Ent) 541 then 542 null; 543 544 -- Ignore calls to imported routines 545 546 elsif Is_Imported (Ent) then 547 null; 548 549 -- Here we have a call to keep and analyze 550 551 else 552 Csub := Find_Current_Subprogram; 553 554 -- Both caller and callee must be subprograms (we ignore 555 -- generic subprograms). 556 557 if Is_Subprogram (Csub) and then Is_Subprogram (Ent) then 558 Calls.Append ((N, Find_Current_Subprogram, Ent)); 559 end if; 560 end if; 561 end if; 562 563 -- Record a subprogram. We record a subprogram body that acts as 564 -- a spec. Otherwise we record a subprogram declaration, providing 565 -- that it has a corresponding body we can get hold of. The case 566 -- of no corresponding body being available is ignored for now. 567 568 elsif (Nkind (N) = N_Subprogram_Body and then Acts_As_Spec (N)) 569 or else (Nkind (N) = N_Subprogram_Declaration 570 and then Present (Corresponding_Body (N))) 571 then 572 Subps.Increment_Last; 573 574 declare 575 STJ : Subp_Entry renames Subps.Table (Subps.Last); 576 577 begin 578 -- Set fields of Subp_Entry for new subprogram 579 580 STJ.Ent := Defining_Entity (Specification (N)); 581 STJ.Lev := Get_Level (STJ.Ent); 582 583 if Nkind (N) = N_Subprogram_Body then 584 STJ.Bod := N; 585 else 586 STJ.Bod := 587 Parent (Declaration_Node (Corresponding_Body (N))); 588 pragma Assert (Nkind (STJ.Bod) = N_Subprogram_Body); 589 end if; 590 591 -- Capture Uplevel_References, and then set (uses the same 592 -- field), the Subps_Index value for this subprogram. 593 594 STJ.Urefs := Uplevel_References (STJ.Ent); 595 Set_Subps_Index (STJ.Ent, UI_From_Int (Int (Subps.Last))); 596 end; 597 end if; 598 599 return OK; 600 end Visit_Node; 601 602 ----------- 603 -- Visit -- 604 ----------- 605 606 procedure Visit is new Traverse_Proc (Visit_Node); 607 -- Used to traverse the body of Subp, populating the tables 608 609 -- Start of processing for Build_Tables 610 611 begin 612 -- A special case, if the outer level subprogram has a separate spec 613 -- then we won't catch it in the traversal of the body. But we do 614 -- want to visit the declaration in this case! 615 616 if not Acts_As_Spec (Subp_Body) then 617 declare 618 Dummy : Traverse_Result; 619 Decl : constant Node_Id := 620 Parent (Declaration_Node (Corresponding_Spec (Subp_Body))); 621 pragma Assert (Nkind (Decl) = N_Subprogram_Declaration); 622 begin 623 Dummy := Visit_Node (Decl); 624 end; 625 end if; 626 627 -- Traverse the body to get the rest of the subprograms and calls 628 629 Visit (Subp_Body); 630 end Build_Tables; 631 632 -- Second step is to do the transitive closure, if any subprogram has 633 -- a call to a subprogram for which Has_Uplevel_Reference is set, then 634 -- we set Has_Uplevel_Reference for the calling routine. 635 636 Closure : declare 637 Modified : Boolean; 638 639 begin 640 -- We use a simple minded algorithm as follows (obviously this can 641 -- be done more efficiently, using one of the standard algorithms 642 -- for efficient transitive closure computation, but this is simple 643 -- and most likely fast enough that its speed does not matter). 644 645 -- Repeatedly scan the list of calls. Any time we find a call from 646 -- A to B, where A does not have Has_Uplevel_Reference, and B does 647 -- have this flag set, then set the flag for A, and note that we 648 -- have made a change by setting Modified True. We repeat this until 649 -- we make a pass with no modifications. 650 651 Outer : loop 652 Modified := False; 653 Inner : for J in Calls.First .. Calls.Last loop 654 if not Has_Uplevel_Reference (Calls.Table (J).From) 655 and then Has_Uplevel_Reference (Calls.Table (J).To) 656 then 657 Set_Has_Uplevel_Reference (Calls.Table (J).From); 658 Modified := True; 659 end if; 660 end loop Inner; 661 662 exit Outer when not Modified; 663 end loop Outer; 664 end Closure; 665 666 -- Next step, create the entities for code we will insert. We do this 667 -- at the start so that all the entities are defined, regardless of the 668 -- order in which we do the code insertions. 669 670 Create_Entities : for J in Subps.First .. Subps.Last loop 671 declare 672 STJ : Subp_Entry renames Subps.Table (J); 673 Loc : constant Source_Ptr := Sloc (STJ.Bod); 674 ARS : constant String := AREC_String (STJ.Lev); 675 676 begin 677 -- First we create the ARECnF entity for the additional formal 678 -- for all subprograms requiring that an activation record pointer 679 -- be passed. This is true of all subprograms that have uplevel 680 -- references, and whose enclosing subprogram also has uplevel 681 -- references. 682 683 if Has_Uplevel_Reference (STJ.Ent) 684 and then STJ.Ent /= Subp 685 and then Has_Uplevel_Reference (Enclosing_Subprogram (STJ.Ent)) 686 then 687 STJ.ARECnF := 688 Make_Defining_Identifier (Loc, 689 Chars => Name_Find_Str (AREC_String (STJ.Lev - 1) & "F")); 690 else 691 STJ.ARECnF := Empty; 692 end if; 693 694 -- Now define the AREC entities for the activation record. This 695 -- is needed for any subprogram that has nested subprograms and 696 -- has uplevel references. 697 698 if Has_Nested_Subprogram (STJ.Ent) 699 and then Has_Uplevel_Reference (STJ.Ent) 700 then 701 STJ.ARECn := 702 Make_Defining_Identifier (Loc, Name_Find_Str (ARS)); 703 STJ.ARECnT := 704 Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "T")); 705 STJ.ARECnPT := 706 Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "PT")); 707 STJ.ARECnP := 708 Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "P")); 709 710 else 711 STJ.ARECn := Empty; 712 STJ.ARECnT := Empty; 713 STJ.ARECnPT := Empty; 714 STJ.ARECnP := Empty; 715 STJ.ARECnU := Empty; 716 end if; 717 718 -- Define uplink component entity if inner nesting case 719 720 if Has_Uplevel_Reference (STJ.Ent) and then STJ.Lev > 1 then 721 declare 722 ARS1 : constant String := AREC_String (STJ.Lev - 1); 723 begin 724 STJ.ARECnU := 725 Make_Defining_Identifier (Loc, 726 Chars => Name_Find_Str (ARS1 & "U")); 727 end; 728 729 else 730 STJ.ARECnU := Empty; 731 end if; 732 end; 733 end loop Create_Entities; 734 735 -- Loop through subprograms 736 737 Subp_Loop : declare 738 Addr : constant Entity_Id := RTE (RE_Address); 739 740 begin 741 for J in Subps.First .. Subps.Last loop 742 declare 743 STJ : Subp_Entry renames Subps.Table (J); 744 745 begin 746 -- First add the extra formal if needed. This applies to all 747 -- nested subprograms that require an activation record to be 748 -- passed, as indicated by ARECnF being defined. 749 750 if Present (STJ.ARECnF) then 751 752 -- Here we need the extra formal. We do the expansion and 753 -- analysis of this manually, since it is fairly simple, 754 -- and it is not obvious how we can get what we want if we 755 -- try to use the normal Analyze circuit. 756 757 Add_Extra_Formal : declare 758 Encl : constant SI_Type := Enclosing_Subp (J); 759 STJE : Subp_Entry renames Subps.Table (Encl); 760 -- Index and Subp_Entry for enclosing routine 761 762 Form : constant Entity_Id := STJ.ARECnF; 763 -- The formal to be added. Note that n here is one less 764 -- than the level of the subprogram itself (STJ.Ent). 765 766 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id); 767 -- S is an N_Function/Procedure_Specification node, and F 768 -- is the new entity to add to this subprogramn spec as 769 -- the last Extra_Formal. 770 771 ---------------------- 772 -- Add_Form_To_Spec -- 773 ---------------------- 774 775 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is 776 Sub : constant Entity_Id := Defining_Entity (S); 777 Ent : Entity_Id; 778 779 begin 780 -- Case of at least one Extra_Formal is present, set 781 -- ARECnF as the new last entry in the list. 782 783 if Present (Extra_Formals (Sub)) then 784 Ent := Extra_Formals (Sub); 785 while Present (Extra_Formal (Ent)) loop 786 Ent := Extra_Formal (Ent); 787 end loop; 788 789 Set_Extra_Formal (Ent, F); 790 791 -- No Extra formals present 792 793 else 794 Set_Extra_Formals (Sub, F); 795 Ent := Last_Formal (Sub); 796 797 if Present (Ent) then 798 Set_Extra_Formal (Ent, F); 799 end if; 800 end if; 801 end Add_Form_To_Spec; 802 803 -- Start of processing for Add_Extra_Formal 804 805 begin 806 -- Decorate the new formal entity 807 808 Set_Scope (Form, STJ.Ent); 809 Set_Ekind (Form, E_In_Parameter); 810 Set_Etype (Form, STJE.ARECnPT); 811 Set_Mechanism (Form, By_Copy); 812 Set_Never_Set_In_Source (Form, True); 813 Set_Analyzed (Form, True); 814 Set_Comes_From_Source (Form, False); 815 816 -- Case of only body present 817 818 if Acts_As_Spec (STJ.Bod) then 819 Add_Form_To_Spec (Form, Specification (STJ.Bod)); 820 821 -- Case of separate spec 822 823 else 824 Add_Form_To_Spec (Form, Parent (STJ.Ent)); 825 end if; 826 end Add_Extra_Formal; 827 end if; 828 829 -- Processing for subprograms that have at least one nested 830 -- subprogram, and have uplevel references. 831 832 if Has_Nested_Subprogram (STJ.Ent) 833 and then Has_Uplevel_Reference (STJ.Ent) 834 then 835 -- Local declarations for one such subprogram 836 837 declare 838 Loc : constant Source_Ptr := Sloc (STJ.Bod); 839 Elmt : Elmt_Id; 840 Nod : Node_Id; 841 Ent : Entity_Id; 842 Clist : List_Id; 843 Comp : Entity_Id; 844 845 Decl_ARECnT : Node_Id; 846 Decl_ARECn : Node_Id; 847 Decl_ARECnPT : Node_Id; 848 Decl_ARECnP : Node_Id; 849 -- Declaration nodes for the AREC entities we build 850 851 Uplevel_Entities : 852 array (1 .. List_Length (STJ.Urefs)) of Entity_Id; 853 Num_Uplevel_Entities : Nat; 854 -- Uplevel_Entities (1 .. Num_Uplevel_Entities) contains 855 -- a list (with no duplicates) of the entities for this 856 -- subprogram that are referenced uplevel. The maximum 857 -- number of entries cannot exceed the total number of 858 -- uplevel references. 859 860 begin 861 -- Populate the Uplevel_Entities array, using the flag 862 -- Uplevel_Reference_Noted to avoid duplicates. 863 864 Num_Uplevel_Entities := 0; 865 866 if Present (STJ.Urefs) then 867 Elmt := First_Elmt (STJ.Urefs); 868 while Present (Elmt) loop 869 Nod := Actual_Ref (Node (Elmt)); 870 Ent := Entity (Nod); 871 872 if not Uplevel_Reference_Noted (Ent) then 873 Set_Uplevel_Reference_Noted (Ent, True); 874 Num_Uplevel_Entities := Num_Uplevel_Entities + 1; 875 Uplevel_Entities (Num_Uplevel_Entities) := Ent; 876 end if; 877 878 Next_Elmt (Elmt); 879 Next_Elmt (Elmt); 880 end loop; 881 end if; 882 883 -- Build list of component declarations for ARECnT 884 885 Clist := Empty_List; 886 887 -- If we are in a subprogram that has a static link that 888 -- ias passed in (as indicated by ARECnF being deinfed), 889 -- then include ARECnU : ARECnPT := ARECnF where n is 890 -- one less than the current level and the entity ARECnPT 891 -- comes from the enclosing subprogram. 892 893 if Present (STJ.ARECnF) then 894 declare 895 STJE : Subp_Entry 896 renames Subps.Table (Enclosing_Subp (J)); 897 898 begin 899 Append_To (Clist, 900 Make_Component_Declaration (Loc, 901 Defining_Identifier => STJ.ARECnU, 902 Component_Definition => 903 Make_Component_Definition (Loc, 904 Subtype_Indication => 905 New_Occurrence_Of (STJE.ARECnPT, Loc)), 906 Expression => 907 New_Occurrence_Of (STJ.ARECnF, Loc))); 908 end; 909 end if; 910 911 -- Add components for uplevel referenced entities 912 913 for J in 1 .. Num_Uplevel_Entities loop 914 Comp := 915 Make_Defining_Identifier (Loc, 916 Chars => Chars (Uplevel_Entities (J))); 917 918 Set_Activation_Record_Component 919 (Uplevel_Entities (J), Comp); 920 921 Append_To (Clist, 922 Make_Component_Declaration (Loc, 923 Defining_Identifier => Comp, 924 Component_Definition => 925 Make_Component_Definition (Loc, 926 Subtype_Indication => 927 New_Occurrence_Of (Addr, Loc)))); 928 end loop; 929 930 -- Now we can insert the AREC declarations into the body 931 932 -- type ARECnT is record .. end record; 933 934 Decl_ARECnT := 935 Make_Full_Type_Declaration (Loc, 936 Defining_Identifier => STJ.ARECnT, 937 Type_Definition => 938 Make_Record_Definition (Loc, 939 Component_List => 940 Make_Component_List (Loc, 941 Component_Items => Clist))); 942 943 -- ARECn : aliased ARECnT; 944 945 Decl_ARECn := 946 Make_Object_Declaration (Loc, 947 Defining_Identifier => STJ.ARECn, 948 Aliased_Present => True, 949 Object_Definition => 950 New_Occurrence_Of (STJ.ARECnT, Loc)); 951 952 -- type ARECnPT is access all ARECnT; 953 954 Decl_ARECnPT := 955 Make_Full_Type_Declaration (Loc, 956 Defining_Identifier => STJ.ARECnPT, 957 Type_Definition => 958 Make_Access_To_Object_Definition (Loc, 959 All_Present => True, 960 Subtype_Indication => 961 New_Occurrence_Of (STJ.ARECnT, Loc))); 962 963 -- ARECnP : constant ARECnPT := ARECn'Access; 964 965 Decl_ARECnP := 966 Make_Object_Declaration (Loc, 967 Defining_Identifier => STJ.ARECnP, 968 Constant_Present => True, 969 Object_Definition => 970 New_Occurrence_Of (STJ.ARECnPT, Loc), 971 Expression => 972 Make_Attribute_Reference (Loc, 973 Prefix => 974 New_Occurrence_Of (STJ.ARECn, Loc), 975 Attribute_Name => Name_Access)); 976 977 Prepend_List_To (Declarations (STJ.Bod), 978 New_List 979 (Decl_ARECnT, Decl_ARECn, Decl_ARECnPT, Decl_ARECnP)); 980 981 -- Analyze the newly inserted declarations. Note that we 982 -- do not need to establish the whole scope stack, since 983 -- we have already set all entity fields (so there will 984 -- be no searching of upper scopes to resolve names). But 985 -- we do set the scope of the current subprogram, so that 986 -- newly created entities go in the right entity chain. 987 988 -- We analyze with all checks suppressed (since we do 989 -- not expect any exceptions, and also we temporarily 990 -- turn off Unested_Subprogram_Mode to avoid trying to 991 -- mark uplevel references (not needed at this stage, 992 -- and in fact causes a bit of recursive chaos). 993 994 Push_Scope (STJ.Ent); 995 Opt.Unnest_Subprogram_Mode := False; 996 Analyze (Decl_ARECnT, Suppress => All_Checks); 997 Analyze (Decl_ARECn, Suppress => All_Checks); 998 Analyze (Decl_ARECnPT, Suppress => All_Checks); 999 Analyze (Decl_ARECnP, Suppress => All_Checks); 1000 Opt.Unnest_Subprogram_Mode := True; 1001 Pop_Scope; 1002 1003 -- Next step, for each uplevel referenced entity, add 1004 -- assignment operations to set the comoponent in the 1005 -- activation record. 1006 1007 for J in 1 .. Num_Uplevel_Entities loop 1008 declare 1009 Ent : constant Entity_Id := Uplevel_Entities (J); 1010 Loc : constant Source_Ptr := Sloc (Ent); 1011 Dec : constant Node_Id := Declaration_Node (Ent); 1012 Ins : Node_Id; 1013 Asn : Node_Id; 1014 1015 begin 1016 -- For parameters, we insert the assignment right 1017 -- after the declaration of ARECnP. For all other 1018 -- entities, we insert the assignment immediately 1019 -- after the declaration of the entity. 1020 1021 -- Note: we don't need to mark the entity as being 1022 -- aliased, because the address attribute will mark 1023 -- it as Address_Taken, and that is good enough. 1024 1025 if Is_Formal (Ent) then 1026 Ins := Decl_ARECnP; 1027 else 1028 Ins := Dec; 1029 end if; 1030 1031 -- Build and insert the assignment: 1032 -- ARECn.nam := nam 1033 1034 Asn := 1035 Make_Assignment_Statement (Loc, 1036 Name => 1037 Make_Selected_Component (Loc, 1038 Prefix => 1039 New_Occurrence_Of (STJ.ARECn, Loc), 1040 Selector_Name => 1041 Make_Identifier (Loc, Chars (Ent))), 1042 1043 Expression => 1044 Make_Attribute_Reference (Loc, 1045 Prefix => 1046 New_Occurrence_Of (Ent, Loc), 1047 Attribute_Name => Name_Address)); 1048 1049 Insert_After (Ins, Asn); 1050 1051 -- Analyze the assignment statement. We do not need 1052 -- to establish the relevant scope stack entries 1053 -- here, because we have already set the correct 1054 -- entity references, so no name resolution is 1055 -- required, and no new entities are created, so 1056 -- we don't even need to set the current scope. 1057 1058 -- We analyze with all checks suppressed (since 1059 -- we do not expect any exceptions, and also we 1060 -- temporarily turn off Unested_Subprogram_Mode 1061 -- to avoid trying to mark uplevel references (not 1062 -- needed at this stage, and in fact causes a bit 1063 -- of recursive chaos). 1064 1065 Opt.Unnest_Subprogram_Mode := False; 1066 Analyze (Asn, Suppress => All_Checks); 1067 Opt.Unnest_Subprogram_Mode := True; 1068 end; 1069 end loop; 1070 end; 1071 end if; 1072 end; 1073 end loop; 1074 end Subp_Loop; 1075 1076 -- Next step, process uplevel references. This has to be done in a 1077 -- separate pass, after completing the processing in Sub_Loop because we 1078 -- need all the AREC declarations generated, inserted, and analyzed so 1079 -- that the uplevel references can be successfully analyzed. 1080 1081 Uplev_Refs : for J in Subps.First .. Subps.Last loop 1082 declare 1083 STJ : Subp_Entry renames Subps.Table (J); 1084 1085 begin 1086 -- We are only interested in entries which have uplevel references 1087 -- to deal with, as indicated by the Urefs list being present 1088 1089 if Present (STJ.Urefs) then 1090 1091 -- Process uplevel references for one subprogram 1092 1093 declare 1094 Elmt : Elmt_Id; 1095 1096 begin 1097 -- Loop through uplevel references 1098 1099 Elmt := First_Elmt (STJ.Urefs); 1100 while Present (Elmt) loop 1101 1102 -- Rewrite one reference 1103 1104 declare 1105 Ref : constant Node_Id := Actual_Ref (Node (Elmt)); 1106 -- The reference to be rewritten 1107 1108 Loc : constant Source_Ptr := Sloc (Ref); 1109 -- Source location for the reference 1110 1111 Ent : constant Entity_Id := Entity (Ref); 1112 -- The referenced entity 1113 1114 Typ : constant Entity_Id := Etype (Ent); 1115 -- The type of the referenced entity 1116 1117 Rsub : constant Entity_Id := 1118 Node (Next_Elmt (Elmt)); 1119 -- The enclosing subprogram for the reference 1120 1121 RSX : constant SI_Type := Subp_Index (Rsub); 1122 -- Subp_Index for enclosing subprogram for ref 1123 1124 STJR : Subp_Entry renames Subps.Table (RSX); 1125 -- Subp_Entry for enclosing subprogram for ref 1126 1127 Tnn : constant Entity_Id := 1128 Make_Temporary 1129 (Loc, 'T', Related_Node => Ref); 1130 -- Local pointer type for reference 1131 1132 Pfx : Node_Id; 1133 Comp : Entity_Id; 1134 SI : SI_Type; 1135 1136 begin 1137 -- Push the current scope, so that the pointer type 1138 -- Tnn, and any subsidiary entities resulting from 1139 -- the analysis of the rewritten reference, go in the 1140 -- right entity chain. 1141 1142 Push_Scope (STJR.Ent); 1143 1144 -- First insert declaration for pointer type 1145 1146 -- type Tnn is access all typ; 1147 1148 Insert_Action (Node (Elmt), 1149 Make_Full_Type_Declaration (Loc, 1150 Defining_Identifier => Tnn, 1151 Type_Definition => 1152 Make_Access_To_Object_Definition (Loc, 1153 All_Present => True, 1154 Subtype_Indication => 1155 New_Occurrence_Of (Typ, Loc)))); 1156 1157 -- Now we need to rewrite the reference. We have a 1158 -- reference is from level STJE.Lev to level STJ.Lev. 1159 -- The general form of the rewritten reference for 1160 -- entity X is: 1161 1162 -- Tnn!(ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X).all 1163 1164 -- where a,b,c,d .. m = 1165 -- STJR.Lev - 1, STJ.Lev - 2, .. STJ.Lev 1166 1167 pragma Assert (STJR.Lev > STJ.Lev); 1168 1169 -- Compute the prefix of X. Here are examples to make 1170 -- things clear (with parens to show groupings, the 1171 -- prefix is everything except the .X at the end). 1172 1173 -- level 2 to level 1 1174 1175 -- AREC1F.X 1176 1177 -- level 3 to level 1 1178 1179 -- (AREC2F.AREC1U).X 1180 1181 -- level 4 to level 1 1182 1183 -- ((AREC3F.AREC2U).AREC1U).X 1184 1185 -- level 6 to level 2 1186 1187 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X 1188 1189 Pfx := New_Occurrence_Of (STJR.ARECnF, Loc); 1190 SI := RSX; 1191 for L in STJ.Lev .. STJR.Lev - 2 loop 1192 SI := Enclosing_Subp (SI); 1193 Pfx := 1194 Make_Selected_Component (Loc, 1195 Prefix => Pfx, 1196 Selector_Name => 1197 New_Occurrence_Of 1198 (Subps.Table (SI).ARECnU, Loc)); 1199 end loop; 1200 1201 -- Get activation record component (must exist) 1202 1203 Comp := Activation_Record_Component (Ent); 1204 pragma Assert (Present (Comp)); 1205 1206 -- Do the replacement 1207 1208 Rewrite (Ref, 1209 Make_Explicit_Dereference (Loc, 1210 Prefix => 1211 Unchecked_Convert_To (Tnn, 1212 Make_Selected_Component (Loc, 1213 Prefix => Pfx, 1214 Selector_Name => 1215 New_Occurrence_Of (Comp, Loc))))); 1216 1217 -- Analyze and resolve the new expression. We do not 1218 -- need to establish the relevant scope stack entries 1219 -- here, because we have already set all the correct 1220 -- entity references, so no name resolution is needed. 1221 -- We have already set the current scope, so that any 1222 -- new entities created will be in the right scope. 1223 1224 -- We analyze with all checks suppressed (since we do 1225 -- not expect any exceptions, and also we temporarily 1226 -- turn off Unested_Subprogram_Mode to avoid trying to 1227 -- mark uplevel references (not needed at this stage, 1228 -- and in fact causes a bit of recursive chaos). 1229 1230 Opt.Unnest_Subprogram_Mode := False; 1231 Analyze_And_Resolve (Ref, Typ, Suppress => All_Checks); 1232 Opt.Unnest_Subprogram_Mode := True; 1233 Pop_Scope; 1234 end; 1235 1236 Next_Elmt (Elmt); 1237 Next_Elmt (Elmt); 1238 end loop; 1239 end; 1240 end if; 1241 end; 1242 end loop Uplev_Refs; 1243 1244 -- Finally, loop through all calls adding extra actual for the 1245 -- activation record where it is required. 1246 1247 Adjust_Calls : for J in Calls.First .. Calls.Last loop 1248 1249 -- Process a single call, we are only interested in a call to a 1250 -- subprogram that actually needs a pointer to an activation record, 1251 -- as indicated by the ARECnF entity being set. This excludes the 1252 -- top level subprogram, and any subprogram not having uplevel refs. 1253 1254 Adjust_One_Call : declare 1255 CTJ : Call_Entry renames Calls.Table (J); 1256 STF : Subp_Entry renames Subps.Table (Subp_Index (CTJ.From)); 1257 STT : Subp_Entry renames Subps.Table (Subp_Index (CTJ.To)); 1258 1259 Loc : constant Source_Ptr := Sloc (CTJ.N); 1260 1261 Extra : Node_Id; 1262 ExtraP : Node_Id; 1263 SubX : SI_Type; 1264 Act : Node_Id; 1265 1266 begin 1267 if Present (STT.ARECnF) then 1268 1269 -- CTJ.N is a call to a subprogram which may require 1270 -- a pointer to an activation record. The subprogram 1271 -- containing the call is CTJ.From and the subprogram being 1272 -- called is CTJ.To, so we have a call from level STF.Lev to 1273 -- level STT.Lev. 1274 1275 -- There are three possibilities: 1276 1277 -- For a call to the same level, we just pass the activation 1278 -- record passed to the calling subprogram. 1279 1280 if STF.Lev = STT.Lev then 1281 Extra := New_Occurrence_Of (STF.ARECnF, Loc); 1282 1283 -- For a call that goes down a level, we pass a pointer 1284 -- to the activation record constructed wtihin the caller 1285 -- (which may be the outer level subprogram, but also may 1286 -- be a more deeply nested caller). 1287 1288 elsif STT.Lev = STF.Lev + 1 then 1289 Extra := New_Occurrence_Of (STF.ARECnP, Loc); 1290 1291 -- Otherwise we must have an upcall (STT.Lev < STF.LEV), 1292 -- since it is not possible to do a downcall of more than 1293 -- one level. 1294 1295 -- For a call from level STF.Lev to level STT.Lev, we 1296 -- have to find the activation record needed by the 1297 -- callee. This is as follows: 1298 1299 -- ARECaF.ARECbU.ARECcU....ARECm 1300 1301 -- where a,b,c .. m = 1302 -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev 1303 1304 else 1305 pragma Assert (STT.Lev < STF.Lev); 1306 1307 Extra := New_Occurrence_Of (STF.ARECnF, Loc); 1308 SubX := Subp_Index (CTJ.From); 1309 for K in reverse STT.Lev .. STF.Lev - 1 loop 1310 SubX := Enclosing_Subp (SubX); 1311 Extra := 1312 Make_Selected_Component (Loc, 1313 Prefix => Extra, 1314 Selector_Name => 1315 New_Occurrence_Of 1316 (Subps.Table (SubX).ARECnU, Loc)); 1317 end loop; 1318 end if; 1319 1320 -- Extra is the additional parameter to be added. Build a 1321 -- parameter association that we can append to the actuals. 1322 1323 ExtraP := 1324 Make_Parameter_Association (Loc, 1325 Selector_Name => 1326 New_Occurrence_Of (STT.ARECnF, Loc), 1327 Explicit_Actual_Parameter => Extra); 1328 1329 if No (Parameter_Associations (CTJ.N)) then 1330 Set_Parameter_Associations (CTJ.N, Empty_List); 1331 end if; 1332 1333 Append (ExtraP, Parameter_Associations (CTJ.N)); 1334 1335 -- We need to deal with the actual parameter chain as well. 1336 -- The newly added parameter is always the last actual. 1337 1338 Act := First_Named_Actual (CTJ.N); 1339 1340 if No (Act) then 1341 Set_First_Named_Actual (CTJ.N, Extra); 1342 1343 -- Here we must follow the chain and append the new entry 1344 1345 else 1346 loop 1347 declare 1348 PAN : Node_Id; 1349 NNA : Node_Id; 1350 1351 begin 1352 PAN := Parent (Act); 1353 pragma Assert (Nkind (PAN) = N_Parameter_Association); 1354 NNA := Next_Named_Actual (PAN); 1355 1356 if No (NNA) then 1357 Set_Next_Named_Actual (PAN, Extra); 1358 exit; 1359 end if; 1360 1361 Act := NNA; 1362 end; 1363 end loop; 1364 end if; 1365 1366 -- Analyze and resolve the new actual. We do not need to 1367 -- establish the relevant scope stack entries here, because 1368 -- we have already set all the correct entity references, so 1369 -- no name resolution is needed. 1370 1371 -- We analyze with all checks suppressed (since we do not 1372 -- expect any exceptions, and also we temporarily turn off 1373 -- Unested_Subprogram_Mode to avoid trying to mark uplevel 1374 -- references (not needed at this stage, and in fact causes 1375 -- a bit of recursive chaos). 1376 1377 Opt.Unnest_Subprogram_Mode := False; 1378 Analyze_And_Resolve 1379 (Extra, Etype (STT.ARECnF), Suppress => All_Checks); 1380 Opt.Unnest_Subprogram_Mode := True; 1381 end if; 1382 end Adjust_One_Call; 1383 end loop Adjust_Calls; 1384 1385 return; 1386 end Unnest_Subprogram; 1387 1388end Exp_Unst; 1389