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