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