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