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