1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ C H 1 0 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-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 Aspects; use Aspects; 27with Atree; use Atree; 28with Contracts; use Contracts; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Errout; use Errout; 32with Exp_Util; use Exp_Util; 33with Elists; use Elists; 34with Fname; use Fname; 35with Fname.UF; use Fname.UF; 36with Freeze; use Freeze; 37with Ghost; use Ghost; 38with Impunit; use Impunit; 39with Inline; use Inline; 40with Lib; use Lib; 41with Lib.Load; use Lib.Load; 42with Lib.Xref; use Lib.Xref; 43with Namet; use Namet; 44with Nlists; use Nlists; 45with Nmake; use Nmake; 46with Opt; use Opt; 47with Output; use Output; 48with Par_SCO; use Par_SCO; 49with Restrict; use Restrict; 50with Rident; use Rident; 51with Rtsfind; use Rtsfind; 52with Sem; use Sem; 53with Sem_Aux; use Sem_Aux; 54with Sem_Ch3; use Sem_Ch3; 55with Sem_Ch6; use Sem_Ch6; 56with Sem_Ch7; use Sem_Ch7; 57with Sem_Ch8; use Sem_Ch8; 58with Sem_Dist; use Sem_Dist; 59with Sem_Prag; use Sem_Prag; 60with Sem_Util; use Sem_Util; 61with Sem_Warn; use Sem_Warn; 62with Stand; use Stand; 63with Sinfo; use Sinfo; 64with Sinfo.CN; use Sinfo.CN; 65with Sinput; use Sinput; 66with Snames; use Snames; 67with Style; use Style; 68with Stylesw; use Stylesw; 69with Tbuild; use Tbuild; 70with Uname; use Uname; 71 72package body Sem_Ch10 is 73 74 ----------------------- 75 -- Local Subprograms -- 76 ----------------------- 77 78 procedure Analyze_Context (N : Node_Id); 79 -- Analyzes items in the context clause of compilation unit 80 81 procedure Build_Limited_Views (N : Node_Id); 82 -- Build and decorate the list of shadow entities for a package mentioned 83 -- in a limited_with clause. If the package was not previously analyzed 84 -- then it also performs a basic decoration of the real entities. This is 85 -- required in order to avoid passing non-decorated entities to the 86 -- back-end. Implements Ada 2005 (AI-50217). 87 88 procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id); 89 -- Common processing for all stubs (subprograms, tasks, packages, and 90 -- protected cases). N is the stub to be analyzed. Once the subunit name 91 -- is established, load and analyze. Nam is the non-overloadable entity 92 -- for which the proper body provides a completion. Subprogram stubs are 93 -- handled differently because they can be declarations. 94 95 procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id); 96 -- Check whether the source for the body of a compilation unit must be 97 -- included in a standalone library. 98 99 procedure Check_No_Elab_Code_All (N : Node_Id); 100 -- Carries out possible tests for violation of No_Elab_Code all for withed 101 -- units in the Context_Items of unit N. 102 103 procedure Check_Private_Child_Unit (N : Node_Id); 104 -- If a with_clause mentions a private child unit, the compilation unit 105 -- must be a member of the same family, as described in 10.1.2. 106 107 procedure Check_Stub_Level (N : Node_Id); 108 -- Verify that a stub is declared immediately within a compilation unit, 109 -- and not in an inner frame. 110 111 procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id); 112 -- When a child unit appears in a context clause, the implicit withs on 113 -- parents are made explicit, and with clauses are inserted in the context 114 -- clause before the one for the child. If a parent in the with_clause 115 -- is a renaming, the implicit with_clause is on the renaming whose name 116 -- is mentioned in the with_clause, and not on the package it renames. 117 -- N is the compilation unit whose list of context items receives the 118 -- implicit with_clauses. 119 120 procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id); 121 -- Generate cross-reference information for the parents of child units 122 -- and of subunits. N is a defining_program_unit_name, and P_Id is the 123 -- immediate parent scope. 124 125 function Has_With_Clause 126 (C_Unit : Node_Id; 127 Pack : Entity_Id; 128 Is_Limited : Boolean := False) return Boolean; 129 -- Determine whether compilation unit C_Unit contains a [limited] with 130 -- clause for package Pack. Use the flag Is_Limited to designate desired 131 -- clause kind. 132 133 procedure Implicit_With_On_Parent (Child_Unit : Node_Id; N : Node_Id); 134 -- If the main unit is a child unit, implicit withs are also added for 135 -- all its ancestors. 136 137 function In_Chain (E : Entity_Id) return Boolean; 138 -- Check that the shadow entity is not already in the homonym chain, for 139 -- example through a limited_with clause in a parent unit. 140 141 procedure Install_Context_Clauses (N : Node_Id; Chain : Boolean := True); 142 -- Subsidiary to Install_Context and Install_Parents. Process all with 143 -- and use clauses for current unit and its library unit if any. The flag 144 -- Chain is used to control the "chaining" or linking together of use-type 145 -- and use-package clauses to avoid circularities with reinstalling 146 -- clauses. 147 148 procedure Install_Limited_Context_Clauses (N : Node_Id); 149 -- Subsidiary to Install_Context. Process only limited with_clauses for 150 -- current unit. Implements Ada 2005 (AI-50217). 151 152 procedure Install_Limited_Withed_Unit (N : Node_Id); 153 -- Place shadow entities for a limited_with package in the visibility 154 -- structures for the current compilation. Implements Ada 2005 (AI-50217). 155 156 procedure Install_Withed_Unit 157 (With_Clause : Node_Id; 158 Private_With_OK : Boolean := False); 159 -- If the unit is not a child unit, make unit immediately visible. The 160 -- caller ensures that the unit is not already currently installed. The 161 -- flag Private_With_OK is set true in Install_Private_With_Clauses, which 162 -- is called when compiling the private part of a package, or installing 163 -- the private declarations of a parent unit. 164 165 procedure Install_Parents 166 (Lib_Unit : Node_Id; 167 Is_Private : Boolean; 168 Chain : Boolean := True); 169 -- This procedure establishes the context for the compilation of a child 170 -- unit. If Lib_Unit is a child library spec then the context of the parent 171 -- is installed, and the parent itself made immediately visible, so that 172 -- the child unit is processed in the declarative region of the parent. 173 -- Install_Parents makes a recursive call to itself to ensure that all 174 -- parents are loaded in the nested case. If Lib_Unit is a library body, 175 -- the only effect of Install_Parents is to install the private decls of 176 -- the parents, because the visible parent declarations will have been 177 -- installed as part of the context of the corresponding spec. The flag 178 -- Chain is used to control the "chaining" or linking of use-type and 179 -- use-package clauses to avoid circularities when installing context. 180 181 procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id); 182 -- In the compilation of a child unit, a child of any of the ancestor 183 -- units is directly visible if it is visible, because the parent is in 184 -- an enclosing scope. Iterate over context to find child units of U_Name 185 -- or of some ancestor of it. 186 187 function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean; 188 -- When compiling a unit Q descended from some parent unit P, a limited 189 -- with_clause in the context of P that names some other ancestor of Q 190 -- must not be installed because the ancestor is immediately visible. 191 192 function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean; 193 -- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec 194 -- returns True if Lib_Unit is a library spec which is a child spec, i.e. 195 -- a library spec that has a parent. If the call to Is_Child_Spec returns 196 -- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the 197 -- compilation unit for the parent spec. 198 -- 199 -- Lib_Unit can also be a subprogram body that acts as its own spec. If the 200 -- Parent_Spec is non-empty, this is also a child unit. 201 202 procedure Remove_Context_Clauses (N : Node_Id); 203 -- Subsidiary of previous one. Remove use_ and with_clauses 204 205 procedure Remove_Limited_With_Clause (N : Node_Id); 206 -- Remove from visibility the shadow entities introduced for a package 207 -- mentioned in a limited_with clause. Implements Ada 2005 (AI-50217). 208 209 procedure Remove_Parents (Lib_Unit : Node_Id); 210 -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent 211 -- contexts established by the corresponding call to Install_Parents are 212 -- removed. Remove_Parents contains a recursive call to itself to ensure 213 -- that all parents are removed in the nested case. 214 215 procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id); 216 -- Reset all visibility flags on unit after compiling it, either as a main 217 -- unit or as a unit in the context. 218 219 procedure Unchain (E : Entity_Id); 220 -- Remove single entity from visibility list 221 222 procedure sm; 223 -- A dummy procedure, for debugging use, called just before analyzing the 224 -- main unit (after dealing with any context clauses). 225 226 -------------------------- 227 -- Limited_With_Clauses -- 228 -------------------------- 229 230 -- Limited_With clauses are the mechanism chosen for Ada 2005 to support 231 -- mutually recursive types declared in different units. A limited_with 232 -- clause that names package P in the context of unit U makes the types 233 -- declared in the visible part of P available within U, but with the 234 -- restriction that these types can only be used as incomplete types. 235 -- The limited_with clause does not impose a semantic dependence on P, 236 -- and it is possible for two packages to have limited_with_clauses on 237 -- each other without creating an elaboration circularity. 238 239 -- To support this feature, the analysis of a limited_with clause must 240 -- create an abbreviated view of the package, without performing any 241 -- semantic analysis on it. This "package abstract" contains shadow types 242 -- that are in one-one correspondence with the real types in the package, 243 -- and that have the properties of incomplete types. 244 245 -- The implementation creates two element lists: one to chain the shadow 246 -- entities, and one to chain the corresponding type entities in the tree 247 -- of the package. Links between corresponding entities in both chains 248 -- allow the compiler to select the proper view of a given type, depending 249 -- on the context. Note that in contrast with the handling of private 250 -- types, the limited view and the non-limited view of a type are treated 251 -- as separate entities, and no entity exchange needs to take place, which 252 -- makes the implementation much simpler than could be feared. 253 254 ------------------------------ 255 -- Analyze_Compilation_Unit -- 256 ------------------------------ 257 258 procedure Analyze_Compilation_Unit (N : Node_Id) is 259 procedure Check_Redundant_Withs 260 (Context_Items : List_Id; 261 Spec_Context_Items : List_Id := No_List); 262 -- Determine whether the context list of a compilation unit contains 263 -- redundant with clauses. When checking body clauses against spec 264 -- clauses, set Context_Items to the context list of the body and 265 -- Spec_Context_Items to that of the spec. Parent packages are not 266 -- examined for documentation purposes. 267 268 --------------------------- 269 -- Check_Redundant_Withs -- 270 --------------------------- 271 272 procedure Check_Redundant_Withs 273 (Context_Items : List_Id; 274 Spec_Context_Items : List_Id := No_List) 275 is 276 Clause : Node_Id; 277 278 procedure Process_Body_Clauses 279 (Context_List : List_Id; 280 Clause : Node_Id; 281 Used : out Boolean; 282 Used_Type_Or_Elab : out Boolean); 283 -- Examine the context clauses of a package body, trying to match the 284 -- name entity of Clause with any list element. If the match occurs 285 -- on a use package clause set Used to True, for a use type clause or 286 -- pragma Elaborate[_All], set Used_Type_Or_Elab to True. 287 288 procedure Process_Spec_Clauses 289 (Context_List : List_Id; 290 Clause : Node_Id; 291 Used : out Boolean; 292 Withed : out Boolean; 293 Exit_On_Self : Boolean := False); 294 -- Examine the context clauses of a package spec, trying to match 295 -- the name entity of Clause with any list element. If the match 296 -- occurs on a use package clause, set Used to True, for a with 297 -- package clause other than Clause, set Withed to True. Limited 298 -- with clauses, implicitly generated with clauses and withs 299 -- having pragmas Elaborate or Elaborate_All applied to them are 300 -- skipped. Exit_On_Self is used to control the search loop and 301 -- force an exit whenever Clause sees itself in the search. 302 303 -------------------------- 304 -- Process_Body_Clauses -- 305 -------------------------- 306 307 procedure Process_Body_Clauses 308 (Context_List : List_Id; 309 Clause : Node_Id; 310 Used : out Boolean; 311 Used_Type_Or_Elab : out Boolean) 312 is 313 Nam_Ent : constant Entity_Id := Entity (Name (Clause)); 314 Cont_Item : Node_Id; 315 Prag_Unit : Node_Id; 316 Subt_Mark : Node_Id; 317 Use_Item : Node_Id; 318 319 function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean; 320 -- In an expanded name in a use clause, if the prefix is a renamed 321 -- package, the entity is set to the original package as a result, 322 -- when checking whether the package appears in a previous with 323 -- clause, the renaming has to be taken into account, to prevent 324 -- spurious/incorrect warnings. A common case is use of Text_IO. 325 326 --------------- 327 -- Same_Unit -- 328 --------------- 329 330 function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean is 331 begin 332 return Entity (N) = P 333 or else (Present (Renamed_Object (P)) 334 and then Entity (N) = Renamed_Object (P)); 335 end Same_Unit; 336 337 -- Start of processing for Process_Body_Clauses 338 339 begin 340 Used := False; 341 Used_Type_Or_Elab := False; 342 343 Cont_Item := First (Context_List); 344 while Present (Cont_Item) loop 345 346 -- Package use clause 347 348 if Nkind (Cont_Item) = N_Use_Package_Clause 349 and then not Used 350 then 351 -- Search through use clauses 352 353 Use_Item := Name (Cont_Item); 354 355 -- Case of a direct use of the one we are looking for 356 357 if Entity (Use_Item) = Nam_Ent then 358 Used := True; 359 360 -- Handle nested case, as in "with P; use P.Q.R" 361 362 else 363 declare 364 UE : Node_Id; 365 366 begin 367 -- Loop through prefixes looking for match 368 369 UE := Use_Item; 370 while Nkind (UE) = N_Expanded_Name loop 371 if Same_Unit (Prefix (UE), Nam_Ent) then 372 Used := True; 373 exit; 374 end if; 375 376 UE := Prefix (UE); 377 end loop; 378 end; 379 end if; 380 381 -- USE TYPE clause 382 383 elsif Nkind (Cont_Item) = N_Use_Type_Clause 384 and then not Used_Type_Or_Elab 385 then 386 Subt_Mark := Subtype_Mark (Cont_Item); 387 if not Used_Type_Or_Elab 388 and then Same_Unit (Prefix (Subt_Mark), Nam_Ent) 389 then 390 Used_Type_Or_Elab := True; 391 end if; 392 393 -- Pragma Elaborate or Elaborate_All 394 395 elsif Nkind (Cont_Item) = N_Pragma 396 and then 397 Nam_In (Pragma_Name_Unmapped (Cont_Item), 398 Name_Elaborate, Name_Elaborate_All) 399 and then not Used_Type_Or_Elab 400 then 401 Prag_Unit := 402 First (Pragma_Argument_Associations (Cont_Item)); 403 while Present (Prag_Unit) and then not Used_Type_Or_Elab loop 404 if Entity (Expression (Prag_Unit)) = Nam_Ent then 405 Used_Type_Or_Elab := True; 406 end if; 407 408 Next (Prag_Unit); 409 end loop; 410 end if; 411 412 Next (Cont_Item); 413 end loop; 414 end Process_Body_Clauses; 415 416 -------------------------- 417 -- Process_Spec_Clauses -- 418 -------------------------- 419 420 procedure Process_Spec_Clauses 421 (Context_List : List_Id; 422 Clause : Node_Id; 423 Used : out Boolean; 424 Withed : out Boolean; 425 Exit_On_Self : Boolean := False) 426 is 427 Nam_Ent : constant Entity_Id := Entity (Name (Clause)); 428 Cont_Item : Node_Id; 429 430 begin 431 Used := False; 432 Withed := False; 433 434 Cont_Item := First (Context_List); 435 while Present (Cont_Item) loop 436 437 -- Stop the search since the context items after Cont_Item have 438 -- already been examined in a previous iteration of the reverse 439 -- loop in Check_Redundant_Withs. 440 441 if Exit_On_Self 442 and Cont_Item = Clause 443 then 444 exit; 445 end if; 446 447 -- Package use clause 448 449 if Nkind (Cont_Item) = N_Use_Package_Clause 450 and then not Used 451 then 452 if Entity (Name (Cont_Item)) = Nam_Ent then 453 Used := True; 454 end if; 455 456 -- Package with clause. Avoid processing self, implicitly 457 -- generated with clauses or limited with clauses. Note that 458 -- we examine with clauses having pragmas Elaborate or 459 -- Elaborate_All applied to them due to cases such as: 460 461 -- with Pack; 462 -- with Pack; 463 -- pragma Elaborate (Pack); 464 465 -- In this case, the second with clause is redundant since 466 -- the pragma applies only to the first "with Pack;". 467 468 -- Note that we only consider with_clauses that comes from 469 -- source. In the case of renamings used as prefixes of names 470 -- in with_clauses, we generate a with_clause for the prefix, 471 -- which we do not treat as implicit because it is needed for 472 -- visibility analysis, but is also not redundant. 473 474 elsif Nkind (Cont_Item) = N_With_Clause 475 and then Comes_From_Source (Cont_Item) 476 and then not Implicit_With (Cont_Item) 477 and then not Limited_Present (Cont_Item) 478 and then Cont_Item /= Clause 479 and then Entity (Name (Cont_Item)) = Nam_Ent 480 then 481 Withed := True; 482 end if; 483 484 Next (Cont_Item); 485 end loop; 486 end Process_Spec_Clauses; 487 488 -- Start of processing for Check_Redundant_Withs 489 490 begin 491 Clause := Last (Context_Items); 492 while Present (Clause) loop 493 494 -- Avoid checking implicitly generated with clauses, limited with 495 -- clauses or withs that have pragma Elaborate or Elaborate_All. 496 497 if Nkind (Clause) = N_With_Clause 498 and then not Implicit_With (Clause) 499 and then not Limited_Present (Clause) 500 and then not Elaborate_Present (Clause) 501 502 -- With_clauses introduced for renamings of parent clauses 503 -- are not marked implicit because they need to be properly 504 -- installed, but they do not come from source and do not 505 -- require warnings. 506 507 and then Comes_From_Source (Clause) 508 then 509 -- Package body-to-spec check 510 511 if Present (Spec_Context_Items) then 512 declare 513 Used_In_Body : Boolean; 514 Used_In_Spec : Boolean; 515 Used_Type_Or_Elab : Boolean; 516 Withed_In_Spec : Boolean; 517 518 begin 519 Process_Spec_Clauses 520 (Context_List => Spec_Context_Items, 521 Clause => Clause, 522 Used => Used_In_Spec, 523 Withed => Withed_In_Spec); 524 525 Process_Body_Clauses 526 (Context_List => Context_Items, 527 Clause => Clause, 528 Used => Used_In_Body, 529 Used_Type_Or_Elab => Used_Type_Or_Elab); 530 531 -- "Type Elab" refers to the presence of either a use 532 -- type clause, pragmas Elaborate or Elaborate_All. 533 534 -- +---------------+---------------------------+------+ 535 -- | Spec | Body | Warn | 536 -- +--------+------+--------+------+-----------+------+ 537 -- | Withed | Used | Withed | Used | Type Elab | | 538 -- | X | | X | | | X | 539 -- | X | | X | X | | | 540 -- | X | | X | | X | | 541 -- | X | | X | X | X | | 542 -- | X | X | X | | | X | 543 -- | X | X | X | | X | | 544 -- | X | X | X | X | | X | 545 -- | X | X | X | X | X | | 546 -- +--------+------+--------+------+-----------+------+ 547 548 if (Withed_In_Spec 549 and then not Used_Type_Or_Elab) 550 and then 551 ((not Used_In_Spec and then not Used_In_Body) 552 or else Used_In_Spec) 553 then 554 Error_Msg_N -- CODEFIX 555 ("redundant with clause in body?r?", Clause); 556 end if; 557 558 Used_In_Body := False; 559 Used_In_Spec := False; 560 Used_Type_Or_Elab := False; 561 Withed_In_Spec := False; 562 end; 563 564 -- Standalone package spec or body check 565 566 else 567 declare 568 Dummy : Boolean := False; 569 Withed : Boolean := False; 570 571 begin 572 -- The mechanism for examining the context clauses of a 573 -- package spec can be applied to package body clauses. 574 575 Process_Spec_Clauses 576 (Context_List => Context_Items, 577 Clause => Clause, 578 Used => Dummy, 579 Withed => Withed, 580 Exit_On_Self => True); 581 582 if Withed then 583 Error_Msg_N -- CODEFIX 584 ("redundant with clause?r?", Clause); 585 end if; 586 end; 587 end if; 588 end if; 589 590 Prev (Clause); 591 end loop; 592 end Check_Redundant_Withs; 593 594 -- Local variables 595 596 Main_Cunit : constant Node_Id := Cunit (Main_Unit); 597 Unit_Node : constant Node_Id := Unit (N); 598 Lib_Unit : Node_Id := Library_Unit (N); 599 Par_Spec_Name : Unit_Name_Type; 600 Spec_Id : Entity_Id; 601 Unum : Unit_Number_Type; 602 603 -- Start of processing for Analyze_Compilation_Unit 604 605 begin 606 Process_Compilation_Unit_Pragmas (N); 607 608 -- If the unit is a subunit whose parent has not been analyzed (which 609 -- indicates that the main unit is a subunit, either the current one or 610 -- one of its descendants) then the subunit is compiled as part of the 611 -- analysis of the parent, which we proceed to do. Basically this gets 612 -- handled from the top down and we don't want to do anything at this 613 -- level (i.e. this subunit will be handled on the way down from the 614 -- parent), so at this level we immediately return. If the subunit ends 615 -- up not analyzed, it means that the parent did not contain a stub for 616 -- it, or that there errors were detected in some ancestor. 617 618 if Nkind (Unit_Node) = N_Subunit and then not Analyzed (Lib_Unit) then 619 Semantics (Lib_Unit); 620 621 if not Analyzed (Proper_Body (Unit_Node)) then 622 if Serious_Errors_Detected > 0 then 623 Error_Msg_N ("subunit not analyzed (errors in parent unit)", N); 624 else 625 Error_Msg_N ("missing stub for subunit", N); 626 end if; 627 end if; 628 629 return; 630 end if; 631 632 -- Analyze context (this will call Sem recursively for with'ed units) To 633 -- detect circularities among with-clauses that are not caught during 634 -- loading, we set the Context_Pending flag on the current unit. If the 635 -- flag is already set there is a potential circularity. We exclude 636 -- predefined units from this check because they are known to be safe. 637 -- We also exclude package bodies that are present because circularities 638 -- between bodies are harmless (and necessary). 639 640 if Context_Pending (N) then 641 declare 642 Circularity : Boolean := True; 643 644 begin 645 if In_Predefined_Unit (N) then 646 Circularity := False; 647 648 else 649 for U in Main_Unit + 1 .. Last_Unit loop 650 if Nkind (Unit (Cunit (U))) = N_Package_Body 651 and then not Analyzed (Cunit (U)) 652 then 653 Circularity := False; 654 exit; 655 end if; 656 end loop; 657 end if; 658 659 if Circularity then 660 Error_Msg_N ("circular dependency caused by with_clauses", N); 661 Error_Msg_N 662 ("\possibly missing limited_with clause" 663 & " in one of the following", N); 664 665 for U in Main_Unit .. Last_Unit loop 666 if Context_Pending (Cunit (U)) then 667 Error_Msg_Unit_1 := Get_Unit_Name (Unit (Cunit (U))); 668 Error_Msg_N ("\unit$", N); 669 end if; 670 end loop; 671 672 raise Unrecoverable_Error; 673 end if; 674 end; 675 else 676 Set_Context_Pending (N); 677 end if; 678 679 Analyze_Context (N); 680 681 Set_Context_Pending (N, False); 682 683 -- If the unit is a package body, the spec is already loaded and must be 684 -- analyzed first, before we analyze the body. 685 686 if Nkind (Unit_Node) = N_Package_Body then 687 688 -- If no Lib_Unit, then there was a serious previous error, so just 689 -- ignore the entire analysis effort. 690 691 if No (Lib_Unit) then 692 Check_Error_Detected; 693 return; 694 695 else 696 -- Analyze the package spec 697 698 Semantics (Lib_Unit); 699 700 -- Check for unused with's 701 702 Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit)); 703 704 -- Verify that the library unit is a package declaration 705 706 if not Nkind_In (Unit (Lib_Unit), N_Package_Declaration, 707 N_Generic_Package_Declaration) 708 then 709 Error_Msg_N 710 ("no legal package declaration for package body", N); 711 return; 712 713 -- Otherwise, the entity in the declaration is visible. Update the 714 -- version to reflect dependence of this body on the spec. 715 716 else 717 Spec_Id := Defining_Entity (Unit (Lib_Unit)); 718 Set_Is_Immediately_Visible (Spec_Id, True); 719 Version_Update (N, Lib_Unit); 720 721 if Nkind (Defining_Unit_Name (Unit_Node)) = 722 N_Defining_Program_Unit_Name 723 then 724 Generate_Parent_References (Unit_Node, Scope (Spec_Id)); 725 end if; 726 end if; 727 end if; 728 729 -- If the unit is a subprogram body, then we similarly need to analyze 730 -- its spec. However, things are a little simpler in this case, because 731 -- here, this analysis is done mostly for error checking and consistency 732 -- purposes (but not only, e.g. there could be a contract on the spec), 733 -- so there's nothing else to be done. 734 735 elsif Nkind (Unit_Node) = N_Subprogram_Body then 736 if Acts_As_Spec (N) then 737 738 -- If the subprogram body is a child unit, we must create a 739 -- declaration for it, in order to properly load the parent(s). 740 -- After this, the original unit does not acts as a spec, because 741 -- there is an explicit one. If this unit appears in a context 742 -- clause, then an implicit with on the parent will be added when 743 -- installing the context. If this is the main unit, there is no 744 -- Unit_Table entry for the declaration (it has the unit number 745 -- of the main unit) and code generation is unaffected. 746 747 Unum := Get_Cunit_Unit_Number (N); 748 Par_Spec_Name := Get_Parent_Spec_Name (Unit_Name (Unum)); 749 750 if Par_Spec_Name /= No_Unit_Name then 751 Unum := 752 Load_Unit 753 (Load_Name => Par_Spec_Name, 754 Required => True, 755 Subunit => False, 756 Error_Node => N); 757 758 if Unum /= No_Unit then 759 760 -- Build subprogram declaration and attach parent unit to it 761 -- This subprogram declaration does not come from source, 762 -- Nevertheless the backend must generate debugging info for 763 -- it, and this must be indicated explicitly. We also mark 764 -- the body entity as a child unit now, to prevent a 765 -- cascaded error if the spec entity cannot be entered 766 -- in its scope. Finally we create a Units table entry for 767 -- the subprogram declaration, to maintain a one-to-one 768 -- correspondence with compilation unit nodes. This is 769 -- critical for the tree traversals performed by CodePeer. 770 771 declare 772 Loc : constant Source_Ptr := Sloc (N); 773 SCS : constant Boolean := 774 Get_Comes_From_Source_Default; 775 776 begin 777 Set_Comes_From_Source_Default (False); 778 779 -- Note: We copy the Context_Items from the explicit body 780 -- to the implicit spec, setting the former to Empty_List 781 -- to preserve the treeish nature of the tree, during 782 -- analysis of the spec. Then we put it back the way it 783 -- was -- copy the Context_Items from the spec to the 784 -- body, and set the spec Context_Items to Empty_List. 785 -- It is necessary to preserve the treeish nature, 786 -- because otherwise we will call End_Use_* twice on the 787 -- same thing. 788 789 Lib_Unit := 790 Make_Compilation_Unit (Loc, 791 Context_Items => Context_Items (N), 792 Unit => 793 Make_Subprogram_Declaration (Sloc (N), 794 Specification => 795 Copy_Separate_Tree 796 (Specification (Unit_Node))), 797 Aux_Decls_Node => 798 Make_Compilation_Unit_Aux (Loc)); 799 800 Set_Context_Items (N, Empty_List); 801 Set_Library_Unit (N, Lib_Unit); 802 Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum)); 803 Make_Child_Decl_Unit (N); 804 Semantics (Lib_Unit); 805 806 -- Now that a separate declaration exists, the body 807 -- of the child unit does not act as spec any longer. 808 809 Set_Acts_As_Spec (N, False); 810 Set_Is_Child_Unit (Defining_Entity (Unit_Node)); 811 Set_Debug_Info_Needed (Defining_Entity (Unit (Lib_Unit))); 812 Set_Comes_From_Source_Default (SCS); 813 814 -- Restore Context_Items to the body 815 816 Set_Context_Items (N, Context_Items (Lib_Unit)); 817 Set_Context_Items (Lib_Unit, Empty_List); 818 end; 819 end if; 820 end if; 821 822 -- Here for subprogram with separate declaration 823 824 else 825 Semantics (Lib_Unit); 826 Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit)); 827 Version_Update (N, Lib_Unit); 828 end if; 829 830 -- If this is a child unit, generate references to the parents 831 832 if Nkind (Defining_Unit_Name (Specification (Unit_Node))) = 833 N_Defining_Program_Unit_Name 834 then 835 Generate_Parent_References 836 (Specification (Unit_Node), 837 Scope (Defining_Entity (Unit (Lib_Unit)))); 838 end if; 839 end if; 840 841 -- If it is a child unit, the parent must be elaborated first and we 842 -- update version, since we are dependent on our parent. 843 844 if Is_Child_Spec (Unit_Node) then 845 846 -- The analysis of the parent is done with style checks off 847 848 declare 849 Save_Style_Check : constant Boolean := Style_Check; 850 851 begin 852 if not GNAT_Mode then 853 Style_Check := False; 854 end if; 855 856 Semantics (Parent_Spec (Unit_Node)); 857 Version_Update (N, Parent_Spec (Unit_Node)); 858 859 -- Restore style check settings 860 861 Style_Check := Save_Style_Check; 862 end; 863 end if; 864 865 -- With the analysis done, install the context. Note that we can't 866 -- install the context from the with clauses as we analyze them, because 867 -- each with clause must be analyzed in a clean visibility context, so 868 -- we have to wait and install them all at once. 869 870 Install_Context (N); 871 872 if Is_Child_Spec (Unit_Node) then 873 874 -- Set the entities of all parents in the program_unit_name 875 876 Generate_Parent_References 877 (Unit_Node, Get_Parent_Entity (Unit (Parent_Spec (Unit_Node)))); 878 end if; 879 880 -- All components of the context: with-clauses, library unit, ancestors 881 -- if any, (and their context) are analyzed and installed. 882 883 -- Call special debug routine sm if this is the main unit 884 885 if Current_Sem_Unit = Main_Unit then 886 sm; 887 end if; 888 889 -- Now analyze the unit (package, subprogram spec, body) itself 890 891 Analyze (Unit_Node); 892 893 if Warn_On_Redundant_Constructs then 894 Check_Redundant_Withs (Context_Items (N)); 895 896 if Nkind (Unit_Node) = N_Package_Body then 897 Check_Redundant_Withs 898 (Context_Items => Context_Items (N), 899 Spec_Context_Items => Context_Items (Lib_Unit)); 900 end if; 901 end if; 902 903 -- The above call might have made Unit_Node an N_Subprogram_Body from 904 -- something else, so propagate any Acts_As_Spec flag. 905 906 if Nkind (Unit_Node) = N_Subprogram_Body 907 and then Acts_As_Spec (Unit_Node) 908 then 909 Set_Acts_As_Spec (N); 910 end if; 911 912 -- Register predefined units in Rtsfind 913 914 if In_Predefined_Unit (N) then 915 Set_RTU_Loaded (Unit_Node); 916 end if; 917 918 -- Treat compilation unit pragmas that appear after the library unit 919 920 if Present (Pragmas_After (Aux_Decls_Node (N))) then 921 declare 922 Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N))); 923 begin 924 while Present (Prag_Node) loop 925 Analyze (Prag_Node); 926 Next (Prag_Node); 927 end loop; 928 end; 929 end if; 930 931 -- Analyze the contract of a [generic] subprogram that acts as a 932 -- compilation unit after all compilation pragmas have been analyzed. 933 934 if Nkind_In (Unit_Node, N_Generic_Subprogram_Declaration, 935 N_Subprogram_Declaration) 936 then 937 Analyze_Entry_Or_Subprogram_Contract (Defining_Entity (Unit_Node)); 938 end if; 939 940 -- Generate distribution stubs if requested and no error 941 942 if N = Main_Cunit 943 and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body 944 or else 945 Distribution_Stub_Mode = Generate_Caller_Stub_Body) 946 and then Fatal_Error (Main_Unit) /= Error_Detected 947 then 948 if Is_RCI_Pkg_Spec_Or_Body (N) then 949 950 -- Regular RCI package 951 952 Add_Stub_Constructs (N); 953 954 elsif (Nkind (Unit_Node) = N_Package_Declaration 955 and then Is_Shared_Passive (Defining_Entity 956 (Specification (Unit_Node)))) 957 or else (Nkind (Unit_Node) = N_Package_Body 958 and then 959 Is_Shared_Passive (Corresponding_Spec (Unit_Node))) 960 then 961 -- Shared passive package 962 963 Add_Stub_Constructs (N); 964 965 elsif Nkind (Unit_Node) = N_Package_Instantiation 966 and then 967 Is_Remote_Call_Interface 968 (Defining_Entity (Specification (Instance_Spec (Unit_Node)))) 969 then 970 -- Instantiation of a RCI generic package 971 972 Add_Stub_Constructs (N); 973 end if; 974 end if; 975 976 -- Remove unit from visibility, so that environment is clean for the 977 -- next compilation, which is either the main unit or some other unit 978 -- in the context. 979 980 if Nkind_In (Unit_Node, N_Package_Declaration, 981 N_Package_Renaming_Declaration, 982 N_Subprogram_Declaration) 983 or else Nkind (Unit_Node) in N_Generic_Declaration 984 or else (Nkind (Unit_Node) = N_Subprogram_Body 985 and then Acts_As_Spec (Unit_Node)) 986 then 987 Remove_Unit_From_Visibility (Defining_Entity (Unit_Node)); 988 989 -- If the unit is an instantiation whose body will be elaborated for 990 -- inlining purposes, use the proper entity of the instance. The entity 991 -- may be missing if the instantiation was illegal. 992 993 elsif Nkind (Unit_Node) = N_Package_Instantiation 994 and then not Error_Posted (Unit_Node) 995 and then Present (Instance_Spec (Unit_Node)) 996 then 997 Remove_Unit_From_Visibility 998 (Defining_Entity (Instance_Spec (Unit_Node))); 999 1000 elsif Nkind (Unit_Node) = N_Package_Body 1001 or else (Nkind (Unit_Node) = N_Subprogram_Body 1002 and then not Acts_As_Spec (Unit_Node)) 1003 then 1004 -- Bodies that are not the main unit are compiled if they are generic 1005 -- or contain generic or inlined units. Their analysis brings in the 1006 -- context of the corresponding spec (unit declaration) which must be 1007 -- removed as well, to return the compilation environment to its 1008 -- proper state. 1009 1010 Remove_Context (Lib_Unit); 1011 Set_Is_Immediately_Visible (Defining_Entity (Unit (Lib_Unit)), False); 1012 end if; 1013 1014 -- Last step is to deinstall the context we just installed as well as 1015 -- the unit just compiled. 1016 1017 Remove_Context (N); 1018 1019 -- When generating code for a non-generic main unit, check that withed 1020 -- generic units have a body if they need it, even if the units have not 1021 -- been instantiated. Force the load of the bodies to produce the proper 1022 -- error if the body is absent. The same applies to GNATprove mode, with 1023 -- the added benefit of capturing global references within the generic. 1024 -- This in turn allows for proper inlining of subprogram bodies without 1025 -- a previous declaration. 1026 1027 if Get_Cunit_Unit_Number (N) = Main_Unit 1028 and then ((Operating_Mode = Generate_Code and then Expander_Active) 1029 or else 1030 (Operating_Mode = Check_Semantics and then GNATprove_Mode)) 1031 then 1032 -- Check whether the source for the body of the unit must be included 1033 -- in a standalone library. 1034 1035 Check_Body_Needed_For_SAL (Cunit_Entity (Main_Unit)); 1036 1037 -- Indicate that the main unit is now analyzed, to catch possible 1038 -- circularities between it and generic bodies. Remove main unit from 1039 -- visibility. This might seem superfluous, but the main unit must 1040 -- not be visible in the generic body expansions that follow. 1041 1042 Set_Analyzed (N, True); 1043 Set_Is_Immediately_Visible (Cunit_Entity (Main_Unit), False); 1044 1045 declare 1046 Item : Node_Id; 1047 Nam : Entity_Id; 1048 Un : Unit_Number_Type; 1049 1050 Save_Style_Check : constant Boolean := Style_Check; 1051 1052 begin 1053 Item := First (Context_Items (N)); 1054 while Present (Item) loop 1055 1056 -- Check for explicit with clause 1057 1058 if Nkind (Item) = N_With_Clause 1059 and then not Implicit_With (Item) 1060 1061 -- Ada 2005 (AI-50217): Ignore limited-withed units 1062 1063 and then not Limited_Present (Item) 1064 then 1065 Nam := Entity (Name (Item)); 1066 1067 -- Compile the generic subprogram, unless it is intrinsic or 1068 -- imported so no body is required, or generic package body 1069 -- if the package spec requires a body. 1070 1071 if (Is_Generic_Subprogram (Nam) 1072 and then not Is_Intrinsic_Subprogram (Nam) 1073 and then not Is_Imported (Nam)) 1074 or else (Ekind (Nam) = E_Generic_Package 1075 and then Unit_Requires_Body (Nam)) 1076 then 1077 Style_Check := False; 1078 1079 if Present (Renamed_Object (Nam)) then 1080 Un := 1081 Load_Unit 1082 (Load_Name => 1083 Get_Body_Name 1084 (Get_Unit_Name 1085 (Unit_Declaration_Node 1086 (Renamed_Object (Nam)))), 1087 Required => False, 1088 Subunit => False, 1089 Error_Node => N, 1090 Renamings => True); 1091 else 1092 Un := 1093 Load_Unit 1094 (Load_Name => 1095 Get_Body_Name (Get_Unit_Name (Item)), 1096 Required => False, 1097 Subunit => False, 1098 Error_Node => N, 1099 Renamings => True); 1100 end if; 1101 1102 if Un = No_Unit then 1103 Error_Msg_NE 1104 ("body of generic unit& not found", Item, Nam); 1105 exit; 1106 1107 elsif not Analyzed (Cunit (Un)) 1108 and then Un /= Main_Unit 1109 and then Fatal_Error (Un) /= Error_Detected 1110 then 1111 Style_Check := False; 1112 Semantics (Cunit (Un)); 1113 end if; 1114 end if; 1115 end if; 1116 1117 Next (Item); 1118 end loop; 1119 1120 -- Restore style checks settings 1121 1122 Style_Check := Save_Style_Check; 1123 end; 1124 1125 -- In GNATprove mode, force the loading of an Interrupt_Priority when 1126 -- processing compilation units with potentially "main" subprograms. 1127 -- This is required for the ceiling priority protocol checks, which 1128 -- are triggered by these subprograms. 1129 1130 if GNATprove_Mode 1131 and then Nkind_In (Unit_Node, N_Function_Instantiation, 1132 N_Procedure_Instantiation, 1133 N_Subprogram_Body) 1134 then 1135 declare 1136 Spec : Node_Id; 1137 1138 begin 1139 case Nkind (Unit_Node) is 1140 when N_Subprogram_Body => 1141 Spec := Specification (Unit_Node); 1142 1143 when N_Subprogram_Instantiation => 1144 Spec := 1145 Subprogram_Specification (Entity (Name (Unit_Node))); 1146 1147 when others => 1148 raise Program_Error; 1149 end case; 1150 1151 pragma Assert (Nkind (Spec) in N_Subprogram_Specification); 1152 1153 -- Main subprogram must have no parameters, and if it is a 1154 -- function, it must return an integer. 1155 1156 if No (Parameter_Specifications (Spec)) 1157 and then (Nkind (Spec) = N_Procedure_Specification 1158 or else 1159 Is_Integer_Type (Etype (Result_Definition (Spec)))) 1160 then 1161 SPARK_Implicit_Load (RE_Interrupt_Priority); 1162 end if; 1163 end; 1164 end if; 1165 end if; 1166 1167 -- Deal with creating elaboration counter if needed. We create an 1168 -- elaboration counter only for units that come from source since 1169 -- units manufactured by the compiler never need elab checks. 1170 1171 if Comes_From_Source (N) 1172 and then Nkind_In (Unit_Node, N_Package_Declaration, 1173 N_Generic_Package_Declaration, 1174 N_Subprogram_Declaration, 1175 N_Generic_Subprogram_Declaration) 1176 then 1177 declare 1178 Loc : constant Source_Ptr := Sloc (N); 1179 Unum : constant Unit_Number_Type := Get_Source_Unit (Loc); 1180 1181 begin 1182 Spec_Id := Defining_Entity (Unit_Node); 1183 Generate_Definition (Spec_Id); 1184 1185 -- See if an elaboration entity is required for possible access 1186 -- before elaboration checking. Note that we must allow for this 1187 -- even if -gnatE is not set, since a client may be compiled in 1188 -- -gnatE mode and reference the entity. 1189 1190 -- These entities are also used by the binder to prevent multiple 1191 -- attempts to execute the elaboration code for the library case 1192 -- where the elaboration routine might otherwise be called more 1193 -- than once. 1194 1195 -- They are also needed to ensure explicit visibility from the 1196 -- binder generated code of all the units involved in a partition 1197 -- when control-flow preservation is requested. 1198 1199 -- Case of units which do not require an elaboration entity 1200 1201 if not Opt.Suppress_Control_Flow_Optimizations 1202 and then 1203 ( -- Pure units do not need checks 1204 1205 Is_Pure (Spec_Id) 1206 1207 -- Preelaborated units do not need checks 1208 1209 or else Is_Preelaborated (Spec_Id) 1210 1211 -- No checks needed if pragma Elaborate_Body present 1212 1213 or else Has_Pragma_Elaborate_Body (Spec_Id) 1214 1215 -- No checks needed if unit does not require a body 1216 1217 or else not Unit_Requires_Body (Spec_Id) 1218 1219 -- No checks needed for predefined files 1220 1221 or else Is_Predefined_Unit (Unum) 1222 1223 -- No checks required if no separate spec 1224 1225 or else Acts_As_Spec (N) 1226 ) 1227 then 1228 -- This is a case where we only need the entity for 1229 -- checking to prevent multiple elaboration checks. 1230 1231 Set_Elaboration_Entity_Required (Spec_Id, False); 1232 1233 -- Case of elaboration entity is required for access before 1234 -- elaboration checking (so certainly we must build it). 1235 1236 else 1237 Set_Elaboration_Entity_Required (Spec_Id, True); 1238 end if; 1239 1240 Build_Elaboration_Entity (N, Spec_Id); 1241 end; 1242 end if; 1243 1244 -- Freeze the compilation unit entity. This for sure is needed because 1245 -- of some warnings that can be output (see Freeze_Subprogram), but may 1246 -- in general be required. If freezing actions result, place them in the 1247 -- compilation unit actions list, and analyze them. 1248 1249 declare 1250 L : constant List_Id := 1251 Freeze_Entity (Cunit_Entity (Current_Sem_Unit), N); 1252 begin 1253 while Is_Non_Empty_List (L) loop 1254 Insert_Library_Level_Action (Remove_Head (L)); 1255 end loop; 1256 end; 1257 1258 Set_Analyzed (N); 1259 1260 -- Call Check_Package_Body so that a body containing subprograms with 1261 -- Inline_Always can be made available for front end inlining. 1262 1263 if Nkind (Unit_Node) = N_Package_Declaration 1264 and then Get_Cunit_Unit_Number (N) /= Main_Unit 1265 1266 -- We don't need to do this if the Expander is not active, since there 1267 -- is no code to inline. 1268 1269 and then Expander_Active 1270 then 1271 declare 1272 Save_Style_Check : constant Boolean := Style_Check; 1273 Save_Warning : constant Warning_Mode_Type := Warning_Mode; 1274 Options : Style_Check_Options; 1275 1276 begin 1277 Save_Style_Check_Options (Options); 1278 Reset_Style_Check_Options; 1279 Opt.Warning_Mode := Suppress; 1280 1281 Check_Package_Body_For_Inlining (N, Defining_Entity (Unit_Node)); 1282 1283 Reset_Style_Check_Options; 1284 Set_Style_Check_Options (Options); 1285 Style_Check := Save_Style_Check; 1286 Warning_Mode := Save_Warning; 1287 end; 1288 end if; 1289 1290 -- If we are generating obsolescent warnings, then here is where we 1291 -- generate them for the with'ed items. The reason for this special 1292 -- processing is that the normal mechanism of generating the warnings 1293 -- for referenced entities does not work for context clause references. 1294 -- That's because when we first analyze the context, it is too early to 1295 -- know if the with'ing unit is itself obsolescent (which suppresses 1296 -- the warnings). 1297 1298 if not GNAT_Mode 1299 and then Warn_On_Obsolescent_Feature 1300 and then Nkind (Unit_Node) not in N_Generic_Instantiation 1301 then 1302 -- Push current compilation unit as scope, so that the test for 1303 -- being within an obsolescent unit will work correctly. The check 1304 -- is not performed within an instantiation, because the warning 1305 -- will have been emitted in the corresponding generic unit. 1306 1307 Push_Scope (Defining_Entity (Unit_Node)); 1308 1309 -- Loop through context items to deal with with clauses 1310 1311 declare 1312 Item : Node_Id; 1313 Nam : Node_Id; 1314 Ent : Entity_Id; 1315 1316 begin 1317 Item := First (Context_Items (N)); 1318 while Present (Item) loop 1319 if Nkind (Item) = N_With_Clause 1320 1321 -- Suppress this check in limited-withed units. Further work 1322 -- needed here if we decide to incorporate this check on 1323 -- limited-withed units. 1324 1325 and then not Limited_Present (Item) 1326 then 1327 Nam := Name (Item); 1328 Ent := Entity (Nam); 1329 1330 if Is_Obsolescent (Ent) then 1331 Output_Obsolescent_Entity_Warnings (Nam, Ent); 1332 end if; 1333 end if; 1334 1335 Next (Item); 1336 end loop; 1337 end; 1338 1339 -- Remove temporary install of current unit as scope 1340 1341 Pop_Scope; 1342 end if; 1343 1344 -- If No_Elaboration_Code_All was encountered, this is where we do the 1345 -- transitive test of with'ed units to make sure they have the aspect. 1346 -- This is delayed till the end of analyzing the compilation unit to 1347 -- ensure that the pragma/aspect, if present, has been analyzed. 1348 1349 Check_No_Elab_Code_All (N); 1350 end Analyze_Compilation_Unit; 1351 1352 --------------------- 1353 -- Analyze_Context -- 1354 --------------------- 1355 1356 procedure Analyze_Context (N : Node_Id) is 1357 Ukind : constant Node_Kind := Nkind (Unit (N)); 1358 Item : Node_Id; 1359 1360 begin 1361 -- First process all configuration pragmas at the start of the context 1362 -- items. Strictly these are not part of the context clause, but that 1363 -- is where the parser puts them. In any case for sure we must analyze 1364 -- these before analyzing the actual context items, since they can have 1365 -- an effect on that analysis (e.g. pragma Ada_2005 may allow a unit to 1366 -- be with'ed as a result of changing categorizations in Ada 2005). 1367 1368 Item := First (Context_Items (N)); 1369 while Present (Item) 1370 and then Nkind (Item) = N_Pragma 1371 and then Pragma_Name (Item) in Configuration_Pragma_Names 1372 loop 1373 Analyze (Item); 1374 Next (Item); 1375 end loop; 1376 1377 -- This is the point at which we capture the configuration settings 1378 -- for the unit. At the moment only the Optimize_Alignment setting 1379 -- needs to be captured. Probably more later ??? 1380 1381 if Optimize_Alignment_Local then 1382 Set_OA_Setting (Current_Sem_Unit, 'L'); 1383 else 1384 Set_OA_Setting (Current_Sem_Unit, Optimize_Alignment); 1385 end if; 1386 1387 -- Loop through actual context items. This is done in two passes: 1388 1389 -- a) The first pass analyzes non-limited with-clauses and also any 1390 -- configuration pragmas (we need to get the latter analyzed right 1391 -- away, since they can affect processing of subsequent items). 1392 1393 -- b) The second pass analyzes limited_with clauses (Ada 2005: AI-50217) 1394 1395 while Present (Item) loop 1396 1397 -- For with clause, analyze the with clause, and then update the 1398 -- version, since we are dependent on a unit that we with. 1399 1400 if Nkind (Item) = N_With_Clause 1401 and then not Limited_Present (Item) 1402 then 1403 -- Skip analyzing with clause if no unit, nothing to do (this 1404 -- happens for a with that references a non-existent unit). 1405 1406 if Present (Library_Unit (Item)) then 1407 1408 -- Skip analyzing with clause if this is a with_clause for 1409 -- the main unit, which happens if a subunit has a useless 1410 -- with_clause on its parent. 1411 1412 if Library_Unit (Item) /= Cunit (Current_Sem_Unit) then 1413 Analyze (Item); 1414 1415 -- Here for the case of a useless with for the main unit 1416 1417 else 1418 Set_Entity (Name (Item), Cunit_Entity (Current_Sem_Unit)); 1419 end if; 1420 end if; 1421 1422 -- Do version update (skipped for implicit with) 1423 1424 if not Implicit_With (Item) then 1425 Version_Update (N, Library_Unit (Item)); 1426 end if; 1427 1428 -- Skip pragmas. Configuration pragmas at the start were handled in 1429 -- the loop above, and remaining pragmas are not processed until we 1430 -- actually install the context (see Install_Context). We delay the 1431 -- analysis of these pragmas to make sure that we have installed all 1432 -- the implicit with's on parent units. 1433 1434 -- Skip use clauses at this stage, since we don't want to do any 1435 -- installing of potentially use-visible entities until we 1436 -- actually install the complete context (in Install_Context). 1437 -- Otherwise things can get installed in the wrong context. 1438 1439 else 1440 null; 1441 end if; 1442 1443 Next (Item); 1444 end loop; 1445 1446 -- Second pass: examine all limited_with clauses. All other context 1447 -- items are ignored in this pass. 1448 1449 Item := First (Context_Items (N)); 1450 while Present (Item) loop 1451 if Nkind (Item) = N_With_Clause 1452 and then Limited_Present (Item) 1453 then 1454 -- No need to check errors on implicitly generated limited-with 1455 -- clauses. 1456 1457 if not Implicit_With (Item) then 1458 1459 -- Verify that the illegal contexts given in 10.1.2 (18/2) are 1460 -- properly rejected, including renaming declarations. 1461 1462 if not Nkind_In (Ukind, N_Package_Declaration, 1463 N_Subprogram_Declaration) 1464 and then Ukind not in N_Generic_Declaration 1465 and then Ukind not in N_Generic_Instantiation 1466 then 1467 Error_Msg_N ("limited with_clause not allowed here", Item); 1468 1469 -- Check wrong use of a limited with clause applied to the 1470 -- compilation unit containing the limited-with clause. 1471 1472 -- limited with P.Q; 1473 -- package P.Q is ... 1474 1475 elsif Unit (Library_Unit (Item)) = Unit (N) then 1476 Error_Msg_N ("wrong use of limited-with clause", Item); 1477 1478 -- Check wrong use of limited-with clause applied to some 1479 -- immediate ancestor. 1480 1481 elsif Is_Child_Spec (Unit (N)) then 1482 declare 1483 Lib_U : constant Entity_Id := Unit (Library_Unit (Item)); 1484 P : Node_Id; 1485 1486 begin 1487 P := Parent_Spec (Unit (N)); 1488 loop 1489 if Unit (P) = Lib_U then 1490 Error_Msg_N 1491 ("limited with_clause cannot name ancestor", 1492 Item); 1493 exit; 1494 end if; 1495 1496 exit when not Is_Child_Spec (Unit (P)); 1497 P := Parent_Spec (Unit (P)); 1498 end loop; 1499 end; 1500 end if; 1501 1502 -- Check if the limited-withed unit is already visible through 1503 -- some context clause of the current compilation unit or some 1504 -- ancestor of the current compilation unit. 1505 1506 declare 1507 Lim_Unit_Name : constant Node_Id := Name (Item); 1508 Comp_Unit : Node_Id; 1509 It : Node_Id; 1510 Unit_Name : Node_Id; 1511 1512 begin 1513 Comp_Unit := N; 1514 loop 1515 It := First (Context_Items (Comp_Unit)); 1516 while Present (It) loop 1517 if Item /= It 1518 and then Nkind (It) = N_With_Clause 1519 and then not Limited_Present (It) 1520 and then 1521 Nkind_In (Unit (Library_Unit (It)), 1522 N_Package_Declaration, 1523 N_Package_Renaming_Declaration) 1524 then 1525 if Nkind (Unit (Library_Unit (It))) = 1526 N_Package_Declaration 1527 then 1528 Unit_Name := Name (It); 1529 else 1530 Unit_Name := Name (Unit (Library_Unit (It))); 1531 end if; 1532 1533 -- Check if the named package (or some ancestor) 1534 -- leaves visible the full-view of the unit given 1535 -- in the limited-with clause. 1536 1537 loop 1538 if Designate_Same_Unit (Lim_Unit_Name, 1539 Unit_Name) 1540 then 1541 Error_Msg_Sloc := Sloc (It); 1542 Error_Msg_N 1543 ("simultaneous visibility of limited and " 1544 & "unlimited views not allowed", Item); 1545 Error_Msg_NE 1546 ("\unlimited view visible through context " 1547 & "clause #", Item, It); 1548 exit; 1549 1550 elsif Nkind (Unit_Name) = N_Identifier then 1551 exit; 1552 end if; 1553 1554 Unit_Name := Prefix (Unit_Name); 1555 end loop; 1556 end if; 1557 1558 Next (It); 1559 end loop; 1560 1561 exit when not Is_Child_Spec (Unit (Comp_Unit)); 1562 1563 Comp_Unit := Parent_Spec (Unit (Comp_Unit)); 1564 end loop; 1565 end; 1566 end if; 1567 1568 -- Skip analyzing with clause if no unit, see above 1569 1570 if Present (Library_Unit (Item)) then 1571 Analyze (Item); 1572 end if; 1573 1574 -- A limited_with does not impose an elaboration order, but there 1575 -- is a semantic dependency for recompilation purposes. 1576 1577 if not Implicit_With (Item) then 1578 Version_Update (N, Library_Unit (Item)); 1579 end if; 1580 1581 -- Pragmas and use clauses and with clauses other than limited with's 1582 -- are ignored in this pass through the context items. 1583 1584 else 1585 null; 1586 end if; 1587 1588 Next (Item); 1589 end loop; 1590 end Analyze_Context; 1591 1592 ------------------------------- 1593 -- Analyze_Package_Body_Stub -- 1594 ------------------------------- 1595 1596 procedure Analyze_Package_Body_Stub (N : Node_Id) is 1597 Id : constant Entity_Id := Defining_Identifier (N); 1598 Nam : Entity_Id; 1599 Opts : Config_Switches_Type; 1600 1601 begin 1602 -- The package declaration must be in the current declarative part 1603 1604 Check_Stub_Level (N); 1605 Nam := Current_Entity_In_Scope (Id); 1606 1607 if No (Nam) or else not Is_Package_Or_Generic_Package (Nam) then 1608 Error_Msg_N ("missing specification for package stub", N); 1609 1610 elsif Has_Completion (Nam) 1611 and then Present (Corresponding_Body (Unit_Declaration_Node (Nam))) 1612 then 1613 Error_Msg_N ("duplicate or redundant stub for package", N); 1614 1615 else 1616 -- Retain and restore the configuration options of the enclosing 1617 -- context as the proper body may introduce a set of its own. 1618 1619 Save_Opt_Config_Switches (Opts); 1620 1621 -- Indicate that the body of the package exists. If we are doing 1622 -- only semantic analysis, the stub stands for the body. If we are 1623 -- generating code, the existence of the body will be confirmed 1624 -- when we load the proper body. 1625 1626 Set_Has_Completion (Nam); 1627 Set_Scope (Defining_Entity (N), Current_Scope); 1628 Set_Ekind (Defining_Entity (N), E_Package_Body); 1629 Set_Corresponding_Spec_Of_Stub (N, Nam); 1630 Generate_Reference (Nam, Id, 'b'); 1631 Analyze_Proper_Body (N, Nam); 1632 1633 Restore_Opt_Config_Switches (Opts); 1634 end if; 1635 end Analyze_Package_Body_Stub; 1636 1637 ------------------------- 1638 -- Analyze_Proper_Body -- 1639 ------------------------- 1640 1641 procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is 1642 Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N); 1643 1644 procedure Optional_Subunit; 1645 -- This procedure is called when the main unit is a stub, or when we 1646 -- are not generating code. In such a case, we analyze the subunit if 1647 -- present, which is user-friendly and in fact required for ASIS, but we 1648 -- don't complain if the subunit is missing. In GNATprove_Mode, we issue 1649 -- an error to avoid formal verification of a partial unit. 1650 1651 ---------------------- 1652 -- Optional_Subunit -- 1653 ---------------------- 1654 1655 procedure Optional_Subunit is 1656 Comp_Unit : Node_Id; 1657 Unum : Unit_Number_Type; 1658 1659 begin 1660 -- Try to load subunit, but ignore any errors that occur during the 1661 -- loading of the subunit, by using the special feature in Errout to 1662 -- ignore all errors. Note that Fatal_Error will still be set, so we 1663 -- will be able to check for this case below. 1664 1665 if not (ASIS_Mode or GNATprove_Mode) then 1666 Ignore_Errors_Enable := Ignore_Errors_Enable + 1; 1667 end if; 1668 1669 Unum := 1670 Load_Unit 1671 (Load_Name => Subunit_Name, 1672 Required => GNATprove_Mode, 1673 Subunit => True, 1674 Error_Node => N); 1675 1676 if not (ASIS_Mode or GNATprove_Mode) then 1677 Ignore_Errors_Enable := Ignore_Errors_Enable - 1; 1678 end if; 1679 1680 -- All done if we successfully loaded the subunit 1681 1682 if Unum /= No_Unit 1683 and then (Fatal_Error (Unum) /= Error_Detected 1684 or else Try_Semantics) 1685 then 1686 Comp_Unit := Cunit (Unum); 1687 1688 -- If the file was empty or seriously mangled, the unit itself may 1689 -- be missing. 1690 1691 if No (Unit (Comp_Unit)) then 1692 Error_Msg_N 1693 ("subunit does not contain expected proper body", N); 1694 1695 elsif Nkind (Unit (Comp_Unit)) /= N_Subunit then 1696 Error_Msg_N 1697 ("expected SEPARATE subunit, found child unit", 1698 Cunit_Entity (Unum)); 1699 else 1700 Set_Corresponding_Stub (Unit (Comp_Unit), N); 1701 Analyze_Subunit (Comp_Unit); 1702 Set_Library_Unit (N, Comp_Unit); 1703 Set_Corresponding_Body (N, Defining_Entity (Unit (Comp_Unit))); 1704 end if; 1705 1706 elsif Unum = No_Unit 1707 and then Present (Nam) 1708 then 1709 if Is_Protected_Type (Nam) then 1710 Set_Corresponding_Body (Parent (Nam), Defining_Identifier (N)); 1711 else 1712 Set_Corresponding_Body ( 1713 Unit_Declaration_Node (Nam), Defining_Identifier (N)); 1714 end if; 1715 end if; 1716 end Optional_Subunit; 1717 1718 -- Local variables 1719 1720 Comp_Unit : Node_Id; 1721 Unum : Unit_Number_Type; 1722 1723 -- Start of processing for Analyze_Proper_Body 1724 1725 begin 1726 -- If the subunit is already loaded, it means that the main unit is a 1727 -- subunit, and that the current unit is one of its parents which was 1728 -- being analyzed to provide the needed context for the analysis of the 1729 -- subunit. In this case we analyze the subunit and continue with the 1730 -- parent, without looking at subsequent subunits. 1731 1732 if Is_Loaded (Subunit_Name) then 1733 1734 -- If the proper body is already linked to the stub node, the stub is 1735 -- in a generic unit and just needs analyzing. 1736 1737 if Present (Library_Unit (N)) then 1738 Set_Corresponding_Stub (Unit (Library_Unit (N)), N); 1739 1740 -- If the subunit has severe errors, the spec of the enclosing 1741 -- body may not be available, in which case do not try analysis. 1742 1743 if Serious_Errors_Detected > 0 1744 and then No (Library_Unit (Library_Unit (N))) 1745 then 1746 return; 1747 end if; 1748 1749 -- Collect SCO information for loaded subunit if we are in the 1750 -- extended main unit. 1751 1752 if Generate_SCO 1753 and then In_Extended_Main_Source_Unit 1754 (Cunit_Entity (Current_Sem_Unit)) 1755 then 1756 SCO_Record_Raw (Get_Cunit_Unit_Number (Library_Unit (N))); 1757 end if; 1758 1759 Analyze_Subunit (Library_Unit (N)); 1760 1761 -- Otherwise we must load the subunit and link to it 1762 1763 else 1764 -- Load the subunit, this must work, since we originally loaded 1765 -- the subunit earlier on. So this will not really load it, just 1766 -- give access to it. 1767 1768 Unum := 1769 Load_Unit 1770 (Load_Name => Subunit_Name, 1771 Required => True, 1772 Subunit => False, 1773 Error_Node => N); 1774 1775 -- And analyze the subunit in the parent context (note that we 1776 -- do not call Semantics, since that would remove the parent 1777 -- context). Because of this, we have to manually reset the 1778 -- compiler state to Analyzing since it got destroyed by Load. 1779 1780 if Unum /= No_Unit then 1781 Compiler_State := Analyzing; 1782 1783 -- Check that the proper body is a subunit and not a child 1784 -- unit. If the unit was previously loaded, the error will 1785 -- have been emitted when copying the generic node, so we 1786 -- just return to avoid cascaded errors. 1787 1788 if Nkind (Unit (Cunit (Unum))) /= N_Subunit then 1789 return; 1790 end if; 1791 1792 Set_Corresponding_Stub (Unit (Cunit (Unum)), N); 1793 Analyze_Subunit (Cunit (Unum)); 1794 Set_Library_Unit (N, Cunit (Unum)); 1795 end if; 1796 end if; 1797 1798 -- If the main unit is a subunit, then we are just performing semantic 1799 -- analysis on that subunit, and any other subunits of any parent unit 1800 -- should be ignored, except that if we are building trees for ASIS 1801 -- usage we want to annotate the stub properly. If the main unit is 1802 -- itself a subunit, another subunit is irrelevant unless it is a 1803 -- subunit of the current one, that is to say appears in the current 1804 -- source tree. 1805 1806 elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit 1807 and then Subunit_Name /= Unit_Name (Main_Unit) 1808 then 1809 if ASIS_Mode then 1810 declare 1811 PB : constant Node_Id := Proper_Body (Unit (Cunit (Main_Unit))); 1812 begin 1813 if Nkind_In (PB, N_Package_Body, N_Subprogram_Body) 1814 and then List_Containing (N) = Declarations (PB) 1815 then 1816 Optional_Subunit; 1817 end if; 1818 end; 1819 end if; 1820 1821 -- But before we return, set the flag for unloaded subunits. This 1822 -- will suppress junk warnings of variables in the same declarative 1823 -- part (or a higher level one) that are in danger of looking unused 1824 -- when in fact there might be a declaration in the subunit that we 1825 -- do not intend to load. 1826 1827 Unloaded_Subunits := True; 1828 return; 1829 1830 -- If the subunit is not already loaded, and we are generating code, 1831 -- then this is the case where compilation started from the parent, and 1832 -- we are generating code for an entire subunit tree. In that case we 1833 -- definitely need to load the subunit. 1834 1835 -- In order to continue the analysis with the rest of the parent, 1836 -- and other subunits, we load the unit without requiring its 1837 -- presence, and emit a warning if not found, rather than terminating 1838 -- the compilation abruptly, as for other missing file problems. 1839 1840 elsif Original_Operating_Mode = Generate_Code then 1841 1842 -- If the proper body is already linked to the stub node, the stub is 1843 -- in a generic unit and just needs analyzing. 1844 1845 -- We update the version. Although we are not strictly technically 1846 -- semantically dependent on the subunit, given our approach of macro 1847 -- substitution of subunits, it makes sense to include it in the 1848 -- version identification. 1849 1850 if Present (Library_Unit (N)) then 1851 Set_Corresponding_Stub (Unit (Library_Unit (N)), N); 1852 Analyze_Subunit (Library_Unit (N)); 1853 Version_Update (Cunit (Main_Unit), Library_Unit (N)); 1854 1855 -- Otherwise we must load the subunit and link to it 1856 1857 else 1858 -- Make sure that, if the subunit is preprocessed and -gnateG is 1859 -- specified, the preprocessed file will be written. 1860 1861 Lib.Analysing_Subunit_Of_Main := True; 1862 Unum := 1863 Load_Unit 1864 (Load_Name => Subunit_Name, 1865 Required => False, 1866 Subunit => True, 1867 Error_Node => N); 1868 Lib.Analysing_Subunit_Of_Main := False; 1869 1870 -- Give message if we did not get the unit Emit warning even if 1871 -- missing subunit is not within main unit, to simplify debugging. 1872 1873 pragma Assert (Original_Operating_Mode = Generate_Code); 1874 if Unum = No_Unit then 1875 Error_Msg_Unit_1 := Subunit_Name; 1876 Error_Msg_File_1 := 1877 Get_File_Name (Subunit_Name, Subunit => True); 1878 Error_Msg_N 1879 ("subunit$$ in file{ not found??!!", N); 1880 Subunits_Missing := True; 1881 end if; 1882 1883 -- Load_Unit may reset Compiler_State, since it may have been 1884 -- necessary to parse an additional units, so we make sure that 1885 -- we reset it to the Analyzing state. 1886 1887 Compiler_State := Analyzing; 1888 1889 if Unum /= No_Unit then 1890 if Debug_Flag_L then 1891 Write_Str ("*** Loaded subunit from stub. Analyze"); 1892 Write_Eol; 1893 end if; 1894 1895 Comp_Unit := Cunit (Unum); 1896 1897 -- Check for child unit instead of subunit 1898 1899 if Nkind (Unit (Comp_Unit)) /= N_Subunit then 1900 Error_Msg_N 1901 ("expected SEPARATE subunit, found child unit", 1902 Cunit_Entity (Unum)); 1903 1904 -- OK, we have a subunit 1905 1906 else 1907 Set_Corresponding_Stub (Unit (Comp_Unit), N); 1908 Set_Library_Unit (N, Comp_Unit); 1909 1910 -- We update the version. Although we are not technically 1911 -- semantically dependent on the subunit, given our approach 1912 -- of macro substitution of subunits, it makes sense to 1913 -- include it in the version identification. 1914 1915 Version_Update (Cunit (Main_Unit), Comp_Unit); 1916 1917 -- Collect SCO information for loaded subunit if we are in 1918 -- the extended main unit. 1919 1920 if Generate_SCO 1921 and then In_Extended_Main_Source_Unit 1922 (Cunit_Entity (Current_Sem_Unit)) 1923 then 1924 SCO_Record_Raw (Unum); 1925 end if; 1926 1927 -- Analyze the unit if semantics active 1928 1929 if Fatal_Error (Unum) /= Error_Detected 1930 or else Try_Semantics 1931 then 1932 Analyze_Subunit (Comp_Unit); 1933 end if; 1934 end if; 1935 end if; 1936 end if; 1937 1938 -- The remaining case is when the subunit is not already loaded and we 1939 -- are not generating code. In this case we are just performing semantic 1940 -- analysis on the parent, and we are not interested in the subunit. For 1941 -- subprograms, analyze the stub as a body. For other entities the stub 1942 -- has already been marked as completed. 1943 1944 else 1945 Optional_Subunit; 1946 end if; 1947 end Analyze_Proper_Body; 1948 1949 ---------------------------------- 1950 -- Analyze_Protected_Body_Stub -- 1951 ---------------------------------- 1952 1953 procedure Analyze_Protected_Body_Stub (N : Node_Id) is 1954 Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N)); 1955 1956 begin 1957 Check_Stub_Level (N); 1958 1959 -- First occurrence of name may have been as an incomplete type 1960 1961 if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then 1962 Nam := Full_View (Nam); 1963 end if; 1964 1965 if No (Nam) or else not Is_Protected_Type (Etype (Nam)) then 1966 Error_Msg_N ("missing specification for Protected body", N); 1967 1968 else 1969 Set_Scope (Defining_Entity (N), Current_Scope); 1970 Set_Ekind (Defining_Entity (N), E_Protected_Body); 1971 Set_Has_Completion (Etype (Nam)); 1972 Set_Corresponding_Spec_Of_Stub (N, Nam); 1973 Generate_Reference (Nam, Defining_Identifier (N), 'b'); 1974 Analyze_Proper_Body (N, Etype (Nam)); 1975 end if; 1976 end Analyze_Protected_Body_Stub; 1977 1978 ---------------------------------- 1979 -- Analyze_Subprogram_Body_Stub -- 1980 ---------------------------------- 1981 1982 -- A subprogram body stub can appear with or without a previous spec. If 1983 -- there is one, then the analysis of the body will find it and verify 1984 -- conformance. The formals appearing in the specification of the stub play 1985 -- no role, except for requiring an additional conformance check. If there 1986 -- is no previous subprogram declaration, the stub acts as a spec, and 1987 -- provides the defining entity for the subprogram. 1988 1989 procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is 1990 Decl : Node_Id; 1991 Opts : Config_Switches_Type; 1992 1993 begin 1994 Check_Stub_Level (N); 1995 1996 -- Verify that the identifier for the stub is unique within this 1997 -- declarative part. 1998 1999 if Nkind_In (Parent (N), N_Block_Statement, 2000 N_Package_Body, 2001 N_Subprogram_Body) 2002 then 2003 Decl := First (Declarations (Parent (N))); 2004 while Present (Decl) and then Decl /= N loop 2005 if Nkind (Decl) = N_Subprogram_Body_Stub 2006 and then (Chars (Defining_Unit_Name (Specification (Decl))) = 2007 Chars (Defining_Unit_Name (Specification (N)))) 2008 then 2009 Error_Msg_N ("identifier for stub is not unique", N); 2010 end if; 2011 2012 Next (Decl); 2013 end loop; 2014 end if; 2015 2016 -- Retain and restore the configuration options of the enclosing context 2017 -- as the proper body may introduce a set of its own. 2018 2019 Save_Opt_Config_Switches (Opts); 2020 2021 -- Treat stub as a body, which checks conformance if there is a previous 2022 -- declaration, or else introduces entity and its signature. 2023 2024 Analyze_Subprogram_Body (N); 2025 Analyze_Proper_Body (N, Empty); 2026 2027 Restore_Opt_Config_Switches (Opts); 2028 end Analyze_Subprogram_Body_Stub; 2029 2030 --------------------- 2031 -- Analyze_Subunit -- 2032 --------------------- 2033 2034 -- A subunit is compiled either by itself (for semantic checking) or as 2035 -- part of compiling the parent (for code generation). In either case, by 2036 -- the time we actually process the subunit, the parent has already been 2037 -- installed and analyzed. The node N is a compilation unit, whose context 2038 -- needs to be treated here, because we come directly here from the parent 2039 -- without calling Analyze_Compilation_Unit. 2040 2041 -- The compilation context includes the explicit context of the subunit, 2042 -- and the context of the parent, together with the parent itself. In order 2043 -- to compile the current context, we remove the one inherited from the 2044 -- parent, in order to have a clean visibility table. We restore the parent 2045 -- context before analyzing the proper body itself. On exit, we remove only 2046 -- the explicit context of the subunit. 2047 2048 -- WARNING: This routine manages SPARK regions. Return statements must be 2049 -- replaced by gotos which jump to the end of the routine and restore the 2050 -- SPARK mode. 2051 2052 procedure Analyze_Subunit (N : Node_Id) is 2053 Lib_Unit : constant Node_Id := Library_Unit (N); 2054 Par_Unit : constant Entity_Id := Current_Scope; 2055 2056 Lib_Spec : Node_Id := Library_Unit (Lib_Unit); 2057 Num_Scopes : Nat := 0; 2058 Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id; 2059 Enclosing_Child : Entity_Id := Empty; 2060 Svg : constant Suppress_Record := Scope_Suppress; 2061 2062 Save_Cunit_Restrictions : constant Save_Cunit_Boolean_Restrictions := 2063 Cunit_Boolean_Restrictions_Save; 2064 -- Save non-partition wide restrictions before processing the subunit. 2065 -- All subunits are analyzed with config restrictions reset and we need 2066 -- to restore these saved values at the end. 2067 2068 procedure Analyze_Subunit_Context; 2069 -- Capture names in use clauses of the subunit. This must be done before 2070 -- re-installing parent declarations, because items in the context must 2071 -- not be hidden by declarations local to the parent. 2072 2073 procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id); 2074 -- Recursive procedure to restore scope of all ancestors of subunit, 2075 -- from outermost in. If parent is not a subunit, the call to install 2076 -- context installs context of spec and (if parent is a child unit) the 2077 -- context of its parents as well. It is confusing that parents should 2078 -- be treated differently in both cases, but the semantics are just not 2079 -- identical. 2080 2081 procedure Re_Install_Use_Clauses; 2082 -- As part of the removal of the parent scope, the use clauses are 2083 -- removed, to be reinstalled when the context of the subunit has been 2084 -- analyzed. Use clauses may also have been affected by the analysis of 2085 -- the context of the subunit, so they have to be applied again, to 2086 -- insure that the compilation environment of the rest of the parent 2087 -- unit is identical. 2088 2089 procedure Remove_Scope; 2090 -- Remove current scope from scope stack, and preserve the list of use 2091 -- clauses in it, to be reinstalled after context is analyzed. 2092 2093 ----------------------------- 2094 -- Analyze_Subunit_Context -- 2095 ----------------------------- 2096 2097 procedure Analyze_Subunit_Context is 2098 Item : Node_Id; 2099 Unit_Name : Entity_Id; 2100 2101 begin 2102 Analyze_Context (N); 2103 Check_No_Elab_Code_All (N); 2104 2105 -- Make withed units immediately visible. If child unit, make the 2106 -- ultimate parent immediately visible. 2107 2108 Item := First (Context_Items (N)); 2109 while Present (Item) loop 2110 if Nkind (Item) = N_With_Clause then 2111 2112 -- Protect frontend against previous errors in context clauses 2113 2114 if Nkind (Name (Item)) /= N_Selected_Component then 2115 if Error_Posted (Item) then 2116 null; 2117 2118 else 2119 -- If a subunits has serious syntax errors, the context 2120 -- may not have been loaded. Add a harmless unit name to 2121 -- attempt processing. 2122 2123 if Serious_Errors_Detected > 0 2124 and then No (Entity (Name (Item))) 2125 then 2126 Set_Entity (Name (Item), Standard_Standard); 2127 end if; 2128 2129 Unit_Name := Entity (Name (Item)); 2130 loop 2131 Set_Is_Visible_Lib_Unit (Unit_Name); 2132 exit when Scope (Unit_Name) = Standard_Standard; 2133 Unit_Name := Scope (Unit_Name); 2134 2135 if No (Unit_Name) then 2136 Check_Error_Detected; 2137 return; 2138 end if; 2139 end loop; 2140 2141 if not Is_Immediately_Visible (Unit_Name) then 2142 Set_Is_Immediately_Visible (Unit_Name); 2143 Set_Context_Installed (Item); 2144 end if; 2145 end if; 2146 end if; 2147 2148 elsif Nkind (Item) = N_Use_Package_Clause then 2149 Analyze (Name (Item)); 2150 2151 elsif Nkind (Item) = N_Use_Type_Clause then 2152 Analyze (Subtype_Mark (Item)); 2153 end if; 2154 2155 Next (Item); 2156 end loop; 2157 2158 -- Reset visibility of withed units. They will be made visible again 2159 -- when we install the subunit context. 2160 2161 Item := First (Context_Items (N)); 2162 while Present (Item) loop 2163 if Nkind (Item) = N_With_Clause 2164 2165 -- Protect frontend against previous errors in context clauses 2166 2167 and then Nkind (Name (Item)) /= N_Selected_Component 2168 and then not Error_Posted (Item) 2169 then 2170 Unit_Name := Entity (Name (Item)); 2171 loop 2172 Set_Is_Visible_Lib_Unit (Unit_Name, False); 2173 exit when Scope (Unit_Name) = Standard_Standard; 2174 Unit_Name := Scope (Unit_Name); 2175 end loop; 2176 2177 if Context_Installed (Item) then 2178 Set_Is_Immediately_Visible (Unit_Name, False); 2179 Set_Context_Installed (Item, False); 2180 end if; 2181 end if; 2182 2183 Next (Item); 2184 end loop; 2185 end Analyze_Subunit_Context; 2186 2187 ------------------------ 2188 -- Re_Install_Parents -- 2189 ------------------------ 2190 2191 procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id) is 2192 E : Entity_Id; 2193 2194 begin 2195 if Nkind (Unit (L)) = N_Subunit then 2196 Re_Install_Parents (Library_Unit (L), Scope (Scop)); 2197 end if; 2198 2199 Install_Context (L, False); 2200 2201 -- If the subunit occurs within a child unit, we must restore the 2202 -- immediate visibility of any siblings that may occur in context. 2203 2204 if Present (Enclosing_Child) then 2205 Install_Siblings (Enclosing_Child, L); 2206 end if; 2207 2208 Push_Scope (Scop); 2209 2210 if Scop /= Par_Unit then 2211 Set_Is_Immediately_Visible (Scop); 2212 end if; 2213 2214 -- Make entities in scope visible again. For child units, restore 2215 -- visibility only if they are actually in context. 2216 2217 E := First_Entity (Current_Scope); 2218 while Present (E) loop 2219 if not Is_Child_Unit (E) or else Is_Visible_Lib_Unit (E) then 2220 Set_Is_Immediately_Visible (E); 2221 end if; 2222 2223 Next_Entity (E); 2224 end loop; 2225 2226 -- A subunit appears within a body, and for a nested subunits all the 2227 -- parents are bodies. Restore full visibility of their private 2228 -- entities. 2229 2230 if Is_Package_Or_Generic_Package (Scop) then 2231 Set_In_Package_Body (Scop); 2232 Install_Private_Declarations (Scop); 2233 end if; 2234 end Re_Install_Parents; 2235 2236 ---------------------------- 2237 -- Re_Install_Use_Clauses -- 2238 ---------------------------- 2239 2240 procedure Re_Install_Use_Clauses is 2241 U : Node_Id; 2242 begin 2243 for J in reverse 1 .. Num_Scopes loop 2244 U := Use_Clauses (J); 2245 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U; 2246 Install_Use_Clauses (U); 2247 end loop; 2248 end Re_Install_Use_Clauses; 2249 2250 ------------------ 2251 -- Remove_Scope -- 2252 ------------------ 2253 2254 procedure Remove_Scope is 2255 E : Entity_Id; 2256 2257 begin 2258 Num_Scopes := Num_Scopes + 1; 2259 Use_Clauses (Num_Scopes) := 2260 Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause; 2261 2262 E := First_Entity (Current_Scope); 2263 while Present (E) loop 2264 Set_Is_Immediately_Visible (E, False); 2265 Next_Entity (E); 2266 end loop; 2267 2268 if Is_Child_Unit (Current_Scope) then 2269 Enclosing_Child := Current_Scope; 2270 end if; 2271 2272 Pop_Scope; 2273 end Remove_Scope; 2274 2275 Saved_SM : SPARK_Mode_Type := SPARK_Mode; 2276 Saved_SMP : Node_Id := SPARK_Mode_Pragma; 2277 -- Save the SPARK mode-related data to restore on exit. Removing 2278 -- enclosing scopes and contexts to provide a clean environment for the 2279 -- context of the subunit will eliminate any previously set SPARK_Mode. 2280 2281 -- Start of processing for Analyze_Subunit 2282 2283 begin 2284 -- For subunit in main extended unit, we reset the configuration values 2285 -- for the non-partition-wide restrictions. For other units reset them. 2286 2287 if In_Extended_Main_Source_Unit (N) then 2288 Restore_Config_Cunit_Boolean_Restrictions; 2289 else 2290 Reset_Cunit_Boolean_Restrictions; 2291 end if; 2292 2293 if Style_Check then 2294 declare 2295 Nam : Node_Id := Name (Unit (N)); 2296 2297 begin 2298 if Nkind (Nam) = N_Selected_Component then 2299 Nam := Selector_Name (Nam); 2300 end if; 2301 2302 Check_Identifier (Nam, Par_Unit); 2303 end; 2304 end if; 2305 2306 if not Is_Empty_List (Context_Items (N)) then 2307 2308 -- Save current use clauses 2309 2310 Remove_Scope; 2311 Remove_Context (Lib_Unit); 2312 2313 -- Now remove parents and their context, including enclosing subunits 2314 -- and the outer parent body which is not a subunit. 2315 2316 if Present (Lib_Spec) then 2317 Remove_Context (Lib_Spec); 2318 2319 while Nkind (Unit (Lib_Spec)) = N_Subunit loop 2320 Lib_Spec := Library_Unit (Lib_Spec); 2321 Remove_Scope; 2322 Remove_Context (Lib_Spec); 2323 end loop; 2324 2325 if Nkind (Unit (Lib_Unit)) = N_Subunit then 2326 Remove_Scope; 2327 end if; 2328 2329 if Nkind (Unit (Lib_Spec)) = N_Package_Body then 2330 Remove_Context (Library_Unit (Lib_Spec)); 2331 end if; 2332 end if; 2333 2334 Set_Is_Immediately_Visible (Par_Unit, False); 2335 2336 Analyze_Subunit_Context; 2337 2338 -- Take into account the effect of any SPARK_Mode configuration 2339 -- pragma, which takes precedence over a different value of 2340 -- SPARK_Mode inherited from the context of the stub. 2341 2342 if SPARK_Mode /= None then 2343 Saved_SM := SPARK_Mode; 2344 Saved_SMP := SPARK_Mode_Pragma; 2345 end if; 2346 2347 Re_Install_Parents (Lib_Unit, Par_Unit); 2348 Set_Is_Immediately_Visible (Par_Unit); 2349 2350 -- If the context includes a child unit of the parent of the subunit, 2351 -- the parent will have been removed from visibility, after compiling 2352 -- that cousin in the context. The visibility of the parent must be 2353 -- restored now. This also applies if the context includes another 2354 -- subunit of the same parent which in turn includes a child unit in 2355 -- its context. 2356 2357 if Is_Package_Or_Generic_Package (Par_Unit) then 2358 if not Is_Immediately_Visible (Par_Unit) 2359 or else (Present (First_Entity (Par_Unit)) 2360 and then not 2361 Is_Immediately_Visible (First_Entity (Par_Unit))) 2362 then 2363 Set_Is_Immediately_Visible (Par_Unit); 2364 Install_Visible_Declarations (Par_Unit); 2365 Install_Private_Declarations (Par_Unit); 2366 end if; 2367 end if; 2368 2369 Re_Install_Use_Clauses; 2370 Install_Context (N, Chain => False); 2371 2372 -- Restore state of suppress flags for current body 2373 2374 Scope_Suppress := Svg; 2375 2376 -- If the subunit is within a child unit, then siblings of any parent 2377 -- unit that appear in the context clause of the subunit must also be 2378 -- made immediately visible. 2379 2380 if Present (Enclosing_Child) then 2381 Install_Siblings (Enclosing_Child, N); 2382 end if; 2383 end if; 2384 2385 Generate_Parent_References (Unit (N), Par_Unit); 2386 2387 -- Reinstall the SPARK_Mode which was in effect prior to any scope and 2388 -- context manipulations, taking into account a possible SPARK_Mode 2389 -- configuration pragma if present. 2390 2391 Install_SPARK_Mode (Saved_SM, Saved_SMP); 2392 2393 Analyze (Proper_Body (Unit (N))); 2394 Remove_Context (N); 2395 2396 -- The subunit may contain a with_clause on a sibling of some ancestor. 2397 -- Removing the context will remove from visibility those ancestor child 2398 -- units, which must be restored to the visibility they have in the 2399 -- enclosing body. 2400 2401 if Present (Enclosing_Child) then 2402 declare 2403 C : Entity_Id; 2404 begin 2405 C := Current_Scope; 2406 while Present (C) and then C /= Standard_Standard loop 2407 Set_Is_Immediately_Visible (C); 2408 Set_Is_Visible_Lib_Unit (C); 2409 C := Scope (C); 2410 end loop; 2411 end; 2412 end if; 2413 2414 -- Deal with restore of restrictions 2415 2416 Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions); 2417 end Analyze_Subunit; 2418 2419 ---------------------------- 2420 -- Analyze_Task_Body_Stub -- 2421 ---------------------------- 2422 2423 procedure Analyze_Task_Body_Stub (N : Node_Id) is 2424 Loc : constant Source_Ptr := Sloc (N); 2425 Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N)); 2426 2427 begin 2428 Check_Stub_Level (N); 2429 2430 -- First occurrence of name may have been as an incomplete type 2431 2432 if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then 2433 Nam := Full_View (Nam); 2434 end if; 2435 2436 if No (Nam) or else not Is_Task_Type (Etype (Nam)) then 2437 Error_Msg_N ("missing specification for task body", N); 2438 2439 else 2440 Set_Scope (Defining_Entity (N), Current_Scope); 2441 Set_Ekind (Defining_Entity (N), E_Task_Body); 2442 Generate_Reference (Nam, Defining_Identifier (N), 'b'); 2443 Set_Corresponding_Spec_Of_Stub (N, Nam); 2444 2445 -- Check for duplicate stub, if so give message and terminate 2446 2447 if Has_Completion (Etype (Nam)) then 2448 Error_Msg_N ("duplicate stub for task", N); 2449 return; 2450 else 2451 Set_Has_Completion (Etype (Nam)); 2452 end if; 2453 2454 Analyze_Proper_Body (N, Etype (Nam)); 2455 2456 -- Set elaboration flag to indicate that entity is callable. This 2457 -- cannot be done in the expansion of the body itself, because the 2458 -- proper body is not in a declarative part. This is only done if 2459 -- expansion is active, because the context may be generic and the 2460 -- flag not defined yet. 2461 2462 if Expander_Active then 2463 Insert_After (N, 2464 Make_Assignment_Statement (Loc, 2465 Name => 2466 Make_Identifier (Loc, 2467 Chars => New_External_Name (Chars (Etype (Nam)), 'E')), 2468 Expression => New_Occurrence_Of (Standard_True, Loc))); 2469 end if; 2470 end if; 2471 end Analyze_Task_Body_Stub; 2472 2473 ------------------------- 2474 -- Analyze_With_Clause -- 2475 ------------------------- 2476 2477 -- Analyze the declaration of a unit in a with clause. At end, label the 2478 -- with clause with the defining entity for the unit. 2479 2480 procedure Analyze_With_Clause (N : Node_Id) is 2481 2482 -- Retrieve the original kind of the unit node, before analysis. If it 2483 -- is a subprogram instantiation, its analysis below will rewrite the 2484 -- node as the declaration of the wrapper package. If the same 2485 -- instantiation appears indirectly elsewhere in the context, it will 2486 -- have been analyzed already. 2487 2488 Unit_Kind : constant Node_Kind := 2489 Nkind (Original_Node (Unit (Library_Unit (N)))); 2490 Nam : constant Node_Id := Name (N); 2491 E_Name : Entity_Id; 2492 Par_Name : Entity_Id; 2493 Pref : Node_Id; 2494 U : Node_Id; 2495 2496 Intunit : Boolean; 2497 -- Set True if the unit currently being compiled is an internal unit 2498 2499 Restriction_Violation : Boolean := False; 2500 -- Set True if a with violates a restriction, no point in giving any 2501 -- warnings if we have this definite error. 2502 2503 Save_Style_Check : constant Boolean := Opt.Style_Check; 2504 2505 begin 2506 U := Unit (Library_Unit (N)); 2507 2508 -- If this is an internal unit which is a renaming, then this is a 2509 -- violation of No_Obsolescent_Features. 2510 2511 -- Note: this is not quite right if the user defines one of these units 2512 -- himself, but that's a marginal case, and fixing it is hard ??? 2513 2514 if Restriction_Check_Required (No_Obsolescent_Features) then 2515 if In_Predefined_Renaming (U) then 2516 Check_Restriction (No_Obsolescent_Features, N); 2517 Restriction_Violation := True; 2518 end if; 2519 end if; 2520 2521 -- Check No_Implementation_Units violation 2522 2523 if Restriction_Check_Required (No_Implementation_Units) then 2524 if Not_Impl_Defined_Unit (Get_Source_Unit (U)) then 2525 null; 2526 else 2527 Check_Restriction (No_Implementation_Units, Nam); 2528 Restriction_Violation := True; 2529 end if; 2530 end if; 2531 2532 -- Several actions are skipped for dummy packages (those supplied for 2533 -- with's where no matching file could be found). Such packages are 2534 -- identified by the Sloc value being set to No_Location. 2535 2536 if Limited_Present (N) then 2537 2538 -- Ada 2005 (AI-50217): Build visibility structures but do not 2539 -- analyze the unit. 2540 2541 -- If the designated unit is a predefined unit, which might be used 2542 -- implicitly through the rtsfind machinery, a limited with clause 2543 -- on such a unit is usually pointless, because run-time units are 2544 -- unlikely to appear in mutually dependent units, and because this 2545 -- disables the rtsfind mechanism. We transform such limited with 2546 -- clauses into regular with clauses. 2547 2548 if Sloc (U) /= No_Location then 2549 if In_Predefined_Unit (U) 2550 2551 -- In ASIS mode the rtsfind mechanism plays no role, and 2552 -- we need to maintain the original tree structure, so 2553 -- this transformation is not performed in this case. 2554 2555 and then not ASIS_Mode 2556 then 2557 Set_Limited_Present (N, False); 2558 Analyze_With_Clause (N); 2559 else 2560 Build_Limited_Views (N); 2561 end if; 2562 end if; 2563 2564 return; 2565 end if; 2566 2567 -- If we are compiling under "don't quit" mode (-gnatq) and we have 2568 -- already detected serious errors then we mark the with-clause nodes as 2569 -- analyzed before the corresponding compilation unit is analyzed. This 2570 -- is done here to protect the frontend against never ending recursion 2571 -- caused by circularities in the sources (because the previous errors 2572 -- may break the regular machine of the compiler implemented in 2573 -- Load_Unit to detect circularities). 2574 2575 if Serious_Errors_Detected > 0 and then Try_Semantics then 2576 Set_Analyzed (N); 2577 end if; 2578 2579 Semantics (Library_Unit (N)); 2580 2581 Intunit := Is_Internal_Unit (Current_Sem_Unit); 2582 2583 if Sloc (U) /= No_Location then 2584 2585 -- Check restrictions, except that we skip the check if this is an 2586 -- internal unit unless we are compiling the internal unit as the 2587 -- main unit. We also skip this for dummy packages. 2588 2589 Check_Restriction_No_Dependence (Nam, N); 2590 2591 if not Intunit or else Current_Sem_Unit = Main_Unit then 2592 Check_Restricted_Unit (Unit_Name (Get_Source_Unit (U)), N); 2593 end if; 2594 2595 -- Deal with special case of GNAT.Current_Exceptions which interacts 2596 -- with the optimization of local raise statements into gotos. 2597 2598 if Nkind (Nam) = N_Selected_Component 2599 and then Nkind (Prefix (Nam)) = N_Identifier 2600 and then Chars (Prefix (Nam)) = Name_Gnat 2601 and then Nam_In (Chars (Selector_Name (Nam)), 2602 Name_Most_Recent_Exception, 2603 Name_Exception_Traces) 2604 then 2605 Check_Restriction (No_Exception_Propagation, N); 2606 Special_Exception_Package_Used := True; 2607 end if; 2608 2609 -- Check for inappropriate with of internal implementation unit if we 2610 -- are not compiling an internal unit and also check for withing unit 2611 -- in wrong version of Ada. Do not issue these messages for implicit 2612 -- with's generated by the compiler itself. 2613 2614 if Implementation_Unit_Warnings 2615 and then not Intunit 2616 and then not Implicit_With (N) 2617 and then not Restriction_Violation 2618 then 2619 declare 2620 U_Kind : constant Kind_Of_Unit := 2621 Get_Kind_Of_Unit (Get_Source_Unit (U)); 2622 2623 begin 2624 if U_Kind = Implementation_Unit then 2625 Error_Msg_F ("& is an internal 'G'N'A'T unit?i?", Name (N)); 2626 2627 -- Add alternative name if available, otherwise issue a 2628 -- general warning message. 2629 2630 if Error_Msg_Strlen /= 0 then 2631 Error_Msg_F ("\use ""~"" instead?i?", Name (N)); 2632 else 2633 Error_Msg_F 2634 ("\use of this unit is non-portable and " 2635 & "version-dependent?i?", Name (N)); 2636 end if; 2637 2638 elsif U_Kind = Ada_2005_Unit 2639 and then Ada_Version < Ada_2005 2640 and then Warn_On_Ada_2005_Compatibility 2641 then 2642 Error_Msg_N ("& is an Ada 2005 unit?i?", Name (N)); 2643 2644 elsif U_Kind = Ada_2012_Unit 2645 and then Ada_Version < Ada_2012 2646 and then Warn_On_Ada_2012_Compatibility 2647 then 2648 Error_Msg_N ("& is an Ada 2012 unit?i?", Name (N)); 2649 end if; 2650 end; 2651 end if; 2652 end if; 2653 2654 -- Semantic analysis of a generic unit is performed on a copy of 2655 -- the original tree. Retrieve the entity on which semantic info 2656 -- actually appears. 2657 2658 if Unit_Kind in N_Generic_Declaration then 2659 E_Name := Defining_Entity (U); 2660 2661 -- Note: in the following test, Unit_Kind is the original Nkind, but in 2662 -- the case of an instantiation, semantic analysis above will have 2663 -- replaced the unit by its instantiated version. If the instance body 2664 -- has been generated, the instance now denotes the body entity. For 2665 -- visibility purposes we need the entity of its spec. 2666 2667 elsif (Unit_Kind = N_Package_Instantiation 2668 or else Nkind (Original_Node (Unit (Library_Unit (N)))) = 2669 N_Package_Instantiation) 2670 and then Nkind (U) = N_Package_Body 2671 then 2672 E_Name := Corresponding_Spec (U); 2673 2674 elsif Unit_Kind = N_Package_Instantiation 2675 and then Nkind (U) = N_Package_Instantiation 2676 and then Present (Instance_Spec (U)) 2677 then 2678 -- If the instance has not been rewritten as a package declaration, 2679 -- then it appeared already in a previous with clause. Retrieve 2680 -- the entity from the previous instance. 2681 2682 E_Name := Defining_Entity (Specification (Instance_Spec (U))); 2683 2684 elsif Unit_Kind in N_Subprogram_Instantiation then 2685 2686 -- The visible subprogram is created during instantiation, and is 2687 -- an attribute of the wrapper package. We retrieve the wrapper 2688 -- package directly from the instantiation node. If the instance 2689 -- is inlined the unit is still an instantiation. Otherwise it has 2690 -- been rewritten as the declaration of the wrapper itself. 2691 2692 if Nkind (U) in N_Subprogram_Instantiation then 2693 E_Name := 2694 Related_Instance 2695 (Defining_Entity (Specification (Instance_Spec (U)))); 2696 else 2697 E_Name := Related_Instance (Defining_Entity (U)); 2698 end if; 2699 2700 elsif Unit_Kind = N_Package_Renaming_Declaration 2701 or else Unit_Kind in N_Generic_Renaming_Declaration 2702 then 2703 E_Name := Defining_Entity (U); 2704 2705 elsif Unit_Kind = N_Subprogram_Body 2706 and then Nkind (Name (N)) = N_Selected_Component 2707 and then not Acts_As_Spec (Library_Unit (N)) 2708 then 2709 -- For a child unit that has no spec, one has been created and 2710 -- analyzed. The entity required is that of the spec. 2711 2712 E_Name := Corresponding_Spec (U); 2713 2714 else 2715 E_Name := Defining_Entity (U); 2716 end if; 2717 2718 if Nkind (Name (N)) = N_Selected_Component then 2719 2720 -- Child unit in a with clause 2721 2722 Change_Selected_Component_To_Expanded_Name (Name (N)); 2723 2724 -- If this is a child unit without a spec, and it has been analyzed 2725 -- already, a declaration has been created for it. The with_clause 2726 -- must reflect the actual body, and not the generated declaration, 2727 -- to prevent spurious binding errors involving an out-of-date spec. 2728 -- Note that this can only happen if the unit includes more than one 2729 -- with_clause for the child unit (e.g. in separate subunits). 2730 2731 if Unit_Kind = N_Subprogram_Declaration 2732 and then Analyzed (Library_Unit (N)) 2733 and then not Comes_From_Source (Library_Unit (N)) 2734 then 2735 Set_Library_Unit (N, 2736 Cunit (Get_Source_Unit (Corresponding_Body (U)))); 2737 end if; 2738 end if; 2739 2740 -- Restore style checks 2741 2742 Style_Check := Save_Style_Check; 2743 2744 -- Record the reference, but do NOT set the unit as referenced, we want 2745 -- to consider the unit as unreferenced if this is the only reference 2746 -- that occurs. 2747 2748 Set_Entity_With_Checks (Name (N), E_Name); 2749 Generate_Reference (E_Name, Name (N), 'w', Set_Ref => False); 2750 2751 -- Generate references and check No_Dependence restriction for parents 2752 2753 if Is_Child_Unit (E_Name) then 2754 Pref := Prefix (Name (N)); 2755 Par_Name := Scope (E_Name); 2756 while Nkind (Pref) = N_Selected_Component loop 2757 Change_Selected_Component_To_Expanded_Name (Pref); 2758 2759 if Present (Entity (Selector_Name (Pref))) 2760 and then 2761 Present (Renamed_Entity (Entity (Selector_Name (Pref)))) 2762 and then Entity (Selector_Name (Pref)) /= Par_Name 2763 then 2764 -- The prefix is a child unit that denotes a renaming declaration. 2765 -- Replace the prefix directly with the renamed unit, because the 2766 -- rest of the prefix is irrelevant to the visibility of the real 2767 -- unit. 2768 2769 Rewrite (Pref, New_Occurrence_Of (Par_Name, Sloc (Pref))); 2770 exit; 2771 end if; 2772 2773 Set_Entity_With_Checks (Pref, Par_Name); 2774 2775 Generate_Reference (Par_Name, Pref); 2776 Check_Restriction_No_Dependence (Pref, N); 2777 Pref := Prefix (Pref); 2778 2779 -- If E_Name is the dummy entity for a nonexistent unit, its scope 2780 -- is set to Standard_Standard, and no attempt should be made to 2781 -- further unwind scopes. 2782 2783 if Par_Name /= Standard_Standard then 2784 Par_Name := Scope (Par_Name); 2785 end if; 2786 2787 -- Abandon processing in case of previous errors 2788 2789 if No (Par_Name) then 2790 Check_Error_Detected; 2791 return; 2792 end if; 2793 end loop; 2794 2795 if Present (Entity (Pref)) 2796 and then not Analyzed (Parent (Parent (Entity (Pref)))) 2797 then 2798 -- If the entity is set without its unit being compiled, the 2799 -- original parent is a renaming, and Par_Name is the renamed 2800 -- entity. For visibility purposes, we need the original entity, 2801 -- which must be analyzed now because Load_Unit directly retrieves 2802 -- the renamed unit, and the renaming declaration itself has not 2803 -- been analyzed. 2804 2805 Analyze (Parent (Parent (Entity (Pref)))); 2806 pragma Assert (Renamed_Object (Entity (Pref)) = Par_Name); 2807 Par_Name := Entity (Pref); 2808 end if; 2809 2810 -- Guard against missing or misspelled child units 2811 2812 if Present (Par_Name) then 2813 Set_Entity_With_Checks (Pref, Par_Name); 2814 Generate_Reference (Par_Name, Pref); 2815 2816 else 2817 pragma Assert (Serious_Errors_Detected /= 0); 2818 2819 -- Mark the node to indicate that a related error has been posted. 2820 -- This defends further compilation passes against improper use of 2821 -- the invalid WITH clause node. 2822 2823 Set_Error_Posted (N); 2824 Set_Name (N, Error); 2825 return; 2826 end if; 2827 end if; 2828 2829 -- If the withed unit is System, and a system extension pragma is 2830 -- present, compile the extension now, rather than waiting for a 2831 -- visibility check on a specific entity. 2832 2833 if Chars (E_Name) = Name_System 2834 and then Scope (E_Name) = Standard_Standard 2835 and then Present (System_Extend_Unit) 2836 and then Present_System_Aux (N) 2837 then 2838 -- If the extension is not present, an error will have been emitted 2839 2840 null; 2841 end if; 2842 2843 -- Ada 2005 (AI-262): Remove from visibility the entity corresponding 2844 -- to private_with units; they will be made visible later (just before 2845 -- the private part is analyzed) 2846 2847 if Private_Present (N) then 2848 Set_Is_Immediately_Visible (E_Name, False); 2849 end if; 2850 2851 -- Propagate Fatal_Error setting from with'ed unit to current unit 2852 2853 case Fatal_Error (Get_Source_Unit (Library_Unit (N))) is 2854 2855 -- Nothing to do if with'ed unit had no error 2856 2857 when None => 2858 null; 2859 2860 -- If with'ed unit had a detected fatal error, propagate it 2861 2862 when Error_Detected => 2863 Set_Fatal_Error (Current_Sem_Unit, Error_Detected); 2864 2865 -- If with'ed unit had an ignored error, then propagate it but do not 2866 -- overide an existring setting. 2867 2868 when Error_Ignored => 2869 if Fatal_Error (Current_Sem_Unit) = None then 2870 Set_Fatal_Error (Current_Sem_Unit, Error_Ignored); 2871 end if; 2872 end case; 2873 2874 Mark_Ghost_Clause (N); 2875 end Analyze_With_Clause; 2876 2877 ------------------------------ 2878 -- Check_Private_Child_Unit -- 2879 ------------------------------ 2880 2881 procedure Check_Private_Child_Unit (N : Node_Id) is 2882 Lib_Unit : constant Node_Id := Unit (N); 2883 Item : Node_Id; 2884 Curr_Unit : Entity_Id; 2885 Sub_Parent : Node_Id; 2886 Priv_Child : Entity_Id; 2887 Par_Lib : Entity_Id; 2888 Par_Spec : Node_Id; 2889 2890 function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean; 2891 -- Returns true if and only if the library unit is declared with 2892 -- an explicit designation of private. 2893 2894 ----------------------------- 2895 -- Is_Private_Library_Unit -- 2896 ----------------------------- 2897 2898 function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is 2899 Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit)); 2900 2901 begin 2902 return Private_Present (Comp_Unit); 2903 end Is_Private_Library_Unit; 2904 2905 -- Start of processing for Check_Private_Child_Unit 2906 2907 begin 2908 if Nkind_In (Lib_Unit, N_Package_Body, N_Subprogram_Body) then 2909 Curr_Unit := Defining_Entity (Unit (Library_Unit (N))); 2910 Par_Lib := Curr_Unit; 2911 2912 elsif Nkind (Lib_Unit) = N_Subunit then 2913 2914 -- The parent is itself a body. The parent entity is to be found in 2915 -- the corresponding spec. 2916 2917 Sub_Parent := Library_Unit (N); 2918 Curr_Unit := Defining_Entity (Unit (Library_Unit (Sub_Parent))); 2919 2920 -- If the parent itself is a subunit, Curr_Unit is the entity of the 2921 -- enclosing body, retrieve the spec entity which is the proper 2922 -- ancestor we need for the following tests. 2923 2924 if Ekind (Curr_Unit) = E_Package_Body then 2925 Curr_Unit := Spec_Entity (Curr_Unit); 2926 end if; 2927 2928 Par_Lib := Curr_Unit; 2929 2930 else 2931 Curr_Unit := Defining_Entity (Lib_Unit); 2932 2933 Par_Lib := Curr_Unit; 2934 Par_Spec := Parent_Spec (Lib_Unit); 2935 2936 if No (Par_Spec) then 2937 Par_Lib := Empty; 2938 else 2939 Par_Lib := Defining_Entity (Unit (Par_Spec)); 2940 end if; 2941 end if; 2942 2943 -- Loop through context items 2944 2945 Item := First (Context_Items (N)); 2946 while Present (Item) loop 2947 2948 -- Ada 2005 (AI-262): Allow private_with of a private child package 2949 -- in public siblings 2950 2951 if Nkind (Item) = N_With_Clause 2952 and then not Implicit_With (Item) 2953 and then not Limited_Present (Item) 2954 and then Is_Private_Descendant (Entity (Name (Item))) 2955 then 2956 Priv_Child := Entity (Name (Item)); 2957 2958 declare 2959 Curr_Parent : Entity_Id := Par_Lib; 2960 Child_Parent : Entity_Id := Scope (Priv_Child); 2961 Prv_Ancestor : Entity_Id := Child_Parent; 2962 Curr_Private : Boolean := Is_Private_Library_Unit (Curr_Unit); 2963 2964 begin 2965 -- If the child unit is a public child then locate the nearest 2966 -- private ancestor. Child_Parent will then be set to the 2967 -- parent of that ancestor. 2968 2969 if not Is_Private_Library_Unit (Priv_Child) then 2970 while Present (Prv_Ancestor) 2971 and then not Is_Private_Library_Unit (Prv_Ancestor) 2972 loop 2973 Prv_Ancestor := Scope (Prv_Ancestor); 2974 end loop; 2975 2976 if Present (Prv_Ancestor) then 2977 Child_Parent := Scope (Prv_Ancestor); 2978 end if; 2979 end if; 2980 2981 while Present (Curr_Parent) 2982 and then Curr_Parent /= Standard_Standard 2983 and then Curr_Parent /= Child_Parent 2984 loop 2985 Curr_Private := 2986 Curr_Private or else Is_Private_Library_Unit (Curr_Parent); 2987 Curr_Parent := Scope (Curr_Parent); 2988 end loop; 2989 2990 if No (Curr_Parent) then 2991 Curr_Parent := Standard_Standard; 2992 end if; 2993 2994 if Curr_Parent /= Child_Parent then 2995 if Ekind (Priv_Child) = E_Generic_Package 2996 and then Chars (Priv_Child) in Text_IO_Package_Name 2997 and then Chars (Scope (Scope (Priv_Child))) = Name_Ada 2998 and then Scope (Scope (Scope (Priv_Child))) = 2999 Standard_Standard 3000 then 3001 Error_Msg_NE 3002 ("& is a nested package, not a compilation unit", 3003 Name (Item), Priv_Child); 3004 3005 else 3006 Error_Msg_N 3007 ("unit in with clause is private child unit!", Item); 3008 Error_Msg_NE 3009 ("\current unit must also have parent&!", 3010 Item, Child_Parent); 3011 end if; 3012 3013 elsif Curr_Private 3014 or else Private_Present (Item) 3015 or else Nkind_In (Lib_Unit, N_Package_Body, N_Subunit) 3016 or else (Nkind (Lib_Unit) = N_Subprogram_Body 3017 and then not Acts_As_Spec (Parent (Lib_Unit))) 3018 then 3019 null; 3020 3021 else 3022 Error_Msg_NE 3023 ("current unit must also be private descendant of&", 3024 Item, Child_Parent); 3025 end if; 3026 end; 3027 end if; 3028 3029 Next (Item); 3030 end loop; 3031 end Check_Private_Child_Unit; 3032 3033 ---------------------- 3034 -- Check_Stub_Level -- 3035 ---------------------- 3036 3037 procedure Check_Stub_Level (N : Node_Id) is 3038 Par : constant Node_Id := Parent (N); 3039 Kind : constant Node_Kind := Nkind (Par); 3040 3041 begin 3042 if Nkind_In (Kind, N_Package_Body, 3043 N_Subprogram_Body, 3044 N_Task_Body, 3045 N_Protected_Body) 3046 and then Nkind_In (Parent (Par), N_Compilation_Unit, N_Subunit) 3047 then 3048 null; 3049 3050 -- In an instance, a missing stub appears at any level. A warning 3051 -- message will have been emitted already for the missing file. 3052 3053 elsif not In_Instance then 3054 Error_Msg_N ("stub cannot appear in an inner scope", N); 3055 3056 elsif Expander_Active then 3057 Error_Msg_N ("missing proper body", N); 3058 end if; 3059 end Check_Stub_Level; 3060 3061 ------------------------ 3062 -- Expand_With_Clause -- 3063 ------------------------ 3064 3065 procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id) is 3066 Loc : constant Source_Ptr := Sloc (Nam); 3067 3068 function Build_Unit_Name (Nam : Node_Id) return Node_Id; 3069 -- Build name to be used in implicit with_clause. In most cases this 3070 -- is the source name, but if renamings are present we must make the 3071 -- original unit visible, not the one it renames. The entity in the 3072 -- with clause is the renamed unit, but the identifier is the one from 3073 -- the source, which allows us to recover the unit renaming. 3074 3075 --------------------- 3076 -- Build_Unit_Name -- 3077 --------------------- 3078 3079 function Build_Unit_Name (Nam : Node_Id) return Node_Id is 3080 Ent : Entity_Id; 3081 Result : Node_Id; 3082 3083 begin 3084 if Nkind (Nam) = N_Identifier then 3085 return New_Occurrence_Of (Entity (Nam), Loc); 3086 3087 else 3088 Ent := Entity (Nam); 3089 3090 if Present (Entity (Selector_Name (Nam))) 3091 and then Chars (Entity (Selector_Name (Nam))) /= Chars (Ent) 3092 and then 3093 Nkind (Unit_Declaration_Node (Entity (Selector_Name (Nam)))) = 3094 N_Package_Renaming_Declaration 3095 then 3096 -- The name in the with_clause is of the form A.B.C, and B is 3097 -- given by a renaming declaration. In that case we may not 3098 -- have analyzed the unit for B, but replaced it directly in 3099 -- lib-load with the unit it renames. We have to make A.B 3100 -- visible, so analyze the declaration for B now, in case it 3101 -- has not been done yet. 3102 3103 Ent := Entity (Selector_Name (Nam)); 3104 Analyze 3105 (Parent 3106 (Unit_Declaration_Node (Entity (Selector_Name (Nam))))); 3107 end if; 3108 3109 Result := 3110 Make_Expanded_Name (Loc, 3111 Chars => Chars (Entity (Nam)), 3112 Prefix => Build_Unit_Name (Prefix (Nam)), 3113 Selector_Name => New_Occurrence_Of (Ent, Loc)); 3114 Set_Entity (Result, Ent); 3115 3116 return Result; 3117 end if; 3118 end Build_Unit_Name; 3119 3120 -- Local variables 3121 3122 Ent : constant Entity_Id := Entity (Nam); 3123 Withn : Node_Id; 3124 3125 -- Start of processing for Expand_With_Clause 3126 3127 begin 3128 Withn := 3129 Make_With_Clause (Loc, 3130 Name => Build_Unit_Name (Nam)); 3131 3132 Set_Corresponding_Spec (Withn, Ent); 3133 Set_First_Name (Withn); 3134 Set_Implicit_With (Withn); 3135 Set_Library_Unit (Withn, Parent (Unit_Declaration_Node (Ent))); 3136 Set_Parent_With (Withn); 3137 3138 -- If the unit is a package or generic package declaration, a private_ 3139 -- with_clause on a child unit implies that the implicit with on the 3140 -- parent is also private. 3141 3142 if Nkind_In (Unit (N), N_Generic_Package_Declaration, 3143 N_Package_Declaration) 3144 then 3145 Set_Private_Present (Withn, Private_Present (Item)); 3146 end if; 3147 3148 Prepend (Withn, Context_Items (N)); 3149 Mark_Rewrite_Insertion (Withn); 3150 Install_Withed_Unit (Withn); 3151 3152 -- If we have "with X.Y;", we want to recurse on "X", except in the 3153 -- unusual case where X.Y is a renaming of X. In that case, the scope 3154 -- of X will be null. 3155 3156 if Nkind (Nam) = N_Expanded_Name 3157 and then Present (Scope (Entity (Prefix (Nam)))) 3158 then 3159 Expand_With_Clause (Item, Prefix (Nam), N); 3160 end if; 3161 end Expand_With_Clause; 3162 3163 -------------------------------- 3164 -- Generate_Parent_References -- 3165 -------------------------------- 3166 3167 procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id) is 3168 Pref : Node_Id; 3169 P_Name : Entity_Id := P_Id; 3170 3171 begin 3172 if Nkind (N) = N_Subunit then 3173 Pref := Name (N); 3174 else 3175 Pref := Name (Parent (Defining_Entity (N))); 3176 end if; 3177 3178 if Nkind (Pref) = N_Expanded_Name then 3179 3180 -- Done already, if the unit has been compiled indirectly as 3181 -- part of the closure of its context because of inlining. 3182 3183 return; 3184 end if; 3185 3186 while Nkind (Pref) = N_Selected_Component loop 3187 Change_Selected_Component_To_Expanded_Name (Pref); 3188 Set_Entity (Pref, P_Name); 3189 Set_Etype (Pref, Etype (P_Name)); 3190 Generate_Reference (P_Name, Pref, 'r'); 3191 Pref := Prefix (Pref); 3192 P_Name := Scope (P_Name); 3193 end loop; 3194 3195 -- The guard here on P_Name is to handle the error condition where 3196 -- the parent unit is missing because the file was not found. 3197 3198 if Present (P_Name) then 3199 Set_Entity (Pref, P_Name); 3200 Set_Etype (Pref, Etype (P_Name)); 3201 Generate_Reference (P_Name, Pref, 'r'); 3202 Style.Check_Identifier (Pref, P_Name); 3203 end if; 3204 end Generate_Parent_References; 3205 3206 --------------------- 3207 -- Has_With_Clause -- 3208 --------------------- 3209 3210 function Has_With_Clause 3211 (C_Unit : Node_Id; 3212 Pack : Entity_Id; 3213 Is_Limited : Boolean := False) return Boolean 3214 is 3215 Item : Node_Id; 3216 3217 function Named_Unit (Clause : Node_Id) return Entity_Id; 3218 -- Return the entity for the unit named in a [limited] with clause 3219 3220 ---------------- 3221 -- Named_Unit -- 3222 ---------------- 3223 3224 function Named_Unit (Clause : Node_Id) return Entity_Id is 3225 begin 3226 if Nkind (Name (Clause)) = N_Selected_Component then 3227 return Entity (Selector_Name (Name (Clause))); 3228 else 3229 return Entity (Name (Clause)); 3230 end if; 3231 end Named_Unit; 3232 3233 -- Start of processing for Has_With_Clause 3234 3235 begin 3236 if Present (Context_Items (C_Unit)) then 3237 Item := First (Context_Items (C_Unit)); 3238 while Present (Item) loop 3239 if Nkind (Item) = N_With_Clause 3240 and then Limited_Present (Item) = Is_Limited 3241 and then Named_Unit (Item) = Pack 3242 then 3243 return True; 3244 end if; 3245 3246 Next (Item); 3247 end loop; 3248 end if; 3249 3250 return False; 3251 end Has_With_Clause; 3252 3253 ----------------------------- 3254 -- Implicit_With_On_Parent -- 3255 ----------------------------- 3256 3257 procedure Implicit_With_On_Parent 3258 (Child_Unit : Node_Id; 3259 N : Node_Id) 3260 is 3261 Loc : constant Source_Ptr := Sloc (N); 3262 P : constant Node_Id := Parent_Spec (Child_Unit); 3263 P_Unit : Node_Id := Unit (P); 3264 P_Name : constant Entity_Id := Get_Parent_Entity (P_Unit); 3265 Withn : Node_Id; 3266 3267 function Build_Ancestor_Name (P : Node_Id) return Node_Id; 3268 -- Build prefix of child unit name. Recurse if needed 3269 3270 function Build_Unit_Name return Node_Id; 3271 -- If the unit is a child unit, build qualified name with all ancestors 3272 3273 ------------------------- 3274 -- Build_Ancestor_Name -- 3275 ------------------------- 3276 3277 function Build_Ancestor_Name (P : Node_Id) return Node_Id is 3278 P_Ref : constant Node_Id := 3279 New_Occurrence_Of (Defining_Entity (P), Loc); 3280 P_Spec : Node_Id := P; 3281 3282 begin 3283 -- Ancestor may have been rewritten as a package body. Retrieve the 3284 -- original spec to trace earlier ancestors. 3285 3286 if Nkind (P) = N_Package_Body 3287 and then Nkind (Original_Node (P)) = N_Package_Instantiation 3288 then 3289 P_Spec := Original_Node (P); 3290 end if; 3291 3292 if No (Parent_Spec (P_Spec)) then 3293 return P_Ref; 3294 else 3295 return 3296 Make_Selected_Component (Loc, 3297 Prefix => 3298 Build_Ancestor_Name (Unit (Parent_Spec (P_Spec))), 3299 Selector_Name => P_Ref); 3300 end if; 3301 end Build_Ancestor_Name; 3302 3303 --------------------- 3304 -- Build_Unit_Name -- 3305 --------------------- 3306 3307 function Build_Unit_Name return Node_Id is 3308 Result : Node_Id; 3309 3310 begin 3311 if No (Parent_Spec (P_Unit)) then 3312 return New_Occurrence_Of (P_Name, Loc); 3313 3314 else 3315 Result := 3316 Make_Expanded_Name (Loc, 3317 Chars => Chars (P_Name), 3318 Prefix => 3319 Build_Ancestor_Name (Unit (Parent_Spec (P_Unit))), 3320 Selector_Name => New_Occurrence_Of (P_Name, Loc)); 3321 Set_Entity (Result, P_Name); 3322 3323 return Result; 3324 end if; 3325 end Build_Unit_Name; 3326 3327 -- Start of processing for Implicit_With_On_Parent 3328 3329 begin 3330 -- The unit of the current compilation may be a package body that 3331 -- replaces an instance node. In this case we need the original instance 3332 -- node to construct the proper parent name. 3333 3334 if Nkind (P_Unit) = N_Package_Body 3335 and then Nkind (Original_Node (P_Unit)) = N_Package_Instantiation 3336 then 3337 P_Unit := Original_Node (P_Unit); 3338 end if; 3339 3340 -- We add the implicit with if the child unit is the current unit being 3341 -- compiled. If the current unit is a body, we do not want to add an 3342 -- implicit_with a second time to the corresponding spec. 3343 3344 if Nkind (Child_Unit) = N_Package_Declaration 3345 and then Child_Unit /= Unit (Cunit (Current_Sem_Unit)) 3346 then 3347 return; 3348 end if; 3349 3350 Withn := Make_With_Clause (Loc, Name => Build_Unit_Name); 3351 3352 Set_Corresponding_Spec (Withn, P_Name); 3353 Set_First_Name (Withn); 3354 Set_Implicit_With (Withn); 3355 Set_Library_Unit (Withn, P); 3356 Set_Parent_With (Withn); 3357 3358 -- Node is placed at the beginning of the context items, so that 3359 -- subsequent use clauses on the parent can be validated. 3360 3361 Prepend (Withn, Context_Items (N)); 3362 Mark_Rewrite_Insertion (Withn); 3363 Install_Withed_Unit (Withn); 3364 3365 if Is_Child_Spec (P_Unit) then 3366 Implicit_With_On_Parent (P_Unit, N); 3367 end if; 3368 end Implicit_With_On_Parent; 3369 3370 -------------- 3371 -- In_Chain -- 3372 -------------- 3373 3374 function In_Chain (E : Entity_Id) return Boolean is 3375 H : Entity_Id; 3376 3377 begin 3378 H := Current_Entity (E); 3379 while Present (H) loop 3380 if H = E then 3381 return True; 3382 else 3383 H := Homonym (H); 3384 end if; 3385 end loop; 3386 3387 return False; 3388 end In_Chain; 3389 3390 --------------------- 3391 -- Install_Context -- 3392 --------------------- 3393 3394 procedure Install_Context (N : Node_Id; Chain : Boolean := True) is 3395 Lib_Unit : constant Node_Id := Unit (N); 3396 3397 begin 3398 Install_Context_Clauses (N, Chain); 3399 3400 if Is_Child_Spec (Lib_Unit) then 3401 Install_Parents 3402 (Lib_Unit => Lib_Unit, 3403 Is_Private => Private_Present (Parent (Lib_Unit)), 3404 Chain => Chain); 3405 end if; 3406 3407 Install_Limited_Context_Clauses (N); 3408 end Install_Context; 3409 3410 ----------------------------- 3411 -- Install_Context_Clauses -- 3412 ----------------------------- 3413 3414 procedure Install_Context_Clauses (N : Node_Id; Chain : Boolean := True) is 3415 Lib_Unit : constant Node_Id := Unit (N); 3416 Item : Node_Id; 3417 Uname_Node : Entity_Id; 3418 Check_Private : Boolean := False; 3419 Decl_Node : Node_Id; 3420 Lib_Parent : Entity_Id; 3421 3422 begin 3423 -- First skip configuration pragmas at the start of the context. They 3424 -- are not technically part of the context clause, but that's where the 3425 -- parser puts them. Note they were analyzed in Analyze_Context. 3426 3427 Item := First (Context_Items (N)); 3428 while Present (Item) 3429 and then Nkind (Item) = N_Pragma 3430 and then Pragma_Name (Item) in Configuration_Pragma_Names 3431 loop 3432 Next (Item); 3433 end loop; 3434 3435 -- Loop through the actual context clause items. We process everything 3436 -- except Limited_With clauses in this routine. Limited_With clauses 3437 -- are separately installed (see Install_Limited_Context_Clauses). 3438 3439 while Present (Item) loop 3440 3441 -- Case of explicit WITH clause 3442 3443 if Nkind (Item) = N_With_Clause 3444 and then not Implicit_With (Item) 3445 then 3446 if Limited_Present (Item) then 3447 3448 -- Limited withed units will be installed later 3449 3450 goto Continue; 3451 3452 -- If Name (Item) is not an entity name, something is wrong, and 3453 -- this will be detected in due course, for now ignore the item 3454 3455 elsif not Is_Entity_Name (Name (Item)) then 3456 goto Continue; 3457 3458 elsif No (Entity (Name (Item))) then 3459 Set_Entity (Name (Item), Any_Id); 3460 goto Continue; 3461 end if; 3462 3463 Uname_Node := Entity (Name (Item)); 3464 3465 if Is_Private_Descendant (Uname_Node) then 3466 Check_Private := True; 3467 end if; 3468 3469 Install_Withed_Unit (Item); 3470 3471 Decl_Node := Unit_Declaration_Node (Uname_Node); 3472 3473 -- If the unit is a subprogram instance, it appears nested within 3474 -- a package that carries the parent information. 3475 3476 if Is_Generic_Instance (Uname_Node) 3477 and then Ekind (Uname_Node) /= E_Package 3478 then 3479 Decl_Node := Parent (Parent (Decl_Node)); 3480 end if; 3481 3482 if Is_Child_Spec (Decl_Node) then 3483 if Nkind (Name (Item)) = N_Expanded_Name then 3484 Expand_With_Clause (Item, Prefix (Name (Item)), N); 3485 else 3486 -- If not an expanded name, the child unit must be a 3487 -- renaming, nothing to do. 3488 3489 null; 3490 end if; 3491 3492 elsif Nkind (Decl_Node) = N_Subprogram_Body 3493 and then not Acts_As_Spec (Parent (Decl_Node)) 3494 and then Is_Child_Spec (Unit (Library_Unit (Parent (Decl_Node)))) 3495 then 3496 Implicit_With_On_Parent 3497 (Unit (Library_Unit (Parent (Decl_Node))), N); 3498 end if; 3499 3500 -- Check license conditions unless this is a dummy unit 3501 3502 if Sloc (Library_Unit (Item)) /= No_Location then 3503 License_Check : declare 3504 Withu : constant Unit_Number_Type := 3505 Get_Source_Unit (Library_Unit (Item)); 3506 Withl : constant License_Type := 3507 License (Source_Index (Withu)); 3508 Unitl : constant License_Type := 3509 License (Source_Index (Current_Sem_Unit)); 3510 3511 procedure License_Error; 3512 -- Signal error of bad license 3513 3514 ------------------- 3515 -- License_Error -- 3516 ------------------- 3517 3518 procedure License_Error is 3519 begin 3520 Error_Msg_N 3521 ("license of withed unit & may be inconsistent??", 3522 Name (Item)); 3523 end License_Error; 3524 3525 -- Start of processing for License_Check 3526 3527 begin 3528 -- Exclude license check if withed unit is an internal unit. 3529 -- This situation arises e.g. with the GPL version of GNAT. 3530 3531 if Is_Internal_Unit (Withu) then 3532 null; 3533 3534 -- Otherwise check various cases 3535 else 3536 case Unitl is 3537 when Unknown => 3538 null; 3539 3540 when Restricted => 3541 if Withl = GPL then 3542 License_Error; 3543 end if; 3544 3545 when GPL => 3546 if Withl = Restricted then 3547 License_Error; 3548 end if; 3549 3550 when Modified_GPL => 3551 if Withl = Restricted or else Withl = GPL then 3552 License_Error; 3553 end if; 3554 3555 when Unrestricted => 3556 null; 3557 end case; 3558 end if; 3559 end License_Check; 3560 end if; 3561 3562 -- Case of USE PACKAGE clause 3563 3564 elsif Nkind (Item) = N_Use_Package_Clause then 3565 Analyze_Use_Package (Item, Chain); 3566 3567 -- Case of USE TYPE clause 3568 3569 elsif Nkind (Item) = N_Use_Type_Clause then 3570 Analyze_Use_Type (Item, Chain); 3571 3572 -- case of PRAGMA 3573 3574 elsif Nkind (Item) = N_Pragma then 3575 Analyze (Item); 3576 end if; 3577 3578 <<Continue>> 3579 Next (Item); 3580 end loop; 3581 3582 if Is_Child_Spec (Lib_Unit) then 3583 3584 -- The unit also has implicit with_clauses on its own parents 3585 3586 if No (Context_Items (N)) then 3587 Set_Context_Items (N, New_List); 3588 end if; 3589 3590 Implicit_With_On_Parent (Lib_Unit, N); 3591 end if; 3592 3593 -- If the unit is a body, the context of the specification must also 3594 -- be installed. That includes private with_clauses in that context. 3595 3596 if Nkind (Lib_Unit) = N_Package_Body 3597 or else (Nkind (Lib_Unit) = N_Subprogram_Body 3598 and then not Acts_As_Spec (N)) 3599 then 3600 Install_Context (Library_Unit (N), Chain); 3601 3602 -- Only install private with-clauses of a spec that comes from 3603 -- source, excluding specs created for a subprogram body that is 3604 -- a child unit. 3605 3606 if Comes_From_Source (Library_Unit (N)) then 3607 Install_Private_With_Clauses 3608 (Defining_Entity (Unit (Library_Unit (N)))); 3609 end if; 3610 3611 if Is_Child_Spec (Unit (Library_Unit (N))) then 3612 3613 -- If the unit is the body of a public child unit, the private 3614 -- declarations of the parent must be made visible. If the child 3615 -- unit is private, the private declarations have been installed 3616 -- already in the call to Install_Parents for the spec. Installing 3617 -- private declarations must be done for all ancestors of public 3618 -- child units. In addition, sibling units mentioned in the 3619 -- context clause of the body are directly visible. 3620 3621 declare 3622 Lib_Spec : Node_Id; 3623 P : Node_Id; 3624 P_Name : Entity_Id; 3625 3626 begin 3627 Lib_Spec := Unit (Library_Unit (N)); 3628 while Is_Child_Spec (Lib_Spec) loop 3629 P := Unit (Parent_Spec (Lib_Spec)); 3630 P_Name := Defining_Entity (P); 3631 3632 if not (Private_Present (Parent (Lib_Spec))) 3633 and then not In_Private_Part (P_Name) 3634 then 3635 Install_Private_Declarations (P_Name); 3636 Install_Private_With_Clauses (P_Name); 3637 Set_Use (Private_Declarations (Specification (P))); 3638 end if; 3639 3640 Lib_Spec := P; 3641 end loop; 3642 end; 3643 end if; 3644 3645 -- For a package body, children in context are immediately visible 3646 3647 Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N); 3648 end if; 3649 3650 if Nkind_In (Lib_Unit, N_Generic_Package_Declaration, 3651 N_Generic_Subprogram_Declaration, 3652 N_Package_Declaration, 3653 N_Subprogram_Declaration) 3654 then 3655 if Is_Child_Spec (Lib_Unit) then 3656 Lib_Parent := Defining_Entity (Unit (Parent_Spec (Lib_Unit))); 3657 Set_Is_Private_Descendant 3658 (Defining_Entity (Lib_Unit), 3659 Is_Private_Descendant (Lib_Parent) 3660 or else Private_Present (Parent (Lib_Unit))); 3661 3662 else 3663 Set_Is_Private_Descendant 3664 (Defining_Entity (Lib_Unit), 3665 Private_Present (Parent (Lib_Unit))); 3666 end if; 3667 end if; 3668 3669 if Check_Private then 3670 Check_Private_Child_Unit (N); 3671 end if; 3672 end Install_Context_Clauses; 3673 3674 ------------------------------------- 3675 -- Install_Limited_Context_Clauses -- 3676 ------------------------------------- 3677 3678 procedure Install_Limited_Context_Clauses (N : Node_Id) is 3679 Item : Node_Id; 3680 3681 procedure Check_Renamings (P : Node_Id; W : Node_Id); 3682 -- Check that the unlimited view of a given compilation_unit is not 3683 -- already visible through "use + renamings". 3684 3685 procedure Check_Private_Limited_Withed_Unit (Item : Node_Id); 3686 -- Check that if a limited_with clause of a given compilation_unit 3687 -- mentions a descendant of a private child of some library unit, then 3688 -- the given compilation_unit must be the declaration of a private 3689 -- descendant of that library unit, or a public descendant of such. The 3690 -- code is analogous to that of Check_Private_Child_Unit but we cannot 3691 -- use entities on the limited with_clauses because their units have not 3692 -- been analyzed, so we have to climb the tree of ancestors looking for 3693 -- private keywords. 3694 3695 procedure Expand_Limited_With_Clause 3696 (Comp_Unit : Node_Id; 3697 Nam : Node_Id; 3698 N : Node_Id); 3699 -- If a child unit appears in a limited_with clause, there are implicit 3700 -- limited_with clauses on all parents that are not already visible 3701 -- through a regular with clause. This procedure creates the implicit 3702 -- limited with_clauses for the parents and loads the corresponding 3703 -- units. The shadow entities are created when the inserted clause is 3704 -- analyzed. Implements Ada 2005 (AI-50217). 3705 3706 --------------------- 3707 -- Check_Renamings -- 3708 --------------------- 3709 3710 procedure Check_Renamings (P : Node_Id; W : Node_Id) is 3711 Item : Node_Id; 3712 Spec : Node_Id; 3713 WEnt : Entity_Id; 3714 E : Entity_Id; 3715 E2 : Entity_Id; 3716 3717 begin 3718 pragma Assert (Nkind (W) = N_With_Clause); 3719 3720 -- Protect the frontend against previous critical errors 3721 3722 case Nkind (Unit (Library_Unit (W))) is 3723 when N_Generic_Package_Declaration 3724 | N_Generic_Subprogram_Declaration 3725 | N_Package_Declaration 3726 | N_Subprogram_Declaration 3727 => 3728 null; 3729 3730 when others => 3731 return; 3732 end case; 3733 3734 -- Check "use + renamings" 3735 3736 WEnt := Defining_Unit_Name (Specification (Unit (Library_Unit (W)))); 3737 Spec := Specification (Unit (P)); 3738 3739 Item := First (Visible_Declarations (Spec)); 3740 while Present (Item) loop 3741 3742 -- Look only at use package clauses 3743 3744 if Nkind (Item) = N_Use_Package_Clause then 3745 3746 E := Entity (Name (Item)); 3747 3748 pragma Assert (Present (Parent (E))); 3749 3750 if Nkind (Parent (E)) = N_Package_Renaming_Declaration 3751 and then Renamed_Entity (E) = WEnt 3752 then 3753 -- The unlimited view is visible through use clause and 3754 -- renamings. There is no need to generate the error 3755 -- message here because Is_Visible_Through_Renamings 3756 -- takes care of generating the precise error message. 3757 3758 return; 3759 3760 elsif Nkind (Parent (E)) = N_Package_Specification then 3761 3762 -- The use clause may refer to a local package. 3763 -- Check all the enclosing scopes. 3764 3765 E2 := E; 3766 while E2 /= Standard_Standard and then E2 /= WEnt loop 3767 E2 := Scope (E2); 3768 end loop; 3769 3770 if E2 = WEnt then 3771 Error_Msg_N 3772 ("unlimited view visible through use clause ", W); 3773 return; 3774 end if; 3775 end if; 3776 end if; 3777 3778 Next (Item); 3779 end loop; 3780 3781 -- Recursive call to check all the ancestors 3782 3783 if Is_Child_Spec (Unit (P)) then 3784 Check_Renamings (P => Parent_Spec (Unit (P)), W => W); 3785 end if; 3786 end Check_Renamings; 3787 3788 --------------------------------------- 3789 -- Check_Private_Limited_Withed_Unit -- 3790 --------------------------------------- 3791 3792 procedure Check_Private_Limited_Withed_Unit (Item : Node_Id) is 3793 Curr_Parent : Node_Id; 3794 Child_Parent : Node_Id; 3795 Curr_Private : Boolean; 3796 3797 begin 3798 -- Compilation unit of the parent of the withed library unit 3799 3800 Child_Parent := Library_Unit (Item); 3801 3802 -- If the child unit is a public child, then locate its nearest 3803 -- private ancestor, if any, then Child_Parent will then be set to 3804 -- the parent of that ancestor. 3805 3806 if not Private_Present (Library_Unit (Item)) then 3807 while Present (Child_Parent) 3808 and then not Private_Present (Child_Parent) 3809 loop 3810 Child_Parent := Parent_Spec (Unit (Child_Parent)); 3811 end loop; 3812 3813 if No (Child_Parent) then 3814 return; 3815 end if; 3816 end if; 3817 3818 Child_Parent := Parent_Spec (Unit (Child_Parent)); 3819 3820 -- Traverse all the ancestors of the current compilation unit to 3821 -- check if it is a descendant of named library unit. 3822 3823 Curr_Parent := Parent (Item); 3824 Curr_Private := Private_Present (Curr_Parent); 3825 3826 while Present (Parent_Spec (Unit (Curr_Parent))) 3827 and then Curr_Parent /= Child_Parent 3828 loop 3829 Curr_Parent := Parent_Spec (Unit (Curr_Parent)); 3830 Curr_Private := Curr_Private or else Private_Present (Curr_Parent); 3831 end loop; 3832 3833 if Curr_Parent /= Child_Parent then 3834 Error_Msg_N 3835 ("unit in with clause is private child unit!", Item); 3836 Error_Msg_NE 3837 ("\current unit must also have parent&!", 3838 Item, Defining_Unit_Name (Specification (Unit (Child_Parent)))); 3839 3840 elsif Private_Present (Parent (Item)) 3841 or else Curr_Private 3842 or else Private_Present (Item) 3843 or else Nkind_In (Unit (Parent (Item)), N_Package_Body, 3844 N_Subprogram_Body, 3845 N_Subunit) 3846 then 3847 -- Current unit is private, of descendant of a private unit 3848 3849 null; 3850 3851 else 3852 Error_Msg_NE 3853 ("current unit must also be private descendant of&", 3854 Item, Defining_Unit_Name (Specification (Unit (Child_Parent)))); 3855 end if; 3856 end Check_Private_Limited_Withed_Unit; 3857 3858 -------------------------------- 3859 -- Expand_Limited_With_Clause -- 3860 -------------------------------- 3861 3862 procedure Expand_Limited_With_Clause 3863 (Comp_Unit : Node_Id; 3864 Nam : Node_Id; 3865 N : Node_Id) 3866 is 3867 Loc : constant Source_Ptr := Sloc (Nam); 3868 Unum : Unit_Number_Type; 3869 Withn : Node_Id; 3870 3871 function Previous_Withed_Unit (W : Node_Id) return Boolean; 3872 -- Returns true if the context already includes a with_clause for 3873 -- this unit. If the with_clause is non-limited, the unit is fully 3874 -- visible and an implicit limited_with should not be created. If 3875 -- there is already a limited_with clause for W, a second one is 3876 -- simply redundant. 3877 3878 -------------------------- 3879 -- Previous_Withed_Unit -- 3880 -------------------------- 3881 3882 function Previous_Withed_Unit (W : Node_Id) return Boolean is 3883 Item : Node_Id; 3884 3885 begin 3886 -- A limited with_clause cannot appear in the same context_clause 3887 -- as a nonlimited with_clause which mentions the same library. 3888 3889 Item := First (Context_Items (Comp_Unit)); 3890 while Present (Item) loop 3891 if Nkind (Item) = N_With_Clause 3892 and then Library_Unit (Item) = Library_Unit (W) 3893 then 3894 return True; 3895 end if; 3896 3897 Next (Item); 3898 end loop; 3899 3900 return False; 3901 end Previous_Withed_Unit; 3902 3903 -- Start of processing for Expand_Limited_With_Clause 3904 3905 begin 3906 if Nkind (Nam) = N_Identifier then 3907 3908 -- Create node for name of withed unit 3909 3910 Withn := 3911 Make_With_Clause (Loc, 3912 Name => New_Copy (Nam)); 3913 3914 else pragma Assert (Nkind (Nam) = N_Selected_Component); 3915 Withn := 3916 Make_With_Clause (Loc, 3917 Name => Make_Selected_Component (Loc, 3918 Prefix => New_Copy_Tree (Prefix (Nam)), 3919 Selector_Name => New_Copy (Selector_Name (Nam)))); 3920 Set_Parent (Withn, Parent (N)); 3921 end if; 3922 3923 Set_First_Name (Withn); 3924 Set_Implicit_With (Withn); 3925 Set_Limited_Present (Withn); 3926 3927 Unum := 3928 Load_Unit 3929 (Load_Name => Get_Spec_Name (Get_Unit_Name (Nam)), 3930 Required => True, 3931 Subunit => False, 3932 Error_Node => Nam); 3933 3934 -- Do not generate a limited_with_clause on the current unit. This 3935 -- path is taken when a unit has a limited_with clause on one of its 3936 -- child units. 3937 3938 if Unum = Current_Sem_Unit then 3939 return; 3940 end if; 3941 3942 Set_Library_Unit (Withn, Cunit (Unum)); 3943 Set_Corresponding_Spec 3944 (Withn, Specification (Unit (Cunit (Unum)))); 3945 3946 if not Previous_Withed_Unit (Withn) then 3947 Prepend (Withn, Context_Items (Parent (N))); 3948 Mark_Rewrite_Insertion (Withn); 3949 3950 -- Add implicit limited_with_clauses for parents of child units 3951 -- mentioned in limited_with clauses. 3952 3953 if Nkind (Nam) = N_Selected_Component then 3954 Expand_Limited_With_Clause (Comp_Unit, Prefix (Nam), N); 3955 end if; 3956 3957 Analyze (Withn); 3958 3959 if not Limited_View_Installed (Withn) then 3960 Install_Limited_Withed_Unit (Withn); 3961 end if; 3962 end if; 3963 end Expand_Limited_With_Clause; 3964 3965 -- Start of processing for Install_Limited_Context_Clauses 3966 3967 begin 3968 Item := First (Context_Items (N)); 3969 while Present (Item) loop 3970 if Nkind (Item) = N_With_Clause 3971 and then Limited_Present (Item) 3972 and then not Error_Posted (Item) 3973 then 3974 if Nkind (Name (Item)) = N_Selected_Component then 3975 Expand_Limited_With_Clause 3976 (Comp_Unit => N, Nam => Prefix (Name (Item)), N => Item); 3977 end if; 3978 3979 Check_Private_Limited_Withed_Unit (Item); 3980 3981 if not Implicit_With (Item) and then Is_Child_Spec (Unit (N)) then 3982 Check_Renamings (Parent_Spec (Unit (N)), Item); 3983 end if; 3984 3985 -- A unit may have a limited with on itself if it has a limited 3986 -- with_clause on one of its child units. In that case it is 3987 -- already being compiled and it makes no sense to install its 3988 -- limited view. 3989 3990 -- If the item is a limited_private_with_clause, install it if the 3991 -- current unit is a body or if it is a private child. Otherwise 3992 -- the private clause is installed before analyzing the private 3993 -- part of the current unit. 3994 3995 if Library_Unit (Item) /= Cunit (Current_Sem_Unit) 3996 and then not Limited_View_Installed (Item) 3997 and then 3998 not Is_Ancestor_Unit 3999 (Library_Unit (Item), Cunit (Current_Sem_Unit)) 4000 then 4001 if not Private_Present (Item) 4002 or else Private_Present (N) 4003 or else Nkind_In (Unit (N), N_Package_Body, 4004 N_Subprogram_Body, 4005 N_Subunit) 4006 then 4007 Install_Limited_Withed_Unit (Item); 4008 end if; 4009 end if; 4010 end if; 4011 4012 Next (Item); 4013 end loop; 4014 4015 -- Ada 2005 (AI-412): Examine visible declarations of a package spec, 4016 -- looking for incomplete subtype declarations of incomplete types 4017 -- visible through a limited with clause. 4018 4019 if Ada_Version >= Ada_2005 4020 and then Analyzed (N) 4021 and then Nkind (Unit (N)) = N_Package_Declaration 4022 then 4023 declare 4024 Decl : Node_Id; 4025 Def_Id : Entity_Id; 4026 Non_Lim_View : Entity_Id; 4027 4028 begin 4029 Decl := First (Visible_Declarations (Specification (Unit (N)))); 4030 while Present (Decl) loop 4031 if Nkind (Decl) = N_Subtype_Declaration 4032 and then 4033 Ekind (Defining_Identifier (Decl)) = E_Incomplete_Subtype 4034 and then 4035 From_Limited_With (Defining_Identifier (Decl)) 4036 then 4037 Def_Id := Defining_Identifier (Decl); 4038 Non_Lim_View := Non_Limited_View (Def_Id); 4039 4040 if not Is_Incomplete_Type (Non_Lim_View) then 4041 4042 -- Convert an incomplete subtype declaration into a 4043 -- corresponding non-limited view subtype declaration. 4044 -- This is usually the case when analyzing a body that 4045 -- has regular with clauses, when the spec has limited 4046 -- ones. 4047 4048 -- If the non-limited view is still incomplete, it is 4049 -- the dummy entry already created, and the declaration 4050 -- cannot be reanalyzed. This is the case when installing 4051 -- a parent unit that has limited with-clauses. 4052 4053 Set_Subtype_Indication (Decl, 4054 New_Occurrence_Of (Non_Lim_View, Sloc (Def_Id))); 4055 Set_Etype (Def_Id, Non_Lim_View); 4056 Set_Ekind (Def_Id, Subtype_Kind (Ekind (Non_Lim_View))); 4057 Set_Analyzed (Decl, False); 4058 4059 -- Reanalyze the declaration, suppressing the call to 4060 -- Enter_Name to avoid duplicate names. 4061 4062 Analyze_Subtype_Declaration 4063 (N => Decl, 4064 Skip => True); 4065 end if; 4066 end if; 4067 4068 Next (Decl); 4069 end loop; 4070 end; 4071 end if; 4072 end Install_Limited_Context_Clauses; 4073 4074 --------------------- 4075 -- Install_Parents -- 4076 --------------------- 4077 4078 procedure Install_Parents 4079 (Lib_Unit : Node_Id; 4080 Is_Private : Boolean; 4081 Chain : Boolean := True) 4082 is 4083 P : Node_Id; 4084 E_Name : Entity_Id; 4085 P_Name : Entity_Id; 4086 P_Spec : Node_Id; 4087 4088 begin 4089 P := Unit (Parent_Spec (Lib_Unit)); 4090 P_Name := Get_Parent_Entity (P); 4091 4092 if Etype (P_Name) = Any_Type then 4093 return; 4094 end if; 4095 4096 if Ekind (P_Name) = E_Generic_Package 4097 and then not Nkind_In (Lib_Unit, N_Generic_Subprogram_Declaration, 4098 N_Generic_Package_Declaration) 4099 and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration 4100 then 4101 Error_Msg_N 4102 ("child of a generic package must be a generic unit", Lib_Unit); 4103 4104 elsif not Is_Package_Or_Generic_Package (P_Name) then 4105 Error_Msg_N 4106 ("parent unit must be package or generic package", Lib_Unit); 4107 raise Unrecoverable_Error; 4108 4109 elsif Present (Renamed_Object (P_Name)) then 4110 Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit); 4111 raise Unrecoverable_Error; 4112 4113 -- Verify that a child of an instance is itself an instance, or the 4114 -- renaming of one. Given that an instance that is a unit is replaced 4115 -- with a package declaration, check against the original node. The 4116 -- parent may be currently being instantiated, in which case it appears 4117 -- as a declaration, but the generic_parent is already established 4118 -- indicating that we deal with an instance. 4119 4120 elsif Nkind (Original_Node (P)) = N_Package_Instantiation then 4121 if Nkind (Lib_Unit) in N_Renaming_Declaration 4122 or else Nkind (Original_Node (Lib_Unit)) in N_Generic_Instantiation 4123 or else 4124 (Nkind (Lib_Unit) = N_Package_Declaration 4125 and then Present (Generic_Parent (Specification (Lib_Unit)))) 4126 then 4127 null; 4128 else 4129 Error_Msg_N 4130 ("child of an instance must be an instance or renaming", 4131 Lib_Unit); 4132 end if; 4133 end if; 4134 4135 -- This is the recursive call that ensures all parents are loaded 4136 4137 if Is_Child_Spec (P) then 4138 Install_Parents 4139 (Lib_Unit => P, 4140 Is_Private => 4141 Is_Private or else Private_Present (Parent (Lib_Unit)), 4142 Chain => Chain); 4143 end if; 4144 4145 -- Now we can install the context for this parent 4146 4147 Install_Context_Clauses (Parent_Spec (Lib_Unit), Chain); 4148 Install_Limited_Context_Clauses (Parent_Spec (Lib_Unit)); 4149 Install_Siblings (P_Name, Parent (Lib_Unit)); 4150 4151 -- The child unit is in the declarative region of the parent. The parent 4152 -- must therefore appear in the scope stack and be visible, as when 4153 -- compiling the corresponding body. If the child unit is private or it 4154 -- is a package body, private declarations must be accessible as well. 4155 -- Use declarations in the parent must also be installed. Finally, other 4156 -- child units of the same parent that are in the context are 4157 -- immediately visible. 4158 4159 -- Find entity for compilation unit, and set its private descendant 4160 -- status as needed. Indicate that it is a compilation unit, which is 4161 -- redundant in general, but needed if this is a generated child spec 4162 -- for a child body without previous spec. 4163 4164 E_Name := Defining_Entity (Lib_Unit); 4165 4166 Set_Is_Child_Unit (E_Name); 4167 Set_Is_Compilation_Unit (E_Name); 4168 4169 Set_Is_Private_Descendant (E_Name, 4170 Is_Private_Descendant (P_Name) 4171 or else Private_Present (Parent (Lib_Unit))); 4172 4173 P_Spec := Package_Specification (P_Name); 4174 Push_Scope (P_Name); 4175 4176 -- Save current visibility of unit 4177 4178 Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility := 4179 Is_Immediately_Visible (P_Name); 4180 Set_Is_Immediately_Visible (P_Name); 4181 Install_Visible_Declarations (P_Name); 4182 Set_Use (Visible_Declarations (P_Spec)); 4183 4184 -- If the parent is a generic unit, its formal part may contain formal 4185 -- packages and use clauses for them. 4186 4187 if Ekind (P_Name) = E_Generic_Package then 4188 Set_Use (Generic_Formal_Declarations (Parent (P_Spec))); 4189 end if; 4190 4191 if Is_Private or else Private_Present (Parent (Lib_Unit)) then 4192 Install_Private_Declarations (P_Name); 4193 Install_Private_With_Clauses (P_Name); 4194 Set_Use (Private_Declarations (P_Spec)); 4195 end if; 4196 end Install_Parents; 4197 4198 ---------------------------------- 4199 -- Install_Private_With_Clauses -- 4200 ---------------------------------- 4201 4202 procedure Install_Private_With_Clauses (P : Entity_Id) is 4203 Decl : constant Node_Id := Unit_Declaration_Node (P); 4204 Item : Node_Id; 4205 4206 begin 4207 if Debug_Flag_I then 4208 Write_Str ("install private with clauses of "); 4209 Write_Name (Chars (P)); 4210 Write_Eol; 4211 end if; 4212 4213 if Nkind (Parent (Decl)) = N_Compilation_Unit then 4214 Item := First (Context_Items (Parent (Decl))); 4215 while Present (Item) loop 4216 if Nkind (Item) = N_With_Clause 4217 and then Private_Present (Item) 4218 then 4219 -- If the unit is an ancestor of the current one, it is the 4220 -- case of a private limited with clause on a child unit, and 4221 -- the compilation of one of its descendants, In that case the 4222 -- limited view is errelevant. 4223 4224 if Limited_Present (Item) then 4225 if not Limited_View_Installed (Item) 4226 and then 4227 not Is_Ancestor_Unit (Library_Unit (Item), 4228 Cunit (Current_Sem_Unit)) 4229 then 4230 Install_Limited_Withed_Unit (Item); 4231 end if; 4232 else 4233 Install_Withed_Unit (Item, Private_With_OK => True); 4234 end if; 4235 end if; 4236 4237 Next (Item); 4238 end loop; 4239 end if; 4240 end Install_Private_With_Clauses; 4241 4242 ---------------------- 4243 -- Install_Siblings -- 4244 ---------------------- 4245 4246 procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id) is 4247 Item : Node_Id; 4248 Id : Entity_Id; 4249 Prev : Entity_Id; 4250 4251 begin 4252 -- Iterate over explicit with clauses, and check whether the scope of 4253 -- each entity is an ancestor of the current unit, in which case it is 4254 -- immediately visible. 4255 4256 Item := First (Context_Items (N)); 4257 while Present (Item) loop 4258 4259 -- Do not install private_with_clauses declaration, unless unit 4260 -- is itself a private child unit, or is a body. Note that for a 4261 -- subprogram body the private_with_clause does not take effect 4262 -- until after the specification. 4263 4264 if Nkind (Item) /= N_With_Clause 4265 or else Implicit_With (Item) 4266 or else Limited_Present (Item) 4267 or else Error_Posted (Item) 4268 4269 -- Skip processing malformed trees 4270 4271 or else (Try_Semantics 4272 and then Nkind (Name (Item)) not in N_Has_Entity) 4273 then 4274 null; 4275 4276 elsif not Private_Present (Item) 4277 or else Private_Present (N) 4278 or else Nkind (Unit (N)) = N_Package_Body 4279 then 4280 Id := Entity (Name (Item)); 4281 4282 if Is_Child_Unit (Id) 4283 and then Is_Ancestor_Package (Scope (Id), U_Name) 4284 then 4285 Set_Is_Immediately_Visible (Id); 4286 4287 -- Check for the presence of another unit in the context that 4288 -- may be inadvertently hidden by the child. 4289 4290 Prev := Current_Entity (Id); 4291 4292 if Present (Prev) 4293 and then Is_Immediately_Visible (Prev) 4294 and then not Is_Child_Unit (Prev) 4295 then 4296 declare 4297 Clause : Node_Id; 4298 4299 begin 4300 Clause := First (Context_Items (N)); 4301 while Present (Clause) loop 4302 if Nkind (Clause) = N_With_Clause 4303 and then Entity (Name (Clause)) = Prev 4304 then 4305 Error_Msg_NE 4306 ("child unit& hides compilation unit " & 4307 "with the same name??", 4308 Name (Item), Id); 4309 exit; 4310 end if; 4311 4312 Next (Clause); 4313 end loop; 4314 end; 4315 end if; 4316 4317 -- The With_Clause may be on a grand-child or one of its further 4318 -- descendants, which makes a child immediately visible. Examine 4319 -- ancestry to determine whether such a child exists. For example, 4320 -- if current unit is A.C, and with_clause is on A.X.Y.Z, then X 4321 -- is immediately visible. 4322 4323 elsif Is_Child_Unit (Id) then 4324 declare 4325 Par : Entity_Id; 4326 4327 begin 4328 Par := Scope (Id); 4329 while Is_Child_Unit (Par) loop 4330 if Is_Ancestor_Package (Scope (Par), U_Name) then 4331 Set_Is_Immediately_Visible (Par); 4332 exit; 4333 end if; 4334 4335 Par := Scope (Par); 4336 end loop; 4337 end; 4338 end if; 4339 4340 -- If the item is a private with-clause on a child unit, the parent 4341 -- may have been installed already, but the child unit must remain 4342 -- invisible until installed in a private part or body, unless there 4343 -- is already a regular with_clause for it in the current unit. 4344 4345 elsif Private_Present (Item) then 4346 Id := Entity (Name (Item)); 4347 4348 if Is_Child_Unit (Id) then 4349 declare 4350 Clause : Node_Id; 4351 4352 function In_Context return Boolean; 4353 -- Scan context of current unit, to check whether there is 4354 -- a with_clause on the same unit as a private with-clause 4355 -- on a parent, in which case child unit is visible. If the 4356 -- unit is a grand-child, the same applies to its parent. 4357 4358 ---------------- 4359 -- In_Context -- 4360 ---------------- 4361 4362 function In_Context return Boolean is 4363 begin 4364 Clause := 4365 First (Context_Items (Cunit (Current_Sem_Unit))); 4366 while Present (Clause) loop 4367 if Nkind (Clause) = N_With_Clause 4368 and then Comes_From_Source (Clause) 4369 and then Is_Entity_Name (Name (Clause)) 4370 and then not Private_Present (Clause) 4371 then 4372 if Entity (Name (Clause)) = Id 4373 or else 4374 (Nkind (Name (Clause)) = N_Expanded_Name 4375 and then Entity (Prefix (Name (Clause))) = Id) 4376 then 4377 return True; 4378 end if; 4379 end if; 4380 4381 Next (Clause); 4382 end loop; 4383 4384 return False; 4385 end In_Context; 4386 4387 begin 4388 Set_Is_Visible_Lib_Unit (Id, In_Context); 4389 end; 4390 end if; 4391 end if; 4392 4393 Next (Item); 4394 end loop; 4395 end Install_Siblings; 4396 4397 --------------------------------- 4398 -- Install_Limited_Withed_Unit -- 4399 --------------------------------- 4400 4401 procedure Install_Limited_Withed_Unit (N : Node_Id) is 4402 P_Unit : constant Entity_Id := Unit (Library_Unit (N)); 4403 E : Entity_Id; 4404 P : Entity_Id; 4405 Is_Child_Package : Boolean := False; 4406 Lim_Header : Entity_Id; 4407 Lim_Typ : Entity_Id; 4408 4409 procedure Check_Body_Required; 4410 -- A unit mentioned in a limited with_clause may not be mentioned in 4411 -- a regular with_clause, but must still be included in the current 4412 -- partition. We need to determine whether the unit needs a body, so 4413 -- that the binder can determine the name of the file to be compiled. 4414 -- Checking whether a unit needs a body can be done without semantic 4415 -- analysis, by examining the nature of the declarations in the package. 4416 4417 function Has_Limited_With_Clause 4418 (C_Unit : Entity_Id; 4419 Pack : Entity_Id) return Boolean; 4420 -- Determine whether any package in the ancestor chain starting with 4421 -- C_Unit has a limited with clause for package Pack. 4422 4423 function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean; 4424 -- Check if some package installed though normal with-clauses has a 4425 -- renaming declaration of package P. AARM 10.1.2(21/2). 4426 4427 ------------------------- 4428 -- Check_Body_Required -- 4429 ------------------------- 4430 4431 procedure Check_Body_Required is 4432 PA : constant List_Id := 4433 Pragmas_After (Aux_Decls_Node (Parent (P_Unit))); 4434 4435 procedure Check_Declarations (Spec : Node_Id); 4436 -- Recursive procedure that does the work and checks nested packages 4437 4438 ------------------------ 4439 -- Check_Declarations -- 4440 ------------------------ 4441 4442 procedure Check_Declarations (Spec : Node_Id) is 4443 Decl : Node_Id; 4444 Incomplete_Decls : constant Elist_Id := New_Elmt_List; 4445 4446 Subp_List : constant Elist_Id := New_Elmt_List; 4447 4448 procedure Check_Pragma_Import (P : Node_Id); 4449 -- If a pragma import applies to a previous subprogram, the 4450 -- enclosing unit may not need a body. The processing is syntactic 4451 -- and does not require a declaration to be analyzed. The code 4452 -- below also handles pragma Import when applied to a subprogram 4453 -- that renames another. In this case the pragma applies to the 4454 -- renamed entity. 4455 -- 4456 -- Chains of multiple renames are not handled by the code below. 4457 -- It is probably impossible to handle all cases without proper 4458 -- name resolution. In such cases the algorithm is conservative 4459 -- and will indicate that a body is needed??? 4460 4461 ------------------------- 4462 -- Check_Pragma_Import -- 4463 ------------------------- 4464 4465 procedure Check_Pragma_Import (P : Node_Id) is 4466 Arg : Node_Id; 4467 Prev_Id : Elmt_Id; 4468 Subp_Id : Elmt_Id; 4469 Imported : Node_Id; 4470 4471 procedure Remove_Homonyms (E : Node_Id); 4472 -- Make one pass over list of subprograms. Called again if 4473 -- subprogram is a renaming. E is known to be an identifier. 4474 4475 --------------------- 4476 -- Remove_Homonyms -- 4477 --------------------- 4478 4479 procedure Remove_Homonyms (E : Node_Id) is 4480 R : Entity_Id := Empty; 4481 -- Name of renamed entity, if any 4482 4483 begin 4484 Subp_Id := First_Elmt (Subp_List); 4485 while Present (Subp_Id) loop 4486 if Chars (Node (Subp_Id)) = Chars (E) then 4487 if Nkind (Parent (Parent (Node (Subp_Id)))) 4488 /= N_Subprogram_Renaming_Declaration 4489 then 4490 Prev_Id := Subp_Id; 4491 Next_Elmt (Subp_Id); 4492 Remove_Elmt (Subp_List, Prev_Id); 4493 else 4494 R := Name (Parent (Parent (Node (Subp_Id)))); 4495 exit; 4496 end if; 4497 else 4498 Next_Elmt (Subp_Id); 4499 end if; 4500 end loop; 4501 4502 if Present (R) then 4503 if Nkind (R) = N_Identifier then 4504 Remove_Homonyms (R); 4505 4506 elsif Nkind (R) = N_Selected_Component then 4507 Remove_Homonyms (Selector_Name (R)); 4508 4509 -- Renaming of attribute 4510 4511 else 4512 null; 4513 end if; 4514 end if; 4515 end Remove_Homonyms; 4516 4517 -- Start of processing for Check_Pragma_Import 4518 4519 begin 4520 -- Find name of entity in Import pragma. We have not analyzed 4521 -- the construct, so we must guard against syntax errors. 4522 4523 Arg := Next (First (Pragma_Argument_Associations (P))); 4524 4525 if No (Arg) 4526 or else Nkind (Expression (Arg)) /= N_Identifier 4527 then 4528 return; 4529 else 4530 Imported := Expression (Arg); 4531 end if; 4532 4533 Remove_Homonyms (Imported); 4534 end Check_Pragma_Import; 4535 4536 -- Start of processing for Check_Declarations 4537 4538 begin 4539 -- Search for Elaborate Body pragma 4540 4541 Decl := First (Visible_Declarations (Spec)); 4542 while Present (Decl) 4543 and then Nkind (Decl) = N_Pragma 4544 loop 4545 if Get_Pragma_Id (Decl) = Pragma_Elaborate_Body then 4546 Set_Body_Required (Library_Unit (N)); 4547 return; 4548 end if; 4549 4550 Next (Decl); 4551 end loop; 4552 4553 -- Look for declarations that require the presence of a body. We 4554 -- have already skipped pragmas at the start of the list. 4555 4556 while Present (Decl) loop 4557 4558 -- Subprogram that comes from source means body may be needed. 4559 -- Save for subsequent examination of import pragmas. 4560 4561 if Comes_From_Source (Decl) 4562 and then (Nkind_In (Decl, N_Subprogram_Declaration, 4563 N_Subprogram_Renaming_Declaration, 4564 N_Generic_Subprogram_Declaration)) 4565 then 4566 Append_Elmt (Defining_Entity (Decl), Subp_List); 4567 4568 -- Package declaration of generic package declaration. We need 4569 -- to recursively examine nested declarations. 4570 4571 elsif Nkind_In (Decl, N_Package_Declaration, 4572 N_Generic_Package_Declaration) 4573 then 4574 Check_Declarations (Specification (Decl)); 4575 4576 elsif Nkind (Decl) = N_Pragma 4577 and then Pragma_Name (Decl) = Name_Import 4578 then 4579 Check_Pragma_Import (Decl); 4580 end if; 4581 4582 Next (Decl); 4583 end loop; 4584 4585 -- Same set of tests for private part. In addition to subprograms 4586 -- detect the presence of Taft Amendment types (incomplete types 4587 -- completed in the body). 4588 4589 Decl := First (Private_Declarations (Spec)); 4590 while Present (Decl) loop 4591 if Comes_From_Source (Decl) 4592 and then (Nkind_In (Decl, N_Subprogram_Declaration, 4593 N_Subprogram_Renaming_Declaration, 4594 N_Generic_Subprogram_Declaration)) 4595 then 4596 Append_Elmt (Defining_Entity (Decl), Subp_List); 4597 4598 elsif Nkind_In (Decl, N_Package_Declaration, 4599 N_Generic_Package_Declaration) 4600 then 4601 Check_Declarations (Specification (Decl)); 4602 4603 -- Collect incomplete type declarations for separate pass 4604 4605 elsif Nkind (Decl) = N_Incomplete_Type_Declaration then 4606 Append_Elmt (Decl, Incomplete_Decls); 4607 4608 elsif Nkind (Decl) = N_Pragma 4609 and then Pragma_Name (Decl) = Name_Import 4610 then 4611 Check_Pragma_Import (Decl); 4612 end if; 4613 4614 Next (Decl); 4615 end loop; 4616 4617 -- Now check incomplete declarations to locate Taft amendment 4618 -- types. This can be done by examining the defining identifiers 4619 -- of type declarations without real semantic analysis. 4620 4621 declare 4622 Inc : Elmt_Id; 4623 4624 begin 4625 Inc := First_Elmt (Incomplete_Decls); 4626 while Present (Inc) loop 4627 Decl := Next (Node (Inc)); 4628 while Present (Decl) loop 4629 if Nkind (Decl) = N_Full_Type_Declaration 4630 and then Chars (Defining_Identifier (Decl)) = 4631 Chars (Defining_Identifier (Node (Inc))) 4632 then 4633 exit; 4634 end if; 4635 4636 Next (Decl); 4637 end loop; 4638 4639 -- If no completion, this is a TAT, and a body is needed 4640 4641 if No (Decl) then 4642 Set_Body_Required (Library_Unit (N)); 4643 return; 4644 end if; 4645 4646 Next_Elmt (Inc); 4647 end loop; 4648 end; 4649 4650 -- Finally, check whether there are subprograms that still require 4651 -- a body, i.e. are not renamings or null. 4652 4653 if not Is_Empty_Elmt_List (Subp_List) then 4654 declare 4655 Subp_Id : Elmt_Id; 4656 Spec : Node_Id; 4657 4658 begin 4659 Subp_Id := First_Elmt (Subp_List); 4660 Spec := Parent (Node (Subp_Id)); 4661 4662 while Present (Subp_Id) loop 4663 if Nkind (Parent (Spec)) 4664 = N_Subprogram_Renaming_Declaration 4665 then 4666 null; 4667 4668 elsif Nkind (Spec) = N_Procedure_Specification 4669 and then Null_Present (Spec) 4670 then 4671 null; 4672 4673 else 4674 Set_Body_Required (Library_Unit (N)); 4675 return; 4676 end if; 4677 4678 Next_Elmt (Subp_Id); 4679 end loop; 4680 end; 4681 end if; 4682 end Check_Declarations; 4683 4684 -- Start of processing for Check_Body_Required 4685 4686 begin 4687 -- If this is an imported package (Java and CIL usage) no body is 4688 -- needed. Scan list of pragmas that may follow a compilation unit 4689 -- to look for a relevant pragma Import. 4690 4691 if Present (PA) then 4692 declare 4693 Prag : Node_Id; 4694 4695 begin 4696 Prag := First (PA); 4697 while Present (Prag) loop 4698 if Nkind (Prag) = N_Pragma 4699 and then Get_Pragma_Id (Prag) = Pragma_Import 4700 then 4701 return; 4702 end if; 4703 4704 Next (Prag); 4705 end loop; 4706 end; 4707 end if; 4708 4709 Check_Declarations (Specification (P_Unit)); 4710 end Check_Body_Required; 4711 4712 ----------------------------- 4713 -- Has_Limited_With_Clause -- 4714 ----------------------------- 4715 4716 function Has_Limited_With_Clause 4717 (C_Unit : Entity_Id; 4718 Pack : Entity_Id) return Boolean 4719 is 4720 Par : Entity_Id; 4721 Par_Unit : Node_Id; 4722 4723 begin 4724 Par := C_Unit; 4725 while Present (Par) loop 4726 if Ekind (Par) /= E_Package then 4727 exit; 4728 end if; 4729 4730 -- Retrieve the Compilation_Unit node for Par and determine if 4731 -- its context clauses contain a limited with for Pack. 4732 4733 Par_Unit := Parent (Parent (Parent (Par))); 4734 4735 if Nkind (Par_Unit) = N_Package_Declaration then 4736 Par_Unit := Parent (Par_Unit); 4737 end if; 4738 4739 if Has_With_Clause (Par_Unit, Pack, True) then 4740 return True; 4741 end if; 4742 4743 -- If there are more ancestors, climb up the tree, otherwise we 4744 -- are done. 4745 4746 if Is_Child_Unit (Par) then 4747 Par := Scope (Par); 4748 else 4749 exit; 4750 end if; 4751 end loop; 4752 4753 return False; 4754 end Has_Limited_With_Clause; 4755 4756 ---------------------------------- 4757 -- Is_Visible_Through_Renamings -- 4758 ---------------------------------- 4759 4760 function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean is 4761 Kind : constant Node_Kind := 4762 Nkind (Unit (Cunit (Current_Sem_Unit))); 4763 Aux_Unit : Node_Id; 4764 Item : Node_Id; 4765 Decl : Entity_Id; 4766 4767 begin 4768 -- Example of the error detected by this subprogram: 4769 4770 -- package P is 4771 -- type T is ... 4772 -- end P; 4773 4774 -- with P; 4775 -- package Q is 4776 -- package Ren_P renames P; 4777 -- end Q; 4778 4779 -- with Q; 4780 -- package R is ... 4781 4782 -- limited with P; -- ERROR 4783 -- package R.C is ... 4784 4785 Aux_Unit := Cunit (Current_Sem_Unit); 4786 4787 loop 4788 Item := First (Context_Items (Aux_Unit)); 4789 while Present (Item) loop 4790 if Nkind (Item) = N_With_Clause 4791 and then not Limited_Present (Item) 4792 and then Nkind (Unit (Library_Unit (Item))) = 4793 N_Package_Declaration 4794 then 4795 Decl := 4796 First (Visible_Declarations 4797 (Specification (Unit (Library_Unit (Item))))); 4798 while Present (Decl) loop 4799 if Nkind (Decl) = N_Package_Renaming_Declaration 4800 and then Entity (Name (Decl)) = P 4801 then 4802 -- Generate the error message only if the current unit 4803 -- is a package declaration; in case of subprogram 4804 -- bodies and package bodies we just return True to 4805 -- indicate that the limited view must not be 4806 -- installed. 4807 4808 if Kind = N_Package_Declaration then 4809 Error_Msg_N 4810 ("simultaneous visibility of the limited and " & 4811 "unlimited views not allowed", N); 4812 Error_Msg_Sloc := Sloc (Item); 4813 Error_Msg_NE 4814 ("\\ unlimited view of & visible through the " & 4815 "context clause #", N, P); 4816 Error_Msg_Sloc := Sloc (Decl); 4817 Error_Msg_NE ("\\ and the renaming #", N, P); 4818 end if; 4819 4820 return True; 4821 end if; 4822 4823 Next (Decl); 4824 end loop; 4825 end if; 4826 4827 Next (Item); 4828 end loop; 4829 4830 -- If it is a body not acting as spec, follow pointer to the 4831 -- corresponding spec, otherwise follow pointer to parent spec. 4832 4833 if Present (Library_Unit (Aux_Unit)) 4834 and then Nkind_In (Unit (Aux_Unit), 4835 N_Package_Body, N_Subprogram_Body) 4836 then 4837 if Aux_Unit = Library_Unit (Aux_Unit) then 4838 4839 -- Aux_Unit is a body that acts as a spec. Clause has 4840 -- already been flagged as illegal. 4841 4842 return False; 4843 4844 else 4845 Aux_Unit := Library_Unit (Aux_Unit); 4846 end if; 4847 4848 else 4849 Aux_Unit := Parent_Spec (Unit (Aux_Unit)); 4850 end if; 4851 4852 exit when No (Aux_Unit); 4853 end loop; 4854 4855 return False; 4856 end Is_Visible_Through_Renamings; 4857 4858 -- Start of processing for Install_Limited_Withed_Unit 4859 4860 begin 4861 pragma Assert (not Limited_View_Installed (N)); 4862 4863 -- In case of limited with_clause on subprograms, generics, instances, 4864 -- or renamings, the corresponding error was previously posted and we 4865 -- have nothing to do here. If the file is missing altogether, it has 4866 -- no source location. 4867 4868 if Nkind (P_Unit) /= N_Package_Declaration 4869 or else Sloc (P_Unit) = No_Location 4870 then 4871 return; 4872 end if; 4873 4874 P := Defining_Unit_Name (Specification (P_Unit)); 4875 4876 -- Handle child packages 4877 4878 if Nkind (P) = N_Defining_Program_Unit_Name then 4879 Is_Child_Package := True; 4880 P := Defining_Identifier (P); 4881 end if; 4882 4883 -- Do not install the limited-view if the context of the unit is already 4884 -- available through a regular with clause. 4885 4886 if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body 4887 and then Has_With_Clause (Cunit (Current_Sem_Unit), P) 4888 then 4889 return; 4890 end if; 4891 4892 -- Do not install the limited-view if the full-view is already visible 4893 -- through renaming declarations. 4894 4895 if Is_Visible_Through_Renamings (P) then 4896 return; 4897 end if; 4898 4899 -- Do not install the limited view if this is the unit being analyzed. 4900 -- This unusual case will happen when a unit has a limited_with clause 4901 -- on one of its children. The compilation of the child forces the load 4902 -- of the parent which tries to install the limited view of the child 4903 -- again. Installing the limited view must also be disabled when 4904 -- compiling the body of the child unit. 4905 4906 if P = Cunit_Entity (Current_Sem_Unit) 4907 or else (Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body 4908 and then P = Main_Unit_Entity 4909 and then Is_Ancestor_Unit 4910 (Cunit (Main_Unit), Cunit (Current_Sem_Unit))) 4911 then 4912 return; 4913 end if; 4914 4915 -- This scenario is similar to the one above, the difference is that the 4916 -- compilation of sibling Par.Sib forces the load of parent Par which 4917 -- tries to install the limited view of Lim_Pack [1]. However Par.Sib 4918 -- has a with clause for Lim_Pack [2] in its body, and thus needs the 4919 -- non-limited views of all entities from Lim_Pack. 4920 4921 -- limited with Lim_Pack; -- [1] 4922 -- package Par is ... package Lim_Pack is ... 4923 4924 -- with Lim_Pack; -- [2] 4925 -- package Par.Sib is ... package body Par.Sib is ... 4926 4927 -- In this case Main_Unit_Entity is the spec of Par.Sib and Current_ 4928 -- Sem_Unit is the body of Par.Sib. 4929 4930 if Ekind (P) = E_Package 4931 and then Ekind (Main_Unit_Entity) = E_Package 4932 and then Is_Child_Unit (Main_Unit_Entity) 4933 4934 -- The body has a regular with clause 4935 4936 and then Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body 4937 and then Has_With_Clause (Cunit (Current_Sem_Unit), P) 4938 4939 -- One of the ancestors has a limited with clause 4940 4941 and then Nkind (Parent (Parent (Main_Unit_Entity))) = 4942 N_Package_Specification 4943 and then Has_Limited_With_Clause (Scope (Main_Unit_Entity), P) 4944 then 4945 return; 4946 end if; 4947 4948 -- A common use of the limited-with is to have a limited-with in the 4949 -- package spec, and a normal with in its package body. For example: 4950 4951 -- limited with X; -- [1] 4952 -- package A is ... 4953 4954 -- with X; -- [2] 4955 -- package body A is ... 4956 4957 -- The compilation of A's body installs the context clauses found at [2] 4958 -- and then the context clauses of its specification (found at [1]). As 4959 -- a consequence, at [1] the specification of X has been analyzed and it 4960 -- is immediately visible. According to the semantics of limited-with 4961 -- context clauses we don't install the limited view because the full 4962 -- view of X supersedes its limited view. 4963 4964 if Analyzed (P_Unit) 4965 and then 4966 (Is_Immediately_Visible (P) 4967 or else (Is_Child_Package and then Is_Visible_Lib_Unit (P))) 4968 then 4969 4970 -- The presence of both the limited and the analyzed nonlimited view 4971 -- may also be an error, such as an illegal context for a limited 4972 -- with_clause. In that case, do not process the context item at all. 4973 4974 if Error_Posted (N) then 4975 return; 4976 end if; 4977 4978 if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then 4979 declare 4980 Item : Node_Id; 4981 begin 4982 Item := First (Context_Items (Cunit (Current_Sem_Unit))); 4983 while Present (Item) loop 4984 if Nkind (Item) = N_With_Clause 4985 and then Comes_From_Source (Item) 4986 and then Entity (Name (Item)) = P 4987 then 4988 return; 4989 end if; 4990 4991 Next (Item); 4992 end loop; 4993 end; 4994 4995 -- If this is a child body, assume that the nonlimited with_clause 4996 -- appears in an ancestor. Could be refined ??? 4997 4998 if Is_Child_Unit 4999 (Defining_Entity 5000 (Unit (Library_Unit (Cunit (Current_Sem_Unit))))) 5001 then 5002 return; 5003 end if; 5004 5005 else 5006 5007 -- If in package declaration, nonlimited view brought in from 5008 -- parent unit or some error condition. 5009 5010 return; 5011 end if; 5012 end if; 5013 5014 if Debug_Flag_I then 5015 Write_Str ("install limited view of "); 5016 Write_Name (Chars (P)); 5017 Write_Eol; 5018 end if; 5019 5020 -- If the unit has not been analyzed and the limited view has not been 5021 -- already installed then we install it. 5022 5023 if not Analyzed (P_Unit) then 5024 if not In_Chain (P) then 5025 5026 -- Minimum decoration 5027 5028 Set_Ekind (P, E_Package); 5029 Set_Etype (P, Standard_Void_Type); 5030 Set_Scope (P, Standard_Standard); 5031 Set_Is_Visible_Lib_Unit (P); 5032 5033 if Is_Child_Package then 5034 Set_Is_Child_Unit (P); 5035 Set_Scope (P, Defining_Entity (Unit (Parent_Spec (P_Unit)))); 5036 end if; 5037 5038 -- Place entity on visibility structure 5039 5040 Set_Homonym (P, Current_Entity (P)); 5041 Set_Current_Entity (P); 5042 5043 if Debug_Flag_I then 5044 Write_Str (" (homonym) chain "); 5045 Write_Name (Chars (P)); 5046 Write_Eol; 5047 end if; 5048 5049 -- Install the incomplete view. The first element of the limited 5050 -- view is a header (an E_Package entity) used to reference the 5051 -- first shadow entity in the private part of the package. 5052 5053 Lim_Header := Limited_View (P); 5054 Lim_Typ := First_Entity (Lim_Header); 5055 5056 while Present (Lim_Typ) 5057 and then Lim_Typ /= First_Private_Entity (Lim_Header) 5058 loop 5059 Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ)); 5060 Set_Current_Entity (Lim_Typ); 5061 5062 if Debug_Flag_I then 5063 Write_Str (" (homonym) chain "); 5064 Write_Name (Chars (Lim_Typ)); 5065 Write_Eol; 5066 end if; 5067 5068 Next_Entity (Lim_Typ); 5069 end loop; 5070 end if; 5071 5072 -- If the unit appears in a previous regular with_clause, the regular 5073 -- entities of the public part of the withed package must be replaced 5074 -- by the shadow ones. 5075 5076 -- This code must be kept synchronized with the code that replaces the 5077 -- shadow entities by the real entities (see body of Remove_Limited 5078 -- With_Clause); otherwise the contents of the homonym chains are not 5079 -- consistent. 5080 5081 else 5082 -- Hide all the type entities of the public part of the package to 5083 -- avoid its usage. This is needed to cover all the subtype decla- 5084 -- rations because we do not remove them from the homonym chain. 5085 5086 E := First_Entity (P); 5087 while Present (E) and then E /= First_Private_Entity (P) loop 5088 if Is_Type (E) then 5089 Set_Was_Hidden (E, Is_Hidden (E)); 5090 Set_Is_Hidden (E); 5091 end if; 5092 5093 Next_Entity (E); 5094 end loop; 5095 5096 -- Replace the real entities by the shadow entities of the limited 5097 -- view. The first element of the limited view is a header that is 5098 -- used to reference the first shadow entity in the private part 5099 -- of the package. Successive elements are the limited views of the 5100 -- type (including regular incomplete types) declared in the package. 5101 5102 Lim_Header := Limited_View (P); 5103 5104 Lim_Typ := First_Entity (Lim_Header); 5105 while Present (Lim_Typ) 5106 and then Lim_Typ /= First_Private_Entity (Lim_Header) 5107 loop 5108 pragma Assert (not In_Chain (Lim_Typ)); 5109 5110 -- Do not unchain nested packages and child units 5111 5112 if Ekind (Lim_Typ) /= E_Package 5113 and then not Is_Child_Unit (Lim_Typ) 5114 then 5115 declare 5116 Prev : Entity_Id; 5117 5118 begin 5119 Prev := Current_Entity (Lim_Typ); 5120 E := Prev; 5121 5122 -- Replace E in the homonyms list, so that the limited view 5123 -- becomes available. 5124 5125 -- If the non-limited view is a record with an anonymous 5126 -- self-referential component, the analysis of the record 5127 -- declaration creates an incomplete type with the same name 5128 -- in order to define an internal access type. The visible 5129 -- entity is now the incomplete type, and that is the one to 5130 -- replace in the visibility structure. 5131 5132 if E = Non_Limited_View (Lim_Typ) 5133 or else 5134 (Ekind (E) = E_Incomplete_Type 5135 and then Full_View (E) = Non_Limited_View (Lim_Typ)) 5136 then 5137 Set_Homonym (Lim_Typ, Homonym (Prev)); 5138 Set_Current_Entity (Lim_Typ); 5139 5140 else 5141 loop 5142 E := Homonym (Prev); 5143 5144 -- E may have been removed when installing a previous 5145 -- limited_with_clause. 5146 5147 exit when No (E); 5148 exit when E = Non_Limited_View (Lim_Typ); 5149 Prev := Homonym (Prev); 5150 end loop; 5151 5152 if Present (E) then 5153 Set_Homonym (Lim_Typ, Homonym (Homonym (Prev))); 5154 Set_Homonym (Prev, Lim_Typ); 5155 end if; 5156 end if; 5157 end; 5158 5159 if Debug_Flag_I then 5160 Write_Str (" (homonym) chain "); 5161 Write_Name (Chars (Lim_Typ)); 5162 Write_Eol; 5163 end if; 5164 end if; 5165 5166 Next_Entity (Lim_Typ); 5167 end loop; 5168 end if; 5169 5170 -- The package must be visible while the limited-with clause is active 5171 -- because references to the type P.T must resolve in the usual way. 5172 -- In addition, we remember that the limited-view has been installed to 5173 -- uninstall it at the point of context removal. 5174 5175 Set_Is_Immediately_Visible (P); 5176 Set_Limited_View_Installed (N); 5177 5178 -- If unit has not been analyzed in some previous context, check 5179 -- (imperfectly ???) whether it might need a body. 5180 5181 if not Analyzed (P_Unit) then 5182 Check_Body_Required; 5183 end if; 5184 5185 -- If the package in the limited_with clause is a child unit, the clause 5186 -- is unanalyzed and appears as a selected component. Recast it as an 5187 -- expanded name so that the entity can be properly set. Use entity of 5188 -- parent, if available, for higher ancestors in the name. 5189 5190 if Nkind (Name (N)) = N_Selected_Component then 5191 declare 5192 Nam : Node_Id; 5193 Ent : Entity_Id; 5194 5195 begin 5196 Nam := Name (N); 5197 Ent := P; 5198 while Nkind (Nam) = N_Selected_Component 5199 and then Present (Ent) 5200 loop 5201 Change_Selected_Component_To_Expanded_Name (Nam); 5202 5203 -- Set entity of parent identifiers if the unit is a child 5204 -- unit. This ensures that the tree is properly formed from 5205 -- semantic point of view (e.g. for ASIS queries). The unit 5206 -- entities are not fully analyzed, so we need to follow unit 5207 -- links in the tree. 5208 5209 Set_Entity (Nam, Ent); 5210 5211 Nam := Prefix (Nam); 5212 Ent := 5213 Defining_Entity 5214 (Unit (Parent_Spec (Unit_Declaration_Node (Ent)))); 5215 5216 -- Set entity of last ancestor 5217 5218 if Nkind (Nam) = N_Identifier then 5219 Set_Entity (Nam, Ent); 5220 end if; 5221 end loop; 5222 end; 5223 end if; 5224 5225 Set_Entity (Name (N), P); 5226 Set_From_Limited_With (P); 5227 end Install_Limited_Withed_Unit; 5228 5229 ------------------------- 5230 -- Install_Withed_Unit -- 5231 ------------------------- 5232 5233 procedure Install_Withed_Unit 5234 (With_Clause : Node_Id; 5235 Private_With_OK : Boolean := False) 5236 is 5237 Uname : constant Entity_Id := Entity (Name (With_Clause)); 5238 P : constant Entity_Id := Scope (Uname); 5239 5240 begin 5241 -- Ada 2005 (AI-262): Do not install the private withed unit if we are 5242 -- compiling a package declaration and the Private_With_OK flag was not 5243 -- set by the caller. These declarations will be installed later (before 5244 -- analyzing the private part of the package). 5245 5246 if Private_Present (With_Clause) 5247 and then Nkind (Unit (Parent (With_Clause))) = N_Package_Declaration 5248 and then not (Private_With_OK) 5249 then 5250 return; 5251 end if; 5252 5253 if Debug_Flag_I then 5254 if Private_Present (With_Clause) then 5255 Write_Str ("install private withed unit "); 5256 else 5257 Write_Str ("install withed unit "); 5258 end if; 5259 5260 Write_Name (Chars (Uname)); 5261 Write_Eol; 5262 end if; 5263 5264 -- We do not apply the restrictions to an internal unit unless we are 5265 -- compiling the internal unit as a main unit. This check is also 5266 -- skipped for dummy units (for missing packages). 5267 5268 if Sloc (Uname) /= No_Location 5269 and then (not Is_Internal_Unit (Current_Sem_Unit) 5270 or else Current_Sem_Unit = Main_Unit) 5271 then 5272 Check_Restricted_Unit 5273 (Unit_Name (Get_Source_Unit (Uname)), With_Clause); 5274 end if; 5275 5276 if P /= Standard_Standard then 5277 5278 -- If the unit is not analyzed after analysis of the with clause and 5279 -- it is an instantiation then it awaits a body and is the main unit. 5280 -- Its appearance in the context of some other unit indicates a 5281 -- circular dependency (DEC suite perversity). 5282 5283 if not Analyzed (Uname) 5284 and then Nkind (Parent (Uname)) = N_Package_Instantiation 5285 then 5286 Error_Msg_N 5287 ("instantiation depends on itself", Name (With_Clause)); 5288 5289 elsif not Is_Visible_Lib_Unit (Uname) then 5290 5291 -- Abandon processing in case of previous errors 5292 5293 if No (Scope (Uname)) then 5294 Check_Error_Detected; 5295 return; 5296 end if; 5297 5298 Set_Is_Visible_Lib_Unit (Uname); 5299 5300 -- If the unit is a wrapper package for a compilation unit that is 5301 -- a subprogrm instance, indicate that the instance itself is a 5302 -- visible unit. This is necessary if the instance is inlined. 5303 5304 if Is_Wrapper_Package (Uname) then 5305 Set_Is_Visible_Lib_Unit (Related_Instance (Uname)); 5306 end if; 5307 5308 -- If the child unit appears in the context of its parent, it is 5309 -- immediately visible. 5310 5311 if In_Open_Scopes (Scope (Uname)) then 5312 Set_Is_Immediately_Visible (Uname); 5313 end if; 5314 5315 if Is_Generic_Instance (Uname) 5316 and then Ekind (Uname) in Subprogram_Kind 5317 then 5318 -- Set flag as well on the visible entity that denotes the 5319 -- instance, which renames the current one. 5320 5321 Set_Is_Visible_Lib_Unit 5322 (Related_Instance 5323 (Defining_Entity (Unit (Library_Unit (With_Clause))))); 5324 end if; 5325 5326 -- The parent unit may have been installed already, and may have 5327 -- appeared in a use clause. 5328 5329 if In_Use (Scope (Uname)) then 5330 Set_Is_Potentially_Use_Visible (Uname); 5331 end if; 5332 5333 Set_Context_Installed (With_Clause); 5334 end if; 5335 5336 elsif not Is_Immediately_Visible (Uname) then 5337 Set_Is_Visible_Lib_Unit (Uname); 5338 5339 if not Private_Present (With_Clause) or else Private_With_OK then 5340 Set_Is_Immediately_Visible (Uname); 5341 end if; 5342 5343 Set_Context_Installed (With_Clause); 5344 end if; 5345 5346 -- A with-clause overrides a with-type clause: there are no restric- 5347 -- tions on the use of package entities. 5348 5349 if Ekind (Uname) = E_Package then 5350 Set_From_Limited_With (Uname, False); 5351 end if; 5352 5353 -- Ada 2005 (AI-377): it is illegal for a with_clause to name a child 5354 -- unit if there is a visible homograph for it declared in the same 5355 -- declarative region. This pathological case can only arise when an 5356 -- instance I1 of a generic unit G1 has an explicit child unit I1.G2, 5357 -- G1 has a generic child also named G2, and the context includes with_ 5358 -- clauses for both I1.G2 and for G1.G2, making an implicit declaration 5359 -- of I1.G2 visible as well. If the child unit is named Standard, do 5360 -- not apply the check to the Standard package itself. 5361 5362 if Is_Child_Unit (Uname) 5363 and then Is_Visible_Lib_Unit (Uname) 5364 and then Ada_Version >= Ada_2005 5365 then 5366 declare 5367 Decl1 : constant Node_Id := Unit_Declaration_Node (P); 5368 Decl2 : Node_Id; 5369 P2 : Entity_Id; 5370 U2 : Entity_Id; 5371 5372 begin 5373 U2 := Homonym (Uname); 5374 while Present (U2) and then U2 /= Standard_Standard loop 5375 P2 := Scope (U2); 5376 Decl2 := Unit_Declaration_Node (P2); 5377 5378 if Is_Child_Unit (U2) and then Is_Visible_Lib_Unit (U2) then 5379 if Is_Generic_Instance (P) 5380 and then Nkind (Decl1) = N_Package_Declaration 5381 and then Generic_Parent (Specification (Decl1)) = P2 5382 then 5383 Error_Msg_N ("illegal with_clause", With_Clause); 5384 Error_Msg_N 5385 ("\child unit has visible homograph" & 5386 " (RM 8.3(26), 10.1.1(19))", 5387 With_Clause); 5388 exit; 5389 5390 elsif Is_Generic_Instance (P2) 5391 and then Nkind (Decl2) = N_Package_Declaration 5392 and then Generic_Parent (Specification (Decl2)) = P 5393 then 5394 -- With_clause for child unit of instance appears before 5395 -- in the context. We want to place the error message on 5396 -- it, not on the generic child unit itself. 5397 5398 declare 5399 Prev_Clause : Node_Id; 5400 5401 begin 5402 Prev_Clause := First (List_Containing (With_Clause)); 5403 while Entity (Name (Prev_Clause)) /= U2 loop 5404 Next (Prev_Clause); 5405 end loop; 5406 5407 pragma Assert (Present (Prev_Clause)); 5408 Error_Msg_N ("illegal with_clause", Prev_Clause); 5409 Error_Msg_N 5410 ("\child unit has visible homograph" & 5411 " (RM 8.3(26), 10.1.1(19))", 5412 Prev_Clause); 5413 exit; 5414 end; 5415 end if; 5416 end if; 5417 5418 U2 := Homonym (U2); 5419 end loop; 5420 end; 5421 end if; 5422 end Install_Withed_Unit; 5423 5424 ------------------- 5425 -- Is_Child_Spec -- 5426 ------------------- 5427 5428 function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean is 5429 K : constant Node_Kind := Nkind (Lib_Unit); 5430 5431 begin 5432 return (K in N_Generic_Declaration or else 5433 K in N_Generic_Instantiation or else 5434 K in N_Generic_Renaming_Declaration or else 5435 K = N_Package_Declaration or else 5436 K = N_Package_Renaming_Declaration or else 5437 K = N_Subprogram_Declaration or else 5438 K = N_Subprogram_Renaming_Declaration) 5439 and then Present (Parent_Spec (Lib_Unit)); 5440 end Is_Child_Spec; 5441 5442 ------------------------------------ 5443 -- Is_Legal_Shadow_Entity_In_Body -- 5444 ------------------------------------ 5445 5446 function Is_Legal_Shadow_Entity_In_Body (T : Entity_Id) return Boolean is 5447 C_Unit : constant Node_Id := Cunit (Current_Sem_Unit); 5448 begin 5449 return Nkind (Unit (C_Unit)) = N_Package_Body 5450 and then 5451 Has_With_Clause 5452 (C_Unit, Cunit_Entity (Get_Source_Unit (Non_Limited_View (T)))); 5453 end Is_Legal_Shadow_Entity_In_Body; 5454 5455 ---------------------- 5456 -- Is_Ancestor_Unit -- 5457 ---------------------- 5458 5459 function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean is 5460 E1 : constant Entity_Id := Defining_Entity (Unit (U1)); 5461 E2 : Entity_Id; 5462 begin 5463 if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then 5464 E2 := Defining_Entity (Unit (Library_Unit (U2))); 5465 return Is_Ancestor_Package (E1, E2); 5466 else 5467 return False; 5468 end if; 5469 end Is_Ancestor_Unit; 5470 5471 ----------------------- 5472 -- Load_Needed_Body -- 5473 ----------------------- 5474 5475 -- N is a generic unit named in a with clause, or else it is a unit that 5476 -- contains a generic unit or an inlined function. In order to perform an 5477 -- instantiation, the body of the unit must be present. If the unit itself 5478 -- is generic, we assume that an instantiation follows, and load & analyze 5479 -- the body unconditionally. This forces analysis of the spec as well. 5480 5481 -- If the unit is not generic, but contains a generic unit, it is loaded on 5482 -- demand, at the point of instantiation (see ch12). 5483 5484 procedure Load_Needed_Body 5485 (N : Node_Id; 5486 OK : out Boolean; 5487 Do_Analyze : Boolean := True) 5488 is 5489 Body_Name : Unit_Name_Type; 5490 Unum : Unit_Number_Type; 5491 5492 Save_Style_Check : constant Boolean := Opt.Style_Check; 5493 -- The loading and analysis is done with style checks off 5494 5495 begin 5496 if not GNAT_Mode then 5497 Style_Check := False; 5498 end if; 5499 5500 Body_Name := Get_Body_Name (Get_Unit_Name (Unit (N))); 5501 Unum := 5502 Load_Unit 5503 (Load_Name => Body_Name, 5504 Required => False, 5505 Subunit => False, 5506 Error_Node => N, 5507 Renamings => True); 5508 5509 if Unum = No_Unit then 5510 OK := False; 5511 5512 else 5513 Compiler_State := Analyzing; -- reset after load 5514 5515 if Fatal_Error (Unum) /= Error_Detected or else Try_Semantics then 5516 if Debug_Flag_L then 5517 Write_Str ("*** Loaded generic body"); 5518 Write_Eol; 5519 end if; 5520 5521 if Do_Analyze then 5522 Semantics (Cunit (Unum)); 5523 end if; 5524 end if; 5525 5526 OK := True; 5527 end if; 5528 5529 Style_Check := Save_Style_Check; 5530 end Load_Needed_Body; 5531 5532 ------------------------- 5533 -- Build_Limited_Views -- 5534 ------------------------- 5535 5536 procedure Build_Limited_Views (N : Node_Id) is 5537 Unum : constant Unit_Number_Type := 5538 Get_Source_Unit (Library_Unit (N)); 5539 Is_Analyzed : constant Boolean := Analyzed (Cunit (Unum)); 5540 5541 Shadow_Pack : Entity_Id; 5542 -- The corresponding shadow entity of the withed package. This entity 5543 -- offers incomplete views of packages and types as well as abstract 5544 -- views of states and variables declared within. 5545 5546 Last_Shadow : Entity_Id := Empty; 5547 -- The last shadow entity created by routine Build_Shadow_Entity 5548 5549 procedure Build_Shadow_Entity 5550 (Ent : Entity_Id; 5551 Scop : Entity_Id; 5552 Shadow : out Entity_Id; 5553 Is_Tagged : Boolean := False); 5554 -- Create a shadow entity that hides Ent and offers an abstract or 5555 -- incomplete view of Ent. Scop is the proper scope. Flag Is_Tagged 5556 -- should be set when Ent is a tagged type. The generated entity is 5557 -- added to Lim_Header. This routine updates the value of Last_Shadow. 5558 5559 procedure Decorate_Package (Ent : Entity_Id; Scop : Entity_Id); 5560 -- Perform minimal decoration of a package or its corresponding shadow 5561 -- entity denoted by Ent. Scop is the proper scope. 5562 5563 procedure Decorate_State (Ent : Entity_Id; Scop : Entity_Id); 5564 -- Perform full decoration of an abstract state or its corresponding 5565 -- shadow entity denoted by Ent. Scop is the proper scope. 5566 5567 procedure Decorate_Type 5568 (Ent : Entity_Id; 5569 Scop : Entity_Id; 5570 Is_Tagged : Boolean := False; 5571 Materialize : Boolean := False); 5572 -- Perform minimal decoration of a type or its corresponding shadow 5573 -- entity denoted by Ent. Scop is the proper scope. Flag Is_Tagged 5574 -- should be set when Ent is a tagged type. Flag Materialize should be 5575 -- set when Ent is a tagged type and its class-wide type needs to appear 5576 -- in the tree. 5577 5578 procedure Decorate_Variable (Ent : Entity_Id; Scop : Entity_Id); 5579 -- Perform minimal decoration of a variable denoted by Ent. Scop is the 5580 -- proper scope. 5581 5582 procedure Process_Declarations_And_States 5583 (Pack : Entity_Id; 5584 Decls : List_Id; 5585 Scop : Entity_Id; 5586 Create_Abstract_Views : Boolean); 5587 -- Inspect the states of package Pack and declarative list Decls. Create 5588 -- shadow entities for all nested packages, states, types and variables 5589 -- encountered. Scop is the proper scope. Create_Abstract_Views should 5590 -- be set when the abstract states and variables need to be processed. 5591 5592 ------------------------- 5593 -- Build_Shadow_Entity -- 5594 ------------------------- 5595 5596 procedure Build_Shadow_Entity 5597 (Ent : Entity_Id; 5598 Scop : Entity_Id; 5599 Shadow : out Entity_Id; 5600 Is_Tagged : Boolean := False) 5601 is 5602 begin 5603 Shadow := Make_Temporary (Sloc (Ent), 'Z'); 5604 5605 -- The shadow entity must share the same name and parent as the 5606 -- entity it hides. 5607 5608 Set_Chars (Shadow, Chars (Ent)); 5609 Set_Parent (Shadow, Parent (Ent)); 5610 5611 -- The abstract view of a variable is a state, not another variable 5612 5613 if Ekind (Ent) = E_Variable then 5614 Set_Ekind (Shadow, E_Abstract_State); 5615 else 5616 Set_Ekind (Shadow, Ekind (Ent)); 5617 end if; 5618 5619 Set_Is_Internal (Shadow); 5620 Set_From_Limited_With (Shadow); 5621 5622 -- Add the new shadow entity to the limited view of the package 5623 5624 Last_Shadow := Shadow; 5625 Append_Entity (Shadow, Shadow_Pack); 5626 5627 -- Perform context-specific decoration of the shadow entity 5628 5629 if Ekind (Ent) = E_Abstract_State then 5630 Decorate_State (Shadow, Scop); 5631 Set_Non_Limited_View (Shadow, Ent); 5632 5633 elsif Ekind (Ent) = E_Package then 5634 Decorate_Package (Shadow, Scop); 5635 5636 elsif Is_Type (Ent) then 5637 Decorate_Type (Shadow, Scop, Is_Tagged); 5638 Set_Non_Limited_View (Shadow, Ent); 5639 5640 if Is_Tagged then 5641 Set_Non_Limited_View 5642 (Class_Wide_Type (Shadow), Class_Wide_Type (Ent)); 5643 end if; 5644 5645 if Is_Incomplete_Or_Private_Type (Ent) then 5646 Set_Private_Dependents (Shadow, New_Elmt_List); 5647 end if; 5648 5649 elsif Ekind (Ent) = E_Variable then 5650 Decorate_State (Shadow, Scop); 5651 Set_Non_Limited_View (Shadow, Ent); 5652 end if; 5653 end Build_Shadow_Entity; 5654 5655 ---------------------- 5656 -- Decorate_Package -- 5657 ---------------------- 5658 5659 procedure Decorate_Package (Ent : Entity_Id; Scop : Entity_Id) is 5660 begin 5661 Set_Ekind (Ent, E_Package); 5662 Set_Etype (Ent, Standard_Void_Type); 5663 Set_Scope (Ent, Scop); 5664 end Decorate_Package; 5665 5666 -------------------- 5667 -- Decorate_State -- 5668 -------------------- 5669 5670 procedure Decorate_State (Ent : Entity_Id; Scop : Entity_Id) is 5671 begin 5672 Set_Ekind (Ent, E_Abstract_State); 5673 Set_Etype (Ent, Standard_Void_Type); 5674 Set_Scope (Ent, Scop); 5675 Set_Encapsulating_State (Ent, Empty); 5676 end Decorate_State; 5677 5678 ------------------- 5679 -- Decorate_Type -- 5680 ------------------- 5681 5682 procedure Decorate_Type 5683 (Ent : Entity_Id; 5684 Scop : Entity_Id; 5685 Is_Tagged : Boolean := False; 5686 Materialize : Boolean := False) 5687 is 5688 CW_Typ : Entity_Id; 5689 5690 begin 5691 -- An unanalyzed type or a shadow entity of a type is treated as an 5692 -- incomplete type, and carries the corresponding attributes. 5693 5694 Set_Ekind (Ent, E_Incomplete_Type); 5695 Set_Etype (Ent, Ent); 5696 Set_Full_View (Ent, Empty); 5697 Set_Is_First_Subtype (Ent); 5698 Set_Scope (Ent, Scop); 5699 Set_Stored_Constraint (Ent, No_Elist); 5700 Init_Size_Align (Ent); 5701 5702 if From_Limited_With (Ent) then 5703 Set_Private_Dependents (Ent, New_Elmt_List); 5704 end if; 5705 5706 -- A tagged type and its corresponding shadow entity share one common 5707 -- class-wide type. The list of primitive operations for the shadow 5708 -- entity is empty. 5709 5710 if Is_Tagged then 5711 Set_Is_Tagged_Type (Ent); 5712 Set_Direct_Primitive_Operations (Ent, New_Elmt_List); 5713 5714 CW_Typ := 5715 New_External_Entity 5716 (E_Void, Scope (Ent), Sloc (Ent), Ent, 'C', 0, 'T'); 5717 5718 Set_Class_Wide_Type (Ent, CW_Typ); 5719 5720 -- Set parent to be the same as the parent of the tagged type. 5721 -- We need a parent field set, and it is supposed to point to 5722 -- the declaration of the type. The tagged type declaration 5723 -- essentially declares two separate types, the tagged type 5724 -- itself and the corresponding class-wide type, so it is 5725 -- reasonable for the parent fields to point to the declaration 5726 -- in both cases. 5727 5728 Set_Parent (CW_Typ, Parent (Ent)); 5729 5730 Set_Ekind (CW_Typ, E_Class_Wide_Type); 5731 Set_Class_Wide_Type (CW_Typ, CW_Typ); 5732 Set_Etype (CW_Typ, Ent); 5733 Set_Equivalent_Type (CW_Typ, Empty); 5734 Set_From_Limited_With (CW_Typ, From_Limited_With (Ent)); 5735 Set_Has_Unknown_Discriminants (CW_Typ); 5736 Set_Is_First_Subtype (CW_Typ); 5737 Set_Is_Tagged_Type (CW_Typ); 5738 Set_Materialize_Entity (CW_Typ, Materialize); 5739 Set_Scope (CW_Typ, Scop); 5740 Init_Size_Align (CW_Typ); 5741 end if; 5742 end Decorate_Type; 5743 5744 ----------------------- 5745 -- Decorate_Variable -- 5746 ----------------------- 5747 5748 procedure Decorate_Variable (Ent : Entity_Id; Scop : Entity_Id) is 5749 begin 5750 Set_Ekind (Ent, E_Variable); 5751 Set_Etype (Ent, Standard_Void_Type); 5752 Set_Scope (Ent, Scop); 5753 end Decorate_Variable; 5754 5755 ------------------------------------- 5756 -- Process_Declarations_And_States -- 5757 ------------------------------------- 5758 5759 procedure Process_Declarations_And_States 5760 (Pack : Entity_Id; 5761 Decls : List_Id; 5762 Scop : Entity_Id; 5763 Create_Abstract_Views : Boolean) 5764 is 5765 procedure Find_And_Process_States; 5766 -- Determine whether package Pack defines abstract state either by 5767 -- using an aspect or a pragma. If this is the case, build shadow 5768 -- entities for all abstract states of Pack. 5769 5770 procedure Process_States (States : Elist_Id); 5771 -- Generate shadow entities for all abstract states in list States 5772 5773 ----------------------------- 5774 -- Find_And_Process_States -- 5775 ----------------------------- 5776 5777 procedure Find_And_Process_States is 5778 procedure Process_State (State : Node_Id); 5779 -- Generate shadow entities for a single abstract state or 5780 -- multiple states expressed as an aggregate. 5781 5782 ------------------- 5783 -- Process_State -- 5784 ------------------- 5785 5786 procedure Process_State (State : Node_Id) is 5787 Loc : constant Source_Ptr := Sloc (State); 5788 Decl : Node_Id; 5789 Dummy : Entity_Id; 5790 Elmt : Node_Id; 5791 Id : Entity_Id; 5792 5793 begin 5794 -- Multiple abstract states appear as an aggregate 5795 5796 if Nkind (State) = N_Aggregate then 5797 Elmt := First (Expressions (State)); 5798 while Present (Elmt) loop 5799 Process_State (Elmt); 5800 Next (Elmt); 5801 end loop; 5802 5803 return; 5804 5805 -- A null state has no abstract view 5806 5807 elsif Nkind (State) = N_Null then 5808 return; 5809 5810 -- State declaration with various options appears as an 5811 -- extension aggregate. 5812 5813 elsif Nkind (State) = N_Extension_Aggregate then 5814 Decl := Ancestor_Part (State); 5815 5816 -- Simple state declaration 5817 5818 elsif Nkind (State) = N_Identifier then 5819 Decl := State; 5820 5821 -- Possibly an illegal state declaration 5822 5823 else 5824 return; 5825 end if; 5826 5827 -- Abstract states are elaborated when the related pragma is 5828 -- elaborated. Since the withed package is not analyzed yet, 5829 -- the entities of the abstract states are not available. To 5830 -- overcome this complication, create the entities now and 5831 -- store them in their respective declarations. The entities 5832 -- are later used by routine Create_Abstract_State to declare 5833 -- and enter the states into visibility. 5834 5835 if No (Entity (Decl)) then 5836 Id := Make_Defining_Identifier (Loc, Chars (Decl)); 5837 5838 Set_Entity (Decl, Id); 5839 Set_Parent (Id, State); 5840 Decorate_State (Id, Scop); 5841 5842 -- Otherwise the package was previously withed 5843 5844 else 5845 Id := Entity (Decl); 5846 end if; 5847 5848 Build_Shadow_Entity (Id, Scop, Dummy); 5849 end Process_State; 5850 5851 -- Local variables 5852 5853 Pack_Decl : constant Node_Id := Unit_Declaration_Node (Pack); 5854 Asp : Node_Id; 5855 Decl : Node_Id; 5856 5857 -- Start of processing for Find_And_Process_States 5858 5859 begin 5860 -- Find aspect Abstract_State 5861 5862 Asp := First (Aspect_Specifications (Pack_Decl)); 5863 while Present (Asp) loop 5864 if Chars (Identifier (Asp)) = Name_Abstract_State then 5865 Process_State (Expression (Asp)); 5866 5867 return; 5868 end if; 5869 5870 Next (Asp); 5871 end loop; 5872 5873 -- Find pragma Abstract_State by inspecting the declarations 5874 5875 Decl := First (Decls); 5876 while Present (Decl) and then Nkind (Decl) = N_Pragma loop 5877 if Pragma_Name (Decl) = Name_Abstract_State then 5878 Process_State 5879 (Get_Pragma_Arg 5880 (First (Pragma_Argument_Associations (Decl)))); 5881 5882 return; 5883 end if; 5884 5885 Next (Decl); 5886 end loop; 5887 end Find_And_Process_States; 5888 5889 -------------------- 5890 -- Process_States -- 5891 -------------------- 5892 5893 procedure Process_States (States : Elist_Id) is 5894 Dummy : Entity_Id; 5895 Elmt : Elmt_Id; 5896 5897 begin 5898 Elmt := First_Elmt (States); 5899 while Present (Elmt) loop 5900 Build_Shadow_Entity (Node (Elmt), Scop, Dummy); 5901 5902 Next_Elmt (Elmt); 5903 end loop; 5904 end Process_States; 5905 5906 -- Local variables 5907 5908 Is_Tagged : Boolean; 5909 Decl : Node_Id; 5910 Def : Node_Id; 5911 Def_Id : Entity_Id; 5912 Shadow : Entity_Id; 5913 5914 -- Start of processing for Process_Declarations_And_States 5915 5916 begin 5917 -- Build abstract views for all states defined in the package 5918 5919 if Create_Abstract_Views then 5920 5921 -- When a package has been analyzed, all states are stored in list 5922 -- Abstract_States. Generate the shadow entities directly. 5923 5924 if Is_Analyzed then 5925 if Present (Abstract_States (Pack)) then 5926 Process_States (Abstract_States (Pack)); 5927 end if; 5928 5929 -- The package may declare abstract states by using an aspect or a 5930 -- pragma. Attempt to locate one of these construct and if found, 5931 -- build the shadow entities. 5932 5933 else 5934 Find_And_Process_States; 5935 end if; 5936 end if; 5937 5938 -- Inspect the declarative list, looking for nested packages, types 5939 -- and variable declarations. 5940 5941 Decl := First (Decls); 5942 while Present (Decl) loop 5943 5944 -- Packages 5945 5946 if Nkind (Decl) = N_Package_Declaration then 5947 Def_Id := Defining_Entity (Decl); 5948 5949 -- Perform minor decoration when the withed package has not 5950 -- been analyzed. 5951 5952 if not Is_Analyzed then 5953 Decorate_Package (Def_Id, Scop); 5954 end if; 5955 5956 -- Create a shadow entity that offers a limited view of all 5957 -- visible types declared within. 5958 5959 Build_Shadow_Entity (Def_Id, Scop, Shadow); 5960 5961 Process_Declarations_And_States 5962 (Pack => Def_Id, 5963 Decls => Visible_Declarations (Specification (Decl)), 5964 Scop => Shadow, 5965 Create_Abstract_Views => Create_Abstract_Views); 5966 5967 -- Types 5968 5969 elsif Nkind_In (Decl, N_Full_Type_Declaration, 5970 N_Incomplete_Type_Declaration, 5971 N_Private_Extension_Declaration, 5972 N_Private_Type_Declaration, 5973 N_Protected_Type_Declaration, 5974 N_Task_Type_Declaration) 5975 then 5976 Def_Id := Defining_Entity (Decl); 5977 5978 -- Determine whether the type is tagged. Note that packages 5979 -- included via a limited with clause are not always analyzed, 5980 -- hence the tree lookup rather than the use of attribute 5981 -- Is_Tagged_Type. 5982 5983 if Nkind (Decl) = N_Full_Type_Declaration then 5984 Def := Type_Definition (Decl); 5985 5986 Is_Tagged := 5987 (Nkind (Def) = N_Record_Definition 5988 and then Tagged_Present (Def)) 5989 or else 5990 (Nkind (Def) = N_Derived_Type_Definition 5991 and then Present (Record_Extension_Part (Def))); 5992 5993 elsif Nkind_In (Decl, N_Incomplete_Type_Declaration, 5994 N_Private_Type_Declaration) 5995 then 5996 Is_Tagged := Tagged_Present (Decl); 5997 5998 elsif Nkind (Decl) = N_Private_Extension_Declaration then 5999 Is_Tagged := True; 6000 6001 else 6002 Is_Tagged := False; 6003 end if; 6004 6005 -- Perform minor decoration when the withed package has not 6006 -- been analyzed. 6007 6008 if not Is_Analyzed then 6009 Decorate_Type (Def_Id, Scop, Is_Tagged, True); 6010 end if; 6011 6012 -- Create a shadow entity that hides the type and offers an 6013 -- incomplete view of the said type. 6014 6015 Build_Shadow_Entity (Def_Id, Scop, Shadow, Is_Tagged); 6016 6017 -- Variables 6018 6019 elsif Create_Abstract_Views 6020 and then Nkind (Decl) = N_Object_Declaration 6021 and then not Constant_Present (Decl) 6022 then 6023 Def_Id := Defining_Entity (Decl); 6024 6025 -- Perform minor decoration when the withed package has not 6026 -- been analyzed. 6027 6028 if not Is_Analyzed then 6029 Decorate_Variable (Def_Id, Scop); 6030 end if; 6031 6032 -- Create a shadow entity that hides the variable and offers an 6033 -- abstract view of the said variable. 6034 6035 Build_Shadow_Entity (Def_Id, Scop, Shadow); 6036 end if; 6037 6038 Next (Decl); 6039 end loop; 6040 end Process_Declarations_And_States; 6041 6042 -- Local variables 6043 6044 Nam : constant Node_Id := Name (N); 6045 Pack : constant Entity_Id := Cunit_Entity (Unum); 6046 6047 Last_Public_Shadow : Entity_Id := Empty; 6048 Private_Shadow : Entity_Id; 6049 Spec : Node_Id; 6050 6051 -- Start of processing for Build_Limited_Views 6052 6053 begin 6054 pragma Assert (Limited_Present (N)); 6055 6056 -- A library_item mentioned in a limited_with_clause is a package 6057 -- declaration, not a subprogram declaration, generic declaration, 6058 -- generic instantiation, or package renaming declaration. 6059 6060 case Nkind (Unit (Library_Unit (N))) is 6061 when N_Package_Declaration => 6062 null; 6063 6064 when N_Subprogram_Declaration => 6065 Error_Msg_N ("subprograms not allowed in limited with_clauses", N); 6066 return; 6067 6068 when N_Generic_Package_Declaration 6069 | N_Generic_Subprogram_Declaration 6070 => 6071 Error_Msg_N ("generics not allowed in limited with_clauses", N); 6072 return; 6073 6074 when N_Generic_Instantiation => 6075 Error_Msg_N 6076 ("generic instantiations not allowed in limited with_clauses", 6077 N); 6078 return; 6079 6080 when N_Generic_Renaming_Declaration => 6081 Error_Msg_N 6082 ("generic renamings not allowed in limited with_clauses", N); 6083 return; 6084 6085 when N_Subprogram_Renaming_Declaration => 6086 Error_Msg_N 6087 ("renamed subprograms not allowed in limited with_clauses", N); 6088 return; 6089 6090 when N_Package_Renaming_Declaration => 6091 Error_Msg_N 6092 ("renamed packages not allowed in limited with_clauses", N); 6093 return; 6094 6095 when others => 6096 raise Program_Error; 6097 end case; 6098 6099 -- The withed unit may not be analyzed, but the with calause itself 6100 -- must be minimally decorated. This ensures that the checks on unused 6101 -- with clauses also process limieted withs. 6102 6103 Set_Ekind (Pack, E_Package); 6104 Set_Etype (Pack, Standard_Void_Type); 6105 6106 if Is_Entity_Name (Nam) then 6107 Set_Entity (Nam, Pack); 6108 6109 elsif Nkind (Nam) = N_Selected_Component then 6110 Set_Entity (Selector_Name (Nam), Pack); 6111 end if; 6112 6113 -- Check if the chain is already built 6114 6115 Spec := Specification (Unit (Library_Unit (N))); 6116 6117 if Limited_View_Installed (Spec) then 6118 return; 6119 end if; 6120 6121 -- Create the shadow package wich hides the withed unit and provides 6122 -- incomplete view of all types and packages declared within. 6123 6124 Shadow_Pack := Make_Temporary (Sloc (N), 'Z'); 6125 Set_Ekind (Shadow_Pack, E_Package); 6126 Set_Is_Internal (Shadow_Pack); 6127 Set_Limited_View (Pack, Shadow_Pack); 6128 6129 -- Inspect the abstract states and visible declarations of the withed 6130 -- unit and create shadow entities that hide existing packages, states, 6131 -- variables and types. 6132 6133 Process_Declarations_And_States 6134 (Pack => Pack, 6135 Decls => Visible_Declarations (Spec), 6136 Scop => Pack, 6137 Create_Abstract_Views => True); 6138 6139 Last_Public_Shadow := Last_Shadow; 6140 6141 -- Ada 2005 (AI-262): Build the limited view of the private declarations 6142 -- to accommodate limited private with clauses. 6143 6144 Process_Declarations_And_States 6145 (Pack => Pack, 6146 Decls => Private_Declarations (Spec), 6147 Scop => Pack, 6148 Create_Abstract_Views => False); 6149 6150 if Present (Last_Public_Shadow) then 6151 Private_Shadow := Next_Entity (Last_Public_Shadow); 6152 else 6153 Private_Shadow := First_Entity (Shadow_Pack); 6154 end if; 6155 6156 Set_First_Private_Entity (Shadow_Pack, Private_Shadow); 6157 Set_Limited_View_Installed (Spec); 6158 end Build_Limited_Views; 6159 6160 ---------------------------- 6161 -- Check_No_Elab_Code_All -- 6162 ---------------------------- 6163 6164 procedure Check_No_Elab_Code_All (N : Node_Id) is 6165 begin 6166 if Present (No_Elab_Code_All_Pragma) 6167 and then In_Extended_Main_Source_Unit (N) 6168 and then Present (Context_Items (N)) 6169 then 6170 declare 6171 CL : constant List_Id := Context_Items (N); 6172 CI : Node_Id; 6173 6174 begin 6175 CI := First (CL); 6176 while Present (CI) loop 6177 if Nkind (CI) = N_With_Clause 6178 and then not 6179 No_Elab_Code_All (Get_Source_Unit (Library_Unit (CI))) 6180 6181 -- In GNATprove mode, some runtime units are implicitly 6182 -- loaded to make their entities available for analysis. In 6183 -- this case, ignore violations of No_Elaboration_Code_All 6184 -- for this special analysis mode. 6185 6186 and then not 6187 (GNATprove_Mode and then Implicit_With (CI)) 6188 then 6189 Error_Msg_Sloc := Sloc (No_Elab_Code_All_Pragma); 6190 Error_Msg_N 6191 ("violation of No_Elaboration_Code_All#", CI); 6192 Error_Msg_NE 6193 ("\unit& does not have No_Elaboration_Code_All", 6194 CI, Entity (Name (CI))); 6195 end if; 6196 6197 Next (CI); 6198 end loop; 6199 end; 6200 end if; 6201 end Check_No_Elab_Code_All; 6202 6203 ------------------------------- 6204 -- Check_Body_Needed_For_SAL -- 6205 ------------------------------- 6206 6207 procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id) is 6208 function Entity_Needs_Body (E : Entity_Id) return Boolean; 6209 -- Determine whether use of entity E might require the presence of its 6210 -- body. For a package this requires a recursive traversal of all nested 6211 -- declarations. 6212 6213 ----------------------- 6214 -- Entity_Needs_Body -- 6215 ----------------------- 6216 6217 function Entity_Needs_Body (E : Entity_Id) return Boolean is 6218 Ent : Entity_Id; 6219 6220 begin 6221 if Is_Subprogram (E) and then Has_Pragma_Inline (E) then 6222 return True; 6223 6224 elsif Ekind_In (E, E_Generic_Function, E_Generic_Procedure) then 6225 6226 -- A generic subprogram always requires the presence of its 6227 -- body because an instantiation needs both templates. The only 6228 -- exceptions is a generic subprogram renaming. In this case the 6229 -- body is needed only when the template is declared outside the 6230 -- compilation unit being checked. 6231 6232 if Present (Renamed_Entity (E)) then 6233 return not Within_Scope (E, Unit_Name); 6234 else 6235 return True; 6236 end if; 6237 6238 elsif Ekind (E) = E_Generic_Package 6239 and then 6240 Nkind (Unit_Declaration_Node (E)) = N_Generic_Package_Declaration 6241 and then Present (Corresponding_Body (Unit_Declaration_Node (E))) 6242 then 6243 return True; 6244 6245 elsif Ekind (E) = E_Package 6246 and then Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration 6247 and then Present (Corresponding_Body (Unit_Declaration_Node (E))) 6248 then 6249 Ent := First_Entity (E); 6250 while Present (Ent) loop 6251 if Entity_Needs_Body (Ent) then 6252 return True; 6253 end if; 6254 6255 Next_Entity (Ent); 6256 end loop; 6257 6258 return False; 6259 6260 else 6261 return False; 6262 end if; 6263 end Entity_Needs_Body; 6264 6265 -- Start of processing for Check_Body_Needed_For_SAL 6266 6267 begin 6268 if Ekind (Unit_Name) = E_Generic_Package 6269 and then Nkind (Unit_Declaration_Node (Unit_Name)) = 6270 N_Generic_Package_Declaration 6271 and then 6272 Present (Corresponding_Body (Unit_Declaration_Node (Unit_Name))) 6273 then 6274 Set_Body_Needed_For_SAL (Unit_Name); 6275 6276 elsif Ekind_In (Unit_Name, E_Generic_Procedure, E_Generic_Function) then 6277 Set_Body_Needed_For_SAL (Unit_Name); 6278 6279 elsif Is_Subprogram (Unit_Name) 6280 and then Nkind (Unit_Declaration_Node (Unit_Name)) = 6281 N_Subprogram_Declaration 6282 and then Has_Pragma_Inline (Unit_Name) 6283 then 6284 Set_Body_Needed_For_SAL (Unit_Name); 6285 6286 elsif Ekind (Unit_Name) = E_Subprogram_Body then 6287 Check_Body_Needed_For_SAL 6288 (Corresponding_Spec (Unit_Declaration_Node (Unit_Name))); 6289 6290 elsif Ekind (Unit_Name) = E_Package 6291 and then Entity_Needs_Body (Unit_Name) 6292 then 6293 Set_Body_Needed_For_SAL (Unit_Name); 6294 6295 elsif Ekind (Unit_Name) = E_Package_Body 6296 and then Nkind (Unit_Declaration_Node (Unit_Name)) = N_Package_Body 6297 then 6298 Check_Body_Needed_For_SAL 6299 (Corresponding_Spec (Unit_Declaration_Node (Unit_Name))); 6300 end if; 6301 end Check_Body_Needed_For_SAL; 6302 6303 -------------------- 6304 -- Remove_Context -- 6305 -------------------- 6306 6307 procedure Remove_Context (N : Node_Id) is 6308 Lib_Unit : constant Node_Id := Unit (N); 6309 6310 begin 6311 -- If this is a child unit, first remove the parent units 6312 6313 if Is_Child_Spec (Lib_Unit) then 6314 Remove_Parents (Lib_Unit); 6315 end if; 6316 6317 Remove_Context_Clauses (N); 6318 end Remove_Context; 6319 6320 ---------------------------- 6321 -- Remove_Context_Clauses -- 6322 ---------------------------- 6323 6324 procedure Remove_Context_Clauses (N : Node_Id) is 6325 Item : Node_Id; 6326 Unit_Name : Entity_Id; 6327 6328 begin 6329 -- Ada 2005 (AI-50217): We remove the context clauses in two phases: 6330 -- limited-views first and regular-views later (to maintain the 6331 -- stack model). 6332 6333 -- First Phase: Remove limited_with context clauses 6334 6335 Item := First (Context_Items (N)); 6336 while Present (Item) loop 6337 6338 -- We are interested only in with clauses which got installed 6339 -- on entry. 6340 6341 if Nkind (Item) = N_With_Clause 6342 and then Limited_Present (Item) 6343 and then Limited_View_Installed (Item) 6344 then 6345 Remove_Limited_With_Clause (Item); 6346 end if; 6347 6348 Next (Item); 6349 end loop; 6350 6351 -- Second Phase: Loop through context items and undo regular 6352 -- with_clauses and use_clauses. 6353 6354 Item := First (Context_Items (N)); 6355 while Present (Item) loop 6356 6357 -- We are interested only in with clauses which got installed on 6358 -- entry, as indicated by their Context_Installed flag set 6359 6360 if Nkind (Item) = N_With_Clause 6361 and then Limited_Present (Item) 6362 and then Limited_View_Installed (Item) 6363 then 6364 null; 6365 6366 elsif Nkind (Item) = N_With_Clause 6367 and then Context_Installed (Item) 6368 then 6369 -- Remove items from one with'ed unit 6370 6371 Unit_Name := Entity (Name (Item)); 6372 Remove_Unit_From_Visibility (Unit_Name); 6373 Set_Context_Installed (Item, False); 6374 6375 elsif Nkind (Item) = N_Use_Package_Clause then 6376 End_Use_Package (Item); 6377 6378 elsif Nkind (Item) = N_Use_Type_Clause then 6379 End_Use_Type (Item); 6380 end if; 6381 6382 Next (Item); 6383 end loop; 6384 end Remove_Context_Clauses; 6385 6386 -------------------------------- 6387 -- Remove_Limited_With_Clause -- 6388 -------------------------------- 6389 6390 procedure Remove_Limited_With_Clause (N : Node_Id) is 6391 P_Unit : constant Entity_Id := Unit (Library_Unit (N)); 6392 E : Entity_Id; 6393 P : Entity_Id; 6394 Lim_Header : Entity_Id; 6395 Lim_Typ : Entity_Id; 6396 Prev : Entity_Id; 6397 6398 begin 6399 pragma Assert (Limited_View_Installed (N)); 6400 6401 -- In case of limited with_clause on subprograms, generics, instances, 6402 -- or renamings, the corresponding error was previously posted and we 6403 -- have nothing to do here. 6404 6405 if Nkind (P_Unit) /= N_Package_Declaration then 6406 return; 6407 end if; 6408 6409 P := Defining_Unit_Name (Specification (P_Unit)); 6410 6411 -- Handle child packages 6412 6413 if Nkind (P) = N_Defining_Program_Unit_Name then 6414 P := Defining_Identifier (P); 6415 end if; 6416 6417 if Debug_Flag_I then 6418 Write_Str ("remove limited view of "); 6419 Write_Name (Chars (P)); 6420 Write_Str (" from visibility"); 6421 Write_Eol; 6422 end if; 6423 6424 -- Prepare the removal of the shadow entities from visibility. The first 6425 -- element of the limited view is a header (an E_Package entity) that is 6426 -- used to reference the first shadow entity in the private part of the 6427 -- package 6428 6429 Lim_Header := Limited_View (P); 6430 Lim_Typ := First_Entity (Lim_Header); 6431 6432 -- Remove package and shadow entities from visibility if it has not 6433 -- been analyzed 6434 6435 if not Analyzed (P_Unit) then 6436 Unchain (P); 6437 Set_Is_Immediately_Visible (P, False); 6438 6439 while Present (Lim_Typ) loop 6440 Unchain (Lim_Typ); 6441 Next_Entity (Lim_Typ); 6442 end loop; 6443 6444 -- Otherwise this package has already appeared in the closure and its 6445 -- shadow entities must be replaced by its real entities. This code 6446 -- must be kept synchronized with the complementary code in Install 6447 -- Limited_Withed_Unit. 6448 6449 else 6450 -- If the limited_with_clause is in some other unit in the context 6451 -- then it is not visible in the main unit. 6452 6453 if not In_Extended_Main_Source_Unit (N) then 6454 Set_Is_Immediately_Visible (P, False); 6455 end if; 6456 6457 -- Real entities that are type or subtype declarations were hidden 6458 -- from visibility at the point of installation of the limited-view. 6459 -- Now we recover the previous value of the hidden attribute. 6460 6461 E := First_Entity (P); 6462 while Present (E) and then E /= First_Private_Entity (P) loop 6463 if Is_Type (E) then 6464 Set_Is_Hidden (E, Was_Hidden (E)); 6465 end if; 6466 6467 Next_Entity (E); 6468 end loop; 6469 6470 while Present (Lim_Typ) 6471 and then Lim_Typ /= First_Private_Entity (Lim_Header) 6472 loop 6473 -- Nested packages and child units were not unchained 6474 6475 if Ekind (Lim_Typ) /= E_Package 6476 and then not Is_Child_Unit (Non_Limited_View (Lim_Typ)) 6477 then 6478 -- If the package has incomplete types, the limited view of the 6479 -- incomplete type is in fact never visible (AI05-129) but we 6480 -- have created a shadow entity E1 for it, that points to E2, 6481 -- a non-limited incomplete type. This in turn has a full view 6482 -- E3 that is the full declaration. There is a corresponding 6483 -- shadow entity E4. When reinstalling the non-limited view, 6484 -- E2 must become the current entity and E3 must be ignored. 6485 6486 E := Non_Limited_View (Lim_Typ); 6487 6488 if Present (Current_Entity (E)) 6489 and then Ekind (Current_Entity (E)) = E_Incomplete_Type 6490 and then Full_View (Current_Entity (E)) = E 6491 then 6492 6493 -- Lim_Typ is the limited view of a full type declaration 6494 -- that has a previous incomplete declaration, i.e. E3 from 6495 -- the previous description. Nothing to insert. 6496 6497 null; 6498 6499 else 6500 pragma Assert (not In_Chain (E)); 6501 6502 Prev := Current_Entity (Lim_Typ); 6503 6504 if Prev = Lim_Typ then 6505 Set_Current_Entity (E); 6506 6507 else 6508 while Present (Prev) 6509 and then Homonym (Prev) /= Lim_Typ 6510 loop 6511 Prev := Homonym (Prev); 6512 end loop; 6513 6514 if Present (Prev) then 6515 Set_Homonym (Prev, E); 6516 end if; 6517 end if; 6518 6519 -- Preserve structure of homonym chain 6520 6521 Set_Homonym (E, Homonym (Lim_Typ)); 6522 end if; 6523 end if; 6524 6525 Next_Entity (Lim_Typ); 6526 end loop; 6527 end if; 6528 6529 -- Indicate that the limited view of the package is not installed 6530 6531 Set_From_Limited_With (P, False); 6532 Set_Limited_View_Installed (N, False); 6533 end Remove_Limited_With_Clause; 6534 6535 -------------------- 6536 -- Remove_Parents -- 6537 -------------------- 6538 6539 procedure Remove_Parents (Lib_Unit : Node_Id) is 6540 P : Node_Id; 6541 P_Name : Entity_Id; 6542 P_Spec : Node_Id := Empty; 6543 E : Entity_Id; 6544 Vis : constant Boolean := 6545 Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility; 6546 6547 begin 6548 if Is_Child_Spec (Lib_Unit) then 6549 P_Spec := Parent_Spec (Lib_Unit); 6550 6551 elsif Nkind (Lib_Unit) = N_Package_Body 6552 and then Nkind (Original_Node (Lib_Unit)) = N_Package_Instantiation 6553 then 6554 P_Spec := Parent_Spec (Original_Node (Lib_Unit)); 6555 end if; 6556 6557 if Present (P_Spec) then 6558 P := Unit (P_Spec); 6559 P_Name := Get_Parent_Entity (P); 6560 Remove_Context_Clauses (P_Spec); 6561 End_Package_Scope (P_Name); 6562 Set_Is_Immediately_Visible (P_Name, Vis); 6563 6564 -- Remove from visibility the siblings as well, which are directly 6565 -- visible while the parent is in scope. 6566 6567 E := First_Entity (P_Name); 6568 while Present (E) loop 6569 if Is_Child_Unit (E) then 6570 Set_Is_Immediately_Visible (E, False); 6571 end if; 6572 6573 Next_Entity (E); 6574 end loop; 6575 6576 Set_In_Package_Body (P_Name, False); 6577 6578 -- This is the recursive call to remove the context of any higher 6579 -- level parent. This recursion ensures that all parents are removed 6580 -- in the reverse order of their installation. 6581 6582 Remove_Parents (P); 6583 end if; 6584 end Remove_Parents; 6585 6586 --------------------------------- 6587 -- Remove_Private_With_Clauses -- 6588 --------------------------------- 6589 6590 procedure Remove_Private_With_Clauses (Comp_Unit : Node_Id) is 6591 Item : Node_Id; 6592 6593 function In_Regular_With_Clause (E : Entity_Id) return Boolean; 6594 -- Check whether a given unit appears in a regular with_clause. Used to 6595 -- determine whether a private_with_clause, implicit or explicit, should 6596 -- be ignored. 6597 6598 ---------------------------- 6599 -- In_Regular_With_Clause -- 6600 ---------------------------- 6601 6602 function In_Regular_With_Clause (E : Entity_Id) return Boolean 6603 is 6604 Item : Node_Id; 6605 6606 begin 6607 Item := First (Context_Items (Comp_Unit)); 6608 while Present (Item) loop 6609 if Nkind (Item) = N_With_Clause 6610 6611 -- The following guard is needed to ensure that the name has 6612 -- been properly analyzed before we go fetching its entity. 6613 6614 and then Is_Entity_Name (Name (Item)) 6615 and then Entity (Name (Item)) = E 6616 and then not Private_Present (Item) 6617 then 6618 return True; 6619 end if; 6620 Next (Item); 6621 end loop; 6622 6623 return False; 6624 end In_Regular_With_Clause; 6625 6626 -- Start of processing for Remove_Private_With_Clauses 6627 6628 begin 6629 Item := First (Context_Items (Comp_Unit)); 6630 while Present (Item) loop 6631 if Nkind (Item) = N_With_Clause and then Private_Present (Item) then 6632 6633 -- If private_with_clause is redundant, remove it from context, 6634 -- as a small optimization to subsequent handling of private_with 6635 -- clauses in other nested packages. We replace the clause with 6636 -- a null statement, which is otherwise ignored by the rest of 6637 -- the compiler, so that ASIS tools can reconstruct the source. 6638 6639 if In_Regular_With_Clause (Entity (Name (Item))) then 6640 declare 6641 Nxt : constant Node_Id := Next (Item); 6642 begin 6643 Rewrite (Item, Make_Null_Statement (Sloc (Item))); 6644 Analyze (Item); 6645 Item := Nxt; 6646 end; 6647 6648 elsif Limited_Present (Item) then 6649 if not Limited_View_Installed (Item) then 6650 Remove_Limited_With_Clause (Item); 6651 end if; 6652 6653 Next (Item); 6654 6655 else 6656 Remove_Unit_From_Visibility (Entity (Name (Item))); 6657 Set_Context_Installed (Item, False); 6658 Next (Item); 6659 end if; 6660 6661 else 6662 Next (Item); 6663 end if; 6664 end loop; 6665 end Remove_Private_With_Clauses; 6666 6667 --------------------------------- 6668 -- Remove_Unit_From_Visibility -- 6669 --------------------------------- 6670 6671 procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id) is 6672 begin 6673 if Debug_Flag_I then 6674 Write_Str ("remove unit "); 6675 Write_Name (Chars (Unit_Name)); 6676 Write_Str (" from visibility"); 6677 Write_Eol; 6678 end if; 6679 6680 Set_Is_Visible_Lib_Unit (Unit_Name, False); 6681 Set_Is_Potentially_Use_Visible (Unit_Name, False); 6682 Set_Is_Immediately_Visible (Unit_Name, False); 6683 6684 -- If the unit is a wrapper package, the subprogram instance is 6685 -- what must be removed from visibility. 6686 -- Should we use Related_Instance instead??? 6687 6688 if Is_Wrapper_Package (Unit_Name) then 6689 Set_Is_Immediately_Visible (Current_Entity (Unit_Name), False); 6690 end if; 6691 end Remove_Unit_From_Visibility; 6692 6693 -------- 6694 -- sm -- 6695 -------- 6696 6697 procedure sm is 6698 begin 6699 null; 6700 end sm; 6701 6702 ------------- 6703 -- Unchain -- 6704 ------------- 6705 6706 procedure Unchain (E : Entity_Id) is 6707 Prev : Entity_Id; 6708 6709 begin 6710 Prev := Current_Entity (E); 6711 6712 if No (Prev) then 6713 return; 6714 6715 elsif Prev = E then 6716 Set_Name_Entity_Id (Chars (E), Homonym (E)); 6717 6718 else 6719 while Present (Prev) and then Homonym (Prev) /= E loop 6720 Prev := Homonym (Prev); 6721 end loop; 6722 6723 if Present (Prev) then 6724 Set_Homonym (Prev, Homonym (E)); 6725 end if; 6726 end if; 6727 6728 if Debug_Flag_I then 6729 Write_Str (" (homonym) unchain "); 6730 Write_Name (Chars (E)); 6731 Write_Eol; 6732 end if; 6733 end Unchain; 6734 6735end Sem_Ch10; 6736