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