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