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