1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ C H 7 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2015, 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 26-- This package contains the routines to process package specifications and 27-- bodies. The most important semantic aspects of package processing are the 28-- handling of private and full declarations, and the construction of dispatch 29-- tables for tagged types. 30 31with Aspects; use Aspects; 32with Atree; use Atree; 33with Contracts; use Contracts; 34with Debug; use Debug; 35with Einfo; use Einfo; 36with Elists; use Elists; 37with Errout; use Errout; 38with Exp_Disp; use Exp_Disp; 39with Exp_Dist; use Exp_Dist; 40with Exp_Dbug; use Exp_Dbug; 41with Ghost; use Ghost; 42with Lib; use Lib; 43with Lib.Xref; use Lib.Xref; 44with Namet; use Namet; 45with Nmake; use Nmake; 46with Nlists; use Nlists; 47with Opt; use Opt; 48with Output; use Output; 49with Restrict; use Restrict; 50with Sem; use Sem; 51with Sem_Aux; use Sem_Aux; 52with Sem_Cat; use Sem_Cat; 53with Sem_Ch3; use Sem_Ch3; 54with Sem_Ch6; use Sem_Ch6; 55with Sem_Ch8; use Sem_Ch8; 56with Sem_Ch10; use Sem_Ch10; 57with Sem_Ch12; use Sem_Ch12; 58with Sem_Ch13; use Sem_Ch13; 59with Sem_Disp; use Sem_Disp; 60with Sem_Eval; use Sem_Eval; 61with Sem_Prag; use Sem_Prag; 62with Sem_Util; use Sem_Util; 63with Sem_Warn; use Sem_Warn; 64with Snames; use Snames; 65with Stand; use Stand; 66with Sinfo; use Sinfo; 67with Sinput; use Sinput; 68with Style; 69with Uintp; use Uintp; 70 71package body Sem_Ch7 is 72 73 ----------------------------------- 74 -- Handling private declarations -- 75 ----------------------------------- 76 77 -- The principle that each entity has a single defining occurrence clashes 78 -- with the presence of two separate definitions for private types: the 79 -- first is the private type declaration, and the second is the full type 80 -- declaration. It is important that all references to the type point to 81 -- the same defining occurrence, namely the first one. To enforce the two 82 -- separate views of the entity, the corresponding information is swapped 83 -- between the two declarations. Outside of the package, the defining 84 -- occurrence only contains the private declaration information, while in 85 -- the private part and the body of the package the defining occurrence 86 -- contains the full declaration. To simplify the swap, the defining 87 -- occurrence that currently holds the private declaration points to the 88 -- full declaration. During semantic processing the defining occurrence 89 -- also points to a list of private dependents, that is to say access types 90 -- or composite types whose designated types or component types are 91 -- subtypes or derived types of the private type in question. After the 92 -- full declaration has been seen, the private dependents are updated to 93 -- indicate that they have full definitions. 94 95 ----------------------- 96 -- Local Subprograms -- 97 ----------------------- 98 99 procedure Analyze_Package_Body_Helper (N : Node_Id); 100 -- Does all the real work of Analyze_Package_Body 101 102 procedure Check_Anonymous_Access_Types 103 (Spec_Id : Entity_Id; 104 P_Body : Node_Id); 105 -- If the spec of a package has a limited_with_clause, it may declare 106 -- anonymous access types whose designated type is a limited view, such an 107 -- anonymous access return type for a function. This access type cannot be 108 -- elaborated in the spec itself, but it may need an itype reference if it 109 -- is used within a nested scope. In that case the itype reference is 110 -- created at the beginning of the corresponding package body and inserted 111 -- before other body declarations. 112 113 procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id); 114 -- Called upon entering the private part of a public child package and the 115 -- body of a nested package, to potentially declare certain inherited 116 -- subprograms that were inherited by types in the visible part, but whose 117 -- declaration was deferred because the parent operation was private and 118 -- not visible at that point. These subprograms are located by traversing 119 -- the visible part declarations looking for non-private type extensions 120 -- and then examining each of the primitive operations of such types to 121 -- find those that were inherited but declared with a special internal 122 -- name. Each such operation is now declared as an operation with a normal 123 -- name (using the name of the parent operation) and replaces the previous 124 -- implicit operation in the primitive operations list of the type. If the 125 -- inherited private operation has been overridden, then it's replaced by 126 -- the overriding operation. 127 128 procedure Install_Package_Entity (Id : Entity_Id); 129 -- Supporting procedure for Install_{Visible,Private}_Declarations. Places 130 -- one entity on its visibility chain, and recurses on the visible part if 131 -- the entity is an inner package. 132 133 function Is_Private_Base_Type (E : Entity_Id) return Boolean; 134 -- True for a private type that is not a subtype 135 136 function Is_Visible_Dependent (Dep : Entity_Id) return Boolean; 137 -- If the private dependent is a private type whose full view is derived 138 -- from the parent type, its full properties are revealed only if we are in 139 -- the immediate scope of the private dependent. Should this predicate be 140 -- tightened further??? 141 142 function Requires_Completion_In_Body 143 (Id : Entity_Id; 144 Pack_Id : Entity_Id) return Boolean; 145 -- Subsidiary to routines Unit_Requires_Body and Unit_Requires_Body_Info. 146 -- Determine whether entity Id declared in package spec Pack_Id requires 147 -- completion in a package body. 148 149 procedure Unit_Requires_Body_Info (Pack_Id : Entity_Id); 150 -- Outputs info messages showing why package Pack_Id requires a body. The 151 -- caller has checked that the switch requesting this information is set, 152 -- and that the package does indeed require a body. 153 154 -------------------------- 155 -- Analyze_Package_Body -- 156 -------------------------- 157 158 procedure Analyze_Package_Body (N : Node_Id) is 159 Loc : constant Source_Ptr := Sloc (N); 160 161 begin 162 if Debug_Flag_C then 163 Write_Str ("==> package body "); 164 Write_Name (Chars (Defining_Entity (N))); 165 Write_Str (" from "); 166 Write_Location (Loc); 167 Write_Eol; 168 Indent; 169 end if; 170 171 -- The real work is split out into the helper, so it can do "return;" 172 -- without skipping the debug output. 173 174 Analyze_Package_Body_Helper (N); 175 176 if Debug_Flag_C then 177 Outdent; 178 Write_Str ("<== package body "); 179 Write_Name (Chars (Defining_Entity (N))); 180 Write_Str (" from "); 181 Write_Location (Loc); 182 Write_Eol; 183 end if; 184 end Analyze_Package_Body; 185 186 --------------------------------- 187 -- Analyze_Package_Body_Helper -- 188 --------------------------------- 189 190 procedure Analyze_Package_Body_Helper (N : Node_Id) is 191 procedure Hide_Public_Entities (Decls : List_Id); 192 -- Attempt to hide all public entities found in declarative list Decls 193 -- by resetting their Is_Public flag to False depending on whether the 194 -- entities are not referenced by inlined or generic bodies. This kind 195 -- of processing is a conservative approximation and may still leave 196 -- certain entities externally visible. 197 198 procedure Install_Composite_Operations (P : Entity_Id); 199 -- Composite types declared in the current scope may depend on types 200 -- that were private at the point of declaration, and whose full view 201 -- is now in scope. Indicate that the corresponding operations on the 202 -- composite type are available. 203 204 -------------------------- 205 -- Hide_Public_Entities -- 206 -------------------------- 207 208 procedure Hide_Public_Entities (Decls : List_Id) is 209 function Contains_Subp_Or_Const_Refs (N : Node_Id) return Boolean; 210 -- Subsidiary to routine Has_Referencer. Determine whether a node 211 -- contains a reference to a subprogram or a non-static constant. 212 -- WARNING: this is a very expensive routine as it performs a full 213 -- tree traversal. 214 215 function Has_Referencer 216 (Decls : List_Id; 217 Top_Level : Boolean := False) return Boolean; 218 -- A "referencer" is a construct which may reference a previous 219 -- declaration. Examine all declarations in list Decls in reverse 220 -- and determine whether once such referencer exists. All entities 221 -- in the range Last (Decls) .. Referencer are hidden from external 222 -- visibility. 223 224 --------------------------------- 225 -- Contains_Subp_Or_Const_Refs -- 226 --------------------------------- 227 228 function Contains_Subp_Or_Const_Refs (N : Node_Id) return Boolean is 229 Reference_Seen : Boolean := False; 230 231 function Is_Subp_Or_Const_Ref 232 (N : Node_Id) return Traverse_Result; 233 -- Determine whether a node denotes a reference to a subprogram or 234 -- a non-static constant. 235 236 -------------------------- 237 -- Is_Subp_Or_Const_Ref -- 238 -------------------------- 239 240 function Is_Subp_Or_Const_Ref 241 (N : Node_Id) return Traverse_Result 242 is 243 Val : Node_Id; 244 245 begin 246 -- Detect a reference of the form 247 -- Subp_Call 248 249 if Nkind (N) in N_Subprogram_Call 250 and then Is_Entity_Name (Name (N)) 251 then 252 Reference_Seen := True; 253 return Abandon; 254 255 -- Detect a reference of the form 256 -- Subp'Some_Attribute 257 258 elsif Nkind (N) = N_Attribute_Reference 259 and then Is_Entity_Name (Prefix (N)) 260 and then Present (Entity (Prefix (N))) 261 and then Is_Subprogram (Entity (Prefix (N))) 262 then 263 Reference_Seen := True; 264 return Abandon; 265 266 -- Detect the use of a non-static constant 267 268 elsif Is_Entity_Name (N) 269 and then Present (Entity (N)) 270 and then Ekind (Entity (N)) = E_Constant 271 then 272 Val := Constant_Value (Entity (N)); 273 274 if Present (Val) 275 and then not Compile_Time_Known_Value (Val) 276 then 277 Reference_Seen := True; 278 return Abandon; 279 end if; 280 end if; 281 282 return OK; 283 end Is_Subp_Or_Const_Ref; 284 285 procedure Find_Subp_Or_Const_Ref is 286 new Traverse_Proc (Is_Subp_Or_Const_Ref); 287 288 -- Start of processing for Contains_Subp_Or_Const_Refs 289 290 begin 291 Find_Subp_Or_Const_Ref (N); 292 293 return Reference_Seen; 294 end Contains_Subp_Or_Const_Refs; 295 296 -------------------- 297 -- Has_Referencer -- 298 -------------------- 299 300 function Has_Referencer 301 (Decls : List_Id; 302 Top_Level : Boolean := False) return Boolean 303 is 304 Decl : Node_Id; 305 Decl_Id : Entity_Id; 306 Spec : Node_Id; 307 308 Has_Non_Subp_Const_Referencer : Boolean := False; 309 -- Flag set for inlined subprogram bodies that do not contain 310 -- references to other subprograms or non-static constants. 311 312 begin 313 if No (Decls) then 314 return False; 315 end if; 316 317 -- Examine all declarations in reverse order, hiding all entities 318 -- from external visibility until a referencer has been found. The 319 -- algorithm recurses into nested packages. 320 321 Decl := Last (Decls); 322 while Present (Decl) loop 323 324 -- A stub is always considered a referencer 325 326 if Nkind (Decl) in N_Body_Stub then 327 return True; 328 329 -- Package declaration 330 331 elsif Nkind (Decl) = N_Package_Declaration 332 and then not Has_Non_Subp_Const_Referencer 333 then 334 Spec := Specification (Decl); 335 336 -- Inspect the declarations of a non-generic package to try 337 -- and hide more entities from external visibility. 338 339 if not Is_Generic_Unit (Defining_Entity (Spec)) then 340 if Has_Referencer (Private_Declarations (Spec)) 341 or else Has_Referencer (Visible_Declarations (Spec)) 342 then 343 return True; 344 end if; 345 end if; 346 347 -- Package body 348 349 elsif Nkind (Decl) = N_Package_Body 350 and then Present (Corresponding_Spec (Decl)) 351 then 352 Decl_Id := Corresponding_Spec (Decl); 353 354 -- A generic package body is a referencer. It would seem 355 -- that we only have to consider generics that can be 356 -- exported, i.e. where the corresponding spec is the 357 -- spec of the current package, but because of nested 358 -- instantiations, a fully private generic body may export 359 -- other private body entities. Furthermore, regardless of 360 -- whether there was a previous inlined subprogram, (an 361 -- instantiation of) the generic package may reference any 362 -- entity declared before it. 363 364 if Is_Generic_Unit (Decl_Id) then 365 return True; 366 367 -- Inspect the declarations of a non-generic package body to 368 -- try and hide more entities from external visibility. 369 370 elsif not Has_Non_Subp_Const_Referencer 371 and then Has_Referencer (Declarations (Decl)) 372 then 373 return True; 374 end if; 375 376 -- Subprogram body 377 378 elsif Nkind (Decl) = N_Subprogram_Body then 379 if Present (Corresponding_Spec (Decl)) then 380 Decl_Id := Corresponding_Spec (Decl); 381 382 -- A generic subprogram body acts as a referencer 383 384 if Is_Generic_Unit (Decl_Id) then 385 return True; 386 end if; 387 388 -- An inlined subprogram body acts as a referencer 389 390 if Is_Inlined (Decl_Id) 391 or else Has_Pragma_Inline (Decl_Id) 392 then 393 -- Inspect the statements of the subprogram body 394 -- to determine whether the body references other 395 -- subprograms and/or non-static constants. 396 397 if Top_Level 398 and then not Contains_Subp_Or_Const_Refs (Decl) 399 then 400 Has_Non_Subp_Const_Referencer := True; 401 else 402 return True; 403 end if; 404 end if; 405 406 -- Otherwise this is a stand alone subprogram body 407 408 else 409 Decl_Id := Defining_Entity (Decl); 410 411 -- An inlined body acts as a referencer. Note that an 412 -- inlined subprogram remains Is_Public as gigi requires 413 -- the flag to be set. 414 415 -- Note that we test Has_Pragma_Inline here rather than 416 -- Is_Inlined. We are compiling this for a client, and 417 -- it is the client who will decide if actual inlining 418 -- should occur, so we need to assume that the procedure 419 -- could be inlined for the purpose of accessing global 420 -- entities. 421 422 if Has_Pragma_Inline (Decl_Id) then 423 if Top_Level 424 and then not Contains_Subp_Or_Const_Refs (Decl) 425 then 426 Has_Non_Subp_Const_Referencer := True; 427 else 428 return True; 429 end if; 430 else 431 Set_Is_Public (Decl_Id, False); 432 end if; 433 end if; 434 435 -- Exceptions, objects and renamings do not need to be public 436 -- if they are not followed by a construct which can reference 437 -- and export them. The Is_Public flag is reset on top level 438 -- entities only as anything nested is local to its context. 439 440 elsif Nkind_In (Decl, N_Exception_Declaration, 441 N_Object_Declaration, 442 N_Object_Renaming_Declaration, 443 N_Subprogram_Declaration, 444 N_Subprogram_Renaming_Declaration) 445 then 446 Decl_Id := Defining_Entity (Decl); 447 448 if Top_Level 449 and then not Is_Imported (Decl_Id) 450 and then not Is_Exported (Decl_Id) 451 and then No (Interface_Name (Decl_Id)) 452 and then 453 (not Has_Non_Subp_Const_Referencer 454 or else Nkind (Decl) = N_Subprogram_Declaration) 455 then 456 Set_Is_Public (Decl_Id, False); 457 end if; 458 end if; 459 460 Prev (Decl); 461 end loop; 462 463 return Has_Non_Subp_Const_Referencer; 464 end Has_Referencer; 465 466 -- Local variables 467 468 Discard : Boolean := True; 469 pragma Unreferenced (Discard); 470 471 -- Start of processing for Hide_Public_Entities 472 473 begin 474 -- The algorithm examines the top level declarations of a package 475 -- body in reverse looking for a construct that may export entities 476 -- declared prior to it. If such a scenario is encountered, then all 477 -- entities in the range Last (Decls) .. construct are hidden from 478 -- external visibility. Consider: 479 480 -- package Pack is 481 -- generic 482 -- package Gen is 483 -- end Gen; 484 -- end Pack; 485 486 -- package body Pack is 487 -- External_Obj : ...; -- (1) 488 489 -- package body Gen is -- (2) 490 -- ... External_Obj ... -- (3) 491 -- end Gen; 492 493 -- Local_Obj : ...; -- (4) 494 -- end Pack; 495 496 -- In this example Local_Obj (4) must not be externally visible as 497 -- it cannot be exported by anything in Pack. The body of generic 498 -- package Gen (2) on the other hand acts as a "referencer" and may 499 -- export anything declared before it. Since the compiler does not 500 -- perform flow analysis, it is not possible to determine precisely 501 -- which entities will be exported when Gen is instantiated. In the 502 -- example above External_Obj (1) is exported at (3), but this may 503 -- not always be the case. The algorithm takes a conservative stance 504 -- and leaves entity External_Obj public. 505 506 Discard := Has_Referencer (Decls, Top_Level => True); 507 end Hide_Public_Entities; 508 509 ---------------------------------- 510 -- Install_Composite_Operations -- 511 ---------------------------------- 512 513 procedure Install_Composite_Operations (P : Entity_Id) is 514 Id : Entity_Id; 515 516 begin 517 Id := First_Entity (P); 518 while Present (Id) loop 519 if Is_Type (Id) 520 and then (Is_Limited_Composite (Id) 521 or else Is_Private_Composite (Id)) 522 and then No (Private_Component (Id)) 523 then 524 Set_Is_Limited_Composite (Id, False); 525 Set_Is_Private_Composite (Id, False); 526 end if; 527 528 Next_Entity (Id); 529 end loop; 530 end Install_Composite_Operations; 531 532 -- Local variables 533 534 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; 535 Body_Id : Entity_Id; 536 HSS : Node_Id; 537 Last_Spec_Entity : Entity_Id; 538 New_N : Node_Id; 539 Pack_Decl : Node_Id; 540 Spec_Id : Entity_Id; 541 542 -- Start of processing for Analyze_Package_Body_Helper 543 544 begin 545 -- A [generic] package body "freezes" the contract of the nearest 546 -- enclosing package body and all other contracts encountered in the 547 -- same declarative part up to and excluding the package body: 548 549 -- package body Nearest_Enclosing_Package 550 -- with Refined_State => (State => Constit) 551 -- is 552 -- Constit : ...; 553 554 -- package body Freezes_Enclosing_Package_Body 555 -- with Refined_State => (State_2 => Constit_2) 556 -- is 557 -- Constit_2 : ...; 558 559 -- procedure Proc 560 -- with Refined_Depends => (Input => (Constit, Constit_2)) ... 561 562 -- This ensures that any annotations referenced by the contract of a 563 -- [generic] subprogram body declared within the current package body 564 -- are available. This form of "freezing" is decoupled from the usual 565 -- Freeze_xxx mechanism because it must also work in the context of 566 -- generics where normal freezing is disabled. 567 568 -- Only bodies coming from source should cause this type of "freezing" 569 570 if Comes_From_Source (N) then 571 Analyze_Previous_Contracts (N); 572 end if; 573 574 -- Find corresponding package specification, and establish the current 575 -- scope. The visible defining entity for the package is the defining 576 -- occurrence in the spec. On exit from the package body, all body 577 -- declarations are attached to the defining entity for the body, but 578 -- the later is never used for name resolution. In this fashion there 579 -- is only one visible entity that denotes the package. 580 581 -- Set Body_Id. Note that this will be reset to point to the generic 582 -- copy later on in the generic case. 583 584 Body_Id := Defining_Entity (N); 585 586 -- Body is body of package instantiation. Corresponding spec has already 587 -- been set. 588 589 if Present (Corresponding_Spec (N)) then 590 Spec_Id := Corresponding_Spec (N); 591 Pack_Decl := Unit_Declaration_Node (Spec_Id); 592 593 else 594 Spec_Id := Current_Entity_In_Scope (Defining_Entity (N)); 595 596 if Present (Spec_Id) 597 and then Is_Package_Or_Generic_Package (Spec_Id) 598 then 599 Pack_Decl := Unit_Declaration_Node (Spec_Id); 600 601 if Nkind (Pack_Decl) = N_Package_Renaming_Declaration then 602 Error_Msg_N ("cannot supply body for package renaming", N); 603 return; 604 605 elsif Present (Corresponding_Body (Pack_Decl)) then 606 Error_Msg_N ("redefinition of package body", N); 607 return; 608 end if; 609 610 else 611 Error_Msg_N ("missing specification for package body", N); 612 return; 613 end if; 614 615 if Is_Package_Or_Generic_Package (Spec_Id) 616 and then (Scope (Spec_Id) = Standard_Standard 617 or else Is_Child_Unit (Spec_Id)) 618 and then not Unit_Requires_Body (Spec_Id) 619 then 620 if Ada_Version = Ada_83 then 621 Error_Msg_N 622 ("optional package body (not allowed in Ada 95)??", N); 623 else 624 Error_Msg_N ("spec of this package does not allow a body", N); 625 end if; 626 end if; 627 end if; 628 629 -- A package body is Ghost when the corresponding spec is Ghost. Set 630 -- the mode now to ensure that any nodes generated during analysis and 631 -- expansion are properly flagged as ignored Ghost. 632 633 Set_Ghost_Mode (N, Spec_Id); 634 635 Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id)); 636 Style.Check_Identifier (Body_Id, Spec_Id); 637 638 if Is_Child_Unit (Spec_Id) then 639 if Nkind (Parent (N)) /= N_Compilation_Unit then 640 Error_Msg_NE 641 ("body of child unit& cannot be an inner package", N, Spec_Id); 642 end if; 643 644 Set_Is_Child_Unit (Body_Id); 645 end if; 646 647 -- Generic package case 648 649 if Ekind (Spec_Id) = E_Generic_Package then 650 651 -- Disable expansion and perform semantic analysis on copy. The 652 -- unannotated body will be used in all instantiations. 653 654 Body_Id := Defining_Entity (N); 655 Set_Ekind (Body_Id, E_Package_Body); 656 Set_Scope (Body_Id, Scope (Spec_Id)); 657 Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id)); 658 Set_Body_Entity (Spec_Id, Body_Id); 659 Set_Spec_Entity (Body_Id, Spec_Id); 660 661 New_N := Copy_Generic_Node (N, Empty, Instantiating => False); 662 Rewrite (N, New_N); 663 664 -- Once the contents of the generic copy and the template are 665 -- swapped, do the same for their respective aspect specifications. 666 667 Exchange_Aspects (N, New_N); 668 669 -- Collect all contract-related source pragmas found within the 670 -- template and attach them to the contract of the package body. 671 -- This contract is used in the capture of global references within 672 -- annotations. 673 674 Create_Generic_Contract (N); 675 676 -- Update Body_Id to point to the copied node for the remainder of 677 -- the processing. 678 679 Body_Id := Defining_Entity (N); 680 Start_Generic; 681 end if; 682 683 -- The Body_Id is that of the copied node in the generic case, the 684 -- current node otherwise. Note that N was rewritten above, so we must 685 -- be sure to get the latest Body_Id value. 686 687 Set_Ekind (Body_Id, E_Package_Body); 688 Set_Body_Entity (Spec_Id, Body_Id); 689 Set_Spec_Entity (Body_Id, Spec_Id); 690 691 -- Defining name for the package body is not a visible entity: Only the 692 -- defining name for the declaration is visible. 693 694 Set_Etype (Body_Id, Standard_Void_Type); 695 Set_Scope (Body_Id, Scope (Spec_Id)); 696 Set_Corresponding_Spec (N, Spec_Id); 697 Set_Corresponding_Body (Pack_Decl, Body_Id); 698 699 -- The body entity is not used for semantics or code generation, but 700 -- it is attached to the entity list of the enclosing scope to simplify 701 -- the listing of back-annotations for the types it main contain. 702 703 if Scope (Spec_Id) /= Standard_Standard then 704 Append_Entity (Body_Id, Scope (Spec_Id)); 705 end if; 706 707 -- Indicate that we are currently compiling the body of the package 708 709 Set_In_Package_Body (Spec_Id); 710 Set_Has_Completion (Spec_Id); 711 Last_Spec_Entity := Last_Entity (Spec_Id); 712 713 if Has_Aspects (N) then 714 Analyze_Aspect_Specifications (N, Body_Id); 715 end if; 716 717 Push_Scope (Spec_Id); 718 719 -- Set SPARK_Mode only for non-generic package 720 721 if Ekind (Spec_Id) = E_Package then 722 Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); 723 Set_SPARK_Aux_Pragma (Body_Id, SPARK_Mode_Pragma); 724 Set_SPARK_Pragma_Inherited (Body_Id); 725 Set_SPARK_Aux_Pragma_Inherited (Body_Id); 726 end if; 727 728 -- Inherit the "ghostness" of the package spec. Note that this property 729 -- is not directly inherited as the body may be subject to a different 730 -- Ghost assertion policy. 731 732 if Ghost_Mode > None or else Is_Ghost_Entity (Spec_Id) then 733 Set_Is_Ghost_Entity (Body_Id); 734 735 -- The Ghost policy in effect at the point of declaration and at the 736 -- point of completion must match (SPARK RM 6.9(14)). 737 738 Check_Ghost_Completion (Spec_Id, Body_Id); 739 end if; 740 741 Set_Categorization_From_Pragmas (N); 742 743 Install_Visible_Declarations (Spec_Id); 744 Install_Private_Declarations (Spec_Id); 745 Install_Private_With_Clauses (Spec_Id); 746 Install_Composite_Operations (Spec_Id); 747 748 Check_Anonymous_Access_Types (Spec_Id, N); 749 750 if Ekind (Spec_Id) = E_Generic_Package then 751 Set_Use (Generic_Formal_Declarations (Pack_Decl)); 752 end if; 753 754 Set_Use (Visible_Declarations (Specification (Pack_Decl))); 755 Set_Use (Private_Declarations (Specification (Pack_Decl))); 756 757 -- This is a nested package, so it may be necessary to declare certain 758 -- inherited subprograms that are not yet visible because the parent 759 -- type's subprograms are now visible. 760 761 if Ekind (Scope (Spec_Id)) = E_Package 762 and then Scope (Spec_Id) /= Standard_Standard 763 then 764 Declare_Inherited_Private_Subprograms (Spec_Id); 765 end if; 766 767 -- A package body "freezes" the contract of its initial declaration. 768 -- This analysis depends on attribute Corresponding_Spec being set. Only 769 -- bodies coming from source shuld cause this type of "freezing". 770 771 if Present (Declarations (N)) then 772 Analyze_Declarations (Declarations (N)); 773 Inspect_Deferred_Constant_Completion (Declarations (N)); 774 end if; 775 776 -- Verify that the SPARK_Mode of the body agrees with that of its spec 777 778 if Present (SPARK_Pragma (Body_Id)) then 779 if Present (SPARK_Aux_Pragma (Spec_Id)) then 780 if Get_SPARK_Mode_From_Pragma (SPARK_Aux_Pragma (Spec_Id)) = Off 781 and then 782 Get_SPARK_Mode_From_Pragma (SPARK_Pragma (Body_Id)) = On 783 then 784 Error_Msg_Sloc := Sloc (SPARK_Pragma (Body_Id)); 785 Error_Msg_N ("incorrect application of SPARK_Mode#", N); 786 Error_Msg_Sloc := Sloc (SPARK_Aux_Pragma (Spec_Id)); 787 Error_Msg_NE 788 ("\value Off was set for SPARK_Mode on & #", N, Spec_Id); 789 end if; 790 791 else 792 Error_Msg_Sloc := Sloc (SPARK_Pragma (Body_Id)); 793 Error_Msg_N ("incorrect application of SPARK_Mode#", N); 794 Error_Msg_Sloc := Sloc (Spec_Id); 795 Error_Msg_NE 796 ("\no value was set for SPARK_Mode on & #", N, Spec_Id); 797 end if; 798 end if; 799 800 -- Analyze_Declarations has caused freezing of all types. Now generate 801 -- bodies for RACW primitives and stream attributes, if any. 802 803 if Ekind (Spec_Id) = E_Package and then Has_RACW (Spec_Id) then 804 805 -- Attach subprogram bodies to support RACWs declared in spec 806 807 Append_RACW_Bodies (Declarations (N), Spec_Id); 808 Analyze_List (Declarations (N)); 809 end if; 810 811 HSS := Handled_Statement_Sequence (N); 812 813 if Present (HSS) then 814 Process_End_Label (HSS, 't', Spec_Id); 815 Analyze (HSS); 816 817 -- Check that elaboration code in a preelaborable package body is 818 -- empty other than null statements and labels (RM 10.2.1(6)). 819 820 Validate_Null_Statement_Sequence (N); 821 end if; 822 823 Validate_Categorization_Dependency (N, Spec_Id); 824 Check_Completion (Body_Id); 825 826 -- Generate start of body reference. Note that we do this fairly late, 827 -- because the call will use In_Extended_Main_Source_Unit as a check, 828 -- and we want to make sure that Corresponding_Stub links are set 829 830 Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False); 831 832 -- For a generic package, collect global references and mark them on 833 -- the original body so that they are not resolved again at the point 834 -- of instantiation. 835 836 if Ekind (Spec_Id) /= E_Package then 837 Save_Global_References (Original_Node (N)); 838 End_Generic; 839 end if; 840 841 -- The entities of the package body have so far been chained onto the 842 -- declaration chain for the spec. That's been fine while we were in the 843 -- body, since we wanted them to be visible, but now that we are leaving 844 -- the package body, they are no longer visible, so we remove them from 845 -- the entity chain of the package spec entity, and copy them to the 846 -- entity chain of the package body entity, where they will never again 847 -- be visible. 848 849 if Present (Last_Spec_Entity) then 850 Set_First_Entity (Body_Id, Next_Entity (Last_Spec_Entity)); 851 Set_Next_Entity (Last_Spec_Entity, Empty); 852 Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); 853 Set_Last_Entity (Spec_Id, Last_Spec_Entity); 854 855 else 856 Set_First_Entity (Body_Id, First_Entity (Spec_Id)); 857 Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); 858 Set_First_Entity (Spec_Id, Empty); 859 Set_Last_Entity (Spec_Id, Empty); 860 end if; 861 862 End_Package_Scope (Spec_Id); 863 864 -- All entities declared in body are not visible 865 866 declare 867 E : Entity_Id; 868 869 begin 870 E := First_Entity (Body_Id); 871 while Present (E) loop 872 Set_Is_Immediately_Visible (E, False); 873 Set_Is_Potentially_Use_Visible (E, False); 874 Set_Is_Hidden (E); 875 876 -- Child units may appear on the entity list (e.g. if they appear 877 -- in the context of a subunit) but they are not body entities. 878 879 if not Is_Child_Unit (E) then 880 Set_Is_Package_Body_Entity (E); 881 end if; 882 883 Next_Entity (E); 884 end loop; 885 end; 886 887 Check_References (Body_Id); 888 889 -- For a generic unit, check that the formal parameters are referenced, 890 -- and that local variables are used, as for regular packages. 891 892 if Ekind (Spec_Id) = E_Generic_Package then 893 Check_References (Spec_Id); 894 end if; 895 896 -- At this point all entities of the package body are externally visible 897 -- to the linker as their Is_Public flag is set to True. This proactive 898 -- approach is necessary because an inlined or a generic body for which 899 -- code is generated in other units may need to see these entities. Cut 900 -- down the number of global symbols that do not neet public visibility 901 -- as this has two beneficial effects: 902 -- (1) It makes the compilation process more efficient. 903 -- (2) It gives the code generatormore freedom to optimize within each 904 -- unit, especially subprograms. 905 906 -- This is done only for top level library packages or child units as 907 -- the algorithm does a top down traversal of the package body. 908 909 if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id)) 910 and then not Is_Generic_Unit (Spec_Id) 911 then 912 Hide_Public_Entities (Declarations (N)); 913 end if; 914 915 -- If expander is not active, then here is where we turn off the 916 -- In_Package_Body flag, otherwise it is turned off at the end of the 917 -- corresponding expansion routine. If this is an instance body, we need 918 -- to qualify names of local entities, because the body may have been 919 -- compiled as a preliminary to another instantiation. 920 921 if not Expander_Active then 922 Set_In_Package_Body (Spec_Id, False); 923 924 if Is_Generic_Instance (Spec_Id) 925 and then Operating_Mode = Generate_Code 926 then 927 Qualify_Entity_Names (N); 928 end if; 929 end if; 930 931 Ghost_Mode := Save_Ghost_Mode; 932 end Analyze_Package_Body_Helper; 933 934 --------------------------------- 935 -- Analyze_Package_Declaration -- 936 --------------------------------- 937 938 procedure Analyze_Package_Declaration (N : Node_Id) is 939 Id : constant Node_Id := Defining_Entity (N); 940 941 Body_Required : Boolean; 942 -- True when this package declaration requires a corresponding body 943 944 Comp_Unit : Boolean; 945 -- True when this package declaration is not a nested declaration 946 947 PF : Boolean; 948 -- True when in the context of a declared pure library unit 949 950 begin 951 if Debug_Flag_C then 952 Write_Str ("==> package spec "); 953 Write_Name (Chars (Id)); 954 Write_Str (" from "); 955 Write_Location (Sloc (N)); 956 Write_Eol; 957 Indent; 958 end if; 959 960 Generate_Definition (Id); 961 Enter_Name (Id); 962 Set_Ekind (Id, E_Package); 963 Set_Etype (Id, Standard_Void_Type); 964 965 -- Set SPARK_Mode from context only for non-generic package 966 967 if Ekind (Id) = E_Package then 968 Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); 969 Set_SPARK_Aux_Pragma (Id, SPARK_Mode_Pragma); 970 Set_SPARK_Pragma_Inherited (Id); 971 Set_SPARK_Aux_Pragma_Inherited (Id); 972 end if; 973 974 -- A package declared within a Ghost refion is automatically Ghost 975 -- (SPARK RM 6.9(2)). 976 977 if Ghost_Mode > None then 978 Set_Is_Ghost_Entity (Id); 979 end if; 980 981 -- Analyze aspect specifications immediately, since we need to recognize 982 -- things like Pure early enough to diagnose violations during analysis. 983 984 if Has_Aspects (N) then 985 Analyze_Aspect_Specifications (N, Id); 986 end if; 987 988 -- Ada 2005 (AI-217): Check if the package has been illegally named 989 -- in a limited-with clause of its own context. In this case the error 990 -- has been previously notified by Analyze_Context. 991 992 -- limited with Pkg; -- ERROR 993 -- package Pkg is ... 994 995 if From_Limited_With (Id) then 996 return; 997 end if; 998 999 Push_Scope (Id); 1000 1001 PF := Is_Pure (Enclosing_Lib_Unit_Entity); 1002 Set_Is_Pure (Id, PF); 1003 1004 Set_Categorization_From_Pragmas (N); 1005 1006 Analyze (Specification (N)); 1007 Validate_Categorization_Dependency (N, Id); 1008 1009 Body_Required := Unit_Requires_Body (Id); 1010 1011 -- When this spec does not require an explicit body, we know that there 1012 -- are no entities requiring completion in the language sense; we call 1013 -- Check_Completion here only to ensure that any nested package 1014 -- declaration that requires an implicit body gets one. (In the case 1015 -- where a body is required, Check_Completion is called at the end of 1016 -- the body's declarative part.) 1017 1018 if not Body_Required then 1019 Check_Completion; 1020 end if; 1021 1022 Comp_Unit := Nkind (Parent (N)) = N_Compilation_Unit; 1023 1024 if Comp_Unit then 1025 1026 -- Set Body_Required indication on the compilation unit node, and 1027 -- determine whether elaboration warnings may be meaningful on it. 1028 1029 Set_Body_Required (Parent (N), Body_Required); 1030 1031 if not Body_Required then 1032 Set_Suppress_Elaboration_Warnings (Id); 1033 end if; 1034 end if; 1035 1036 End_Package_Scope (Id); 1037 1038 -- For the declaration of a library unit that is a remote types package, 1039 -- check legality rules regarding availability of stream attributes for 1040 -- types that contain non-remote access values. This subprogram performs 1041 -- visibility tests that rely on the fact that we have exited the scope 1042 -- of Id. 1043 1044 if Comp_Unit then 1045 Validate_RT_RAT_Component (N); 1046 end if; 1047 1048 if Debug_Flag_C then 1049 Outdent; 1050 Write_Str ("<== package spec "); 1051 Write_Name (Chars (Id)); 1052 Write_Str (" from "); 1053 Write_Location (Sloc (N)); 1054 Write_Eol; 1055 end if; 1056 end Analyze_Package_Declaration; 1057 1058 ----------------------------------- 1059 -- Analyze_Package_Specification -- 1060 ----------------------------------- 1061 1062 -- Note that this code is shared for the analysis of generic package specs 1063 -- (see Sem_Ch12.Analyze_Generic_Package_Declaration for details). 1064 1065 procedure Analyze_Package_Specification (N : Node_Id) is 1066 Id : constant Entity_Id := Defining_Entity (N); 1067 Orig_Decl : constant Node_Id := Original_Node (Parent (N)); 1068 Vis_Decls : constant List_Id := Visible_Declarations (N); 1069 Priv_Decls : constant List_Id := Private_Declarations (N); 1070 E : Entity_Id; 1071 L : Entity_Id; 1072 Public_Child : Boolean; 1073 1074 Private_With_Clauses_Installed : Boolean := False; 1075 -- In Ada 2005, private with_clauses are visible in the private part 1076 -- of a nested package, even if it appears in the public part of the 1077 -- enclosing package. This requires a separate step to install these 1078 -- private_with_clauses, and remove them at the end of the nested 1079 -- package. 1080 1081 procedure Check_One_Tagged_Type_Or_Extension_At_Most; 1082 -- Issue an error in SPARK mode if a package specification contains 1083 -- more than one tagged type or type extension. 1084 1085 procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id); 1086 -- Clears constant indications (Never_Set_In_Source, Constant_Value, and 1087 -- Is_True_Constant) on all variables that are entities of Id, and on 1088 -- the chain whose first element is FE. A recursive call is made for all 1089 -- packages and generic packages. 1090 1091 procedure Generate_Parent_References; 1092 -- For a child unit, generate references to parent units, for 1093 -- GPS navigation purposes. 1094 1095 function Is_Public_Child (Child, Unit : Entity_Id) return Boolean; 1096 -- Child and Unit are entities of compilation units. True if Child 1097 -- is a public child of Parent as defined in 10.1.1 1098 1099 procedure Inspect_Unchecked_Union_Completion (Decls : List_Id); 1100 -- Reject completion of an incomplete or private type declarations 1101 -- having a known discriminant part by an unchecked union. 1102 1103 procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id); 1104 -- Given the package entity of a generic package instantiation or 1105 -- formal package whose corresponding generic is a child unit, installs 1106 -- the private declarations of each of the child unit's parents. 1107 -- This has to be done at the point of entering the instance package's 1108 -- private part rather than being done in Sem_Ch12.Install_Parent 1109 -- (which is where the parents' visible declarations are installed). 1110 1111 ------------------------------------------------ 1112 -- Check_One_Tagged_Type_Or_Extension_At_Most -- 1113 ------------------------------------------------ 1114 1115 procedure Check_One_Tagged_Type_Or_Extension_At_Most is 1116 Previous : Node_Id; 1117 1118 procedure Check_Decls (Decls : List_Id); 1119 -- Check that either Previous is Empty and Decls does not contain 1120 -- more than one tagged type or type extension, or Previous is 1121 -- already set and Decls contains no tagged type or type extension. 1122 1123 ----------------- 1124 -- Check_Decls -- 1125 ----------------- 1126 1127 procedure Check_Decls (Decls : List_Id) is 1128 Decl : Node_Id; 1129 1130 begin 1131 Decl := First (Decls); 1132 while Present (Decl) loop 1133 if Nkind (Decl) = N_Full_Type_Declaration 1134 and then Is_Tagged_Type (Defining_Identifier (Decl)) 1135 then 1136 if No (Previous) then 1137 Previous := Decl; 1138 1139 else 1140 Error_Msg_Sloc := Sloc (Previous); 1141 Check_SPARK_05_Restriction 1142 ("at most one tagged type or type extension allowed", 1143 "\\ previous declaration#", 1144 Decl); 1145 end if; 1146 end if; 1147 1148 Next (Decl); 1149 end loop; 1150 end Check_Decls; 1151 1152 -- Start of processing for Check_One_Tagged_Type_Or_Extension_At_Most 1153 1154 begin 1155 Previous := Empty; 1156 Check_Decls (Vis_Decls); 1157 1158 if Present (Priv_Decls) then 1159 Check_Decls (Priv_Decls); 1160 end if; 1161 end Check_One_Tagged_Type_Or_Extension_At_Most; 1162 1163 --------------------- 1164 -- Clear_Constants -- 1165 --------------------- 1166 1167 procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id) is 1168 E : Entity_Id; 1169 1170 begin 1171 -- Ignore package renamings, not interesting and they can cause self 1172 -- referential loops in the code below. 1173 1174 if Nkind (Parent (Id)) = N_Package_Renaming_Declaration then 1175 return; 1176 end if; 1177 1178 -- Note: in the loop below, the check for Next_Entity pointing back 1179 -- to the package entity may seem odd, but it is needed, because a 1180 -- package can contain a renaming declaration to itself, and such 1181 -- renamings are generated automatically within package instances. 1182 1183 E := FE; 1184 while Present (E) and then E /= Id loop 1185 if Is_Assignable (E) then 1186 Set_Never_Set_In_Source (E, False); 1187 Set_Is_True_Constant (E, False); 1188 Set_Current_Value (E, Empty); 1189 Set_Is_Known_Null (E, False); 1190 Set_Last_Assignment (E, Empty); 1191 1192 if not Can_Never_Be_Null (E) then 1193 Set_Is_Known_Non_Null (E, False); 1194 end if; 1195 1196 elsif Is_Package_Or_Generic_Package (E) then 1197 Clear_Constants (E, First_Entity (E)); 1198 Clear_Constants (E, First_Private_Entity (E)); 1199 end if; 1200 1201 Next_Entity (E); 1202 end loop; 1203 end Clear_Constants; 1204 1205 -------------------------------- 1206 -- Generate_Parent_References -- 1207 -------------------------------- 1208 1209 procedure Generate_Parent_References is 1210 Decl : constant Node_Id := Parent (N); 1211 1212 begin 1213 if Id = Cunit_Entity (Main_Unit) 1214 or else Parent (Decl) = Library_Unit (Cunit (Main_Unit)) 1215 then 1216 Generate_Reference (Id, Scope (Id), 'k', False); 1217 1218 elsif not Nkind_In (Unit (Cunit (Main_Unit)), N_Subprogram_Body, 1219 N_Subunit) 1220 then 1221 -- If current unit is an ancestor of main unit, generate a 1222 -- reference to its own parent. 1223 1224 declare 1225 U : Node_Id; 1226 Main_Spec : Node_Id := Unit (Cunit (Main_Unit)); 1227 1228 begin 1229 if Nkind (Main_Spec) = N_Package_Body then 1230 Main_Spec := Unit (Library_Unit (Cunit (Main_Unit))); 1231 end if; 1232 1233 U := Parent_Spec (Main_Spec); 1234 while Present (U) loop 1235 if U = Parent (Decl) then 1236 Generate_Reference (Id, Scope (Id), 'k', False); 1237 exit; 1238 1239 elsif Nkind (Unit (U)) = N_Package_Body then 1240 exit; 1241 1242 else 1243 U := Parent_Spec (Unit (U)); 1244 end if; 1245 end loop; 1246 end; 1247 end if; 1248 end Generate_Parent_References; 1249 1250 --------------------- 1251 -- Is_Public_Child -- 1252 --------------------- 1253 1254 function Is_Public_Child (Child, Unit : Entity_Id) return Boolean is 1255 begin 1256 if not Is_Private_Descendant (Child) then 1257 return True; 1258 else 1259 if Child = Unit then 1260 return not Private_Present ( 1261 Parent (Unit_Declaration_Node (Child))); 1262 else 1263 return Is_Public_Child (Scope (Child), Unit); 1264 end if; 1265 end if; 1266 end Is_Public_Child; 1267 1268 ---------------------------------------- 1269 -- Inspect_Unchecked_Union_Completion -- 1270 ---------------------------------------- 1271 1272 procedure Inspect_Unchecked_Union_Completion (Decls : List_Id) is 1273 Decl : Node_Id; 1274 1275 begin 1276 Decl := First (Decls); 1277 while Present (Decl) loop 1278 1279 -- We are looking at an incomplete or private type declaration 1280 -- with a known_discriminant_part whose full view is an 1281 -- Unchecked_Union. 1282 1283 if Nkind_In (Decl, N_Incomplete_Type_Declaration, 1284 N_Private_Type_Declaration) 1285 and then Has_Discriminants (Defining_Identifier (Decl)) 1286 and then Present (Full_View (Defining_Identifier (Decl))) 1287 and then 1288 Is_Unchecked_Union (Full_View (Defining_Identifier (Decl))) 1289 then 1290 Error_Msg_N 1291 ("completion of discriminated partial view " 1292 & "cannot be an unchecked union", 1293 Full_View (Defining_Identifier (Decl))); 1294 end if; 1295 1296 Next (Decl); 1297 end loop; 1298 end Inspect_Unchecked_Union_Completion; 1299 1300 ----------------------------------------- 1301 -- Install_Parent_Private_Declarations -- 1302 ----------------------------------------- 1303 1304 procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id) is 1305 Inst_Par : Entity_Id; 1306 Gen_Par : Entity_Id; 1307 Inst_Node : Node_Id; 1308 1309 begin 1310 Inst_Par := Inst_Id; 1311 1312 Gen_Par := 1313 Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par))); 1314 while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop 1315 Inst_Node := Get_Package_Instantiation_Node (Inst_Par); 1316 1317 if Nkind_In (Inst_Node, N_Package_Instantiation, 1318 N_Formal_Package_Declaration) 1319 and then Nkind (Name (Inst_Node)) = N_Expanded_Name 1320 then 1321 Inst_Par := Entity (Prefix (Name (Inst_Node))); 1322 1323 if Present (Renamed_Entity (Inst_Par)) then 1324 Inst_Par := Renamed_Entity (Inst_Par); 1325 end if; 1326 1327 Gen_Par := 1328 Generic_Parent 1329 (Specification (Unit_Declaration_Node (Inst_Par))); 1330 1331 -- Install the private declarations and private use clauses 1332 -- of a parent instance of the child instance, unless the 1333 -- parent instance private declarations have already been 1334 -- installed earlier in Analyze_Package_Specification, which 1335 -- happens when a generic child is instantiated, and the 1336 -- instance is a child of the parent instance. 1337 1338 -- Installing the use clauses of the parent instance twice 1339 -- is both unnecessary and wrong, because it would cause the 1340 -- clauses to be chained to themselves in the use clauses 1341 -- list of the scope stack entry. That in turn would cause 1342 -- an endless loop from End_Use_Clauses upon scope exit. 1343 1344 -- The parent is now fully visible. It may be a hidden open 1345 -- scope if we are currently compiling some child instance 1346 -- declared within it, but while the current instance is being 1347 -- compiled the parent is immediately visible. In particular 1348 -- its entities must remain visible if a stack save/restore 1349 -- takes place through a call to Rtsfind. 1350 1351 if Present (Gen_Par) then 1352 if not In_Private_Part (Inst_Par) then 1353 Install_Private_Declarations (Inst_Par); 1354 Set_Use (Private_Declarations 1355 (Specification 1356 (Unit_Declaration_Node (Inst_Par)))); 1357 Set_Is_Hidden_Open_Scope (Inst_Par, False); 1358 end if; 1359 1360 -- If we've reached the end of the generic instance parents, 1361 -- then finish off by looping through the nongeneric parents 1362 -- and installing their private declarations. 1363 1364 -- If one of the non-generic parents is itself on the scope 1365 -- stack, do not install its private declarations: they are 1366 -- installed in due time when the private part of that parent 1367 -- is analyzed. This is delicate ??? 1368 1369 else 1370 while Present (Inst_Par) 1371 and then Inst_Par /= Standard_Standard 1372 and then (not In_Open_Scopes (Inst_Par) 1373 or else not In_Private_Part (Inst_Par)) 1374 loop 1375 Install_Private_Declarations (Inst_Par); 1376 Set_Use (Private_Declarations 1377 (Specification 1378 (Unit_Declaration_Node (Inst_Par)))); 1379 Inst_Par := Scope (Inst_Par); 1380 end loop; 1381 1382 exit; 1383 end if; 1384 1385 else 1386 exit; 1387 end if; 1388 end loop; 1389 end Install_Parent_Private_Declarations; 1390 1391 -- Start of processing for Analyze_Package_Specification 1392 1393 begin 1394 if Present (Vis_Decls) then 1395 Analyze_Declarations (Vis_Decls); 1396 end if; 1397 1398 -- Inspect the entities defined in the package and ensure that all 1399 -- incomplete types have received full declarations. Build default 1400 -- initial condition and invariant procedures for all qualifying types. 1401 1402 E := First_Entity (Id); 1403 while Present (E) loop 1404 1405 -- Check on incomplete types 1406 1407 -- AI05-0213: A formal incomplete type has no completion 1408 1409 if Ekind (E) = E_Incomplete_Type 1410 and then No (Full_View (E)) 1411 and then not Is_Generic_Type (E) 1412 then 1413 Error_Msg_N ("no declaration in visible part for incomplete}", E); 1414 end if; 1415 1416 if Is_Type (E) then 1417 1418 -- Each private type subject to pragma Default_Initial_Condition 1419 -- declares a specialized procedure which verifies the assumption 1420 -- of the pragma. The declaration appears in the visible part of 1421 -- the package to allow for being called from the outside. 1422 1423 if Has_Default_Init_Cond (E) then 1424 Build_Default_Init_Cond_Procedure_Declaration (E); 1425 1426 -- A private extension inherits the default initial condition 1427 -- procedure from its parent type. 1428 1429 elsif Has_Inherited_Default_Init_Cond (E) then 1430 Inherit_Default_Init_Cond_Procedure (E); 1431 end if; 1432 1433 -- If invariants are present, build the invariant procedure for a 1434 -- private type, but not any of its subtypes or interface types. 1435 1436 if Has_Invariants (E) then 1437 if Ekind (E) = E_Private_Subtype then 1438 null; 1439 else 1440 Build_Invariant_Procedure (E, N); 1441 end if; 1442 end if; 1443 end if; 1444 1445 Next_Entity (E); 1446 end loop; 1447 1448 if Is_Remote_Call_Interface (Id) 1449 and then Nkind (Parent (Parent (N))) = N_Compilation_Unit 1450 then 1451 Validate_RCI_Declarations (Id); 1452 end if; 1453 1454 -- Save global references in the visible declarations, before installing 1455 -- private declarations of parent unit if there is one, because the 1456 -- privacy status of types defined in the parent will change. This is 1457 -- only relevant for generic child units, but is done in all cases for 1458 -- uniformity. 1459 1460 if Ekind (Id) = E_Generic_Package 1461 and then Nkind (Orig_Decl) = N_Generic_Package_Declaration 1462 then 1463 declare 1464 Orig_Spec : constant Node_Id := Specification (Orig_Decl); 1465 Save_Priv : constant List_Id := Private_Declarations (Orig_Spec); 1466 begin 1467 Set_Private_Declarations (Orig_Spec, Empty_List); 1468 Save_Global_References (Orig_Decl); 1469 Set_Private_Declarations (Orig_Spec, Save_Priv); 1470 end; 1471 end if; 1472 1473 -- If package is a public child unit, then make the private declarations 1474 -- of the parent visible. 1475 1476 Public_Child := False; 1477 1478 declare 1479 Par : Entity_Id; 1480 Pack_Decl : Node_Id; 1481 Par_Spec : Node_Id; 1482 1483 begin 1484 Par := Id; 1485 Par_Spec := Parent_Spec (Parent (N)); 1486 1487 -- If the package is formal package of an enclosing generic, it is 1488 -- transformed into a local generic declaration, and compiled to make 1489 -- its spec available. We need to retrieve the original generic to 1490 -- determine whether it is a child unit, and install its parents. 1491 1492 if No (Par_Spec) 1493 and then 1494 Nkind (Original_Node (Parent (N))) = N_Formal_Package_Declaration 1495 then 1496 Par := Entity (Name (Original_Node (Parent (N)))); 1497 Par_Spec := Parent_Spec (Unit_Declaration_Node (Par)); 1498 end if; 1499 1500 if Present (Par_Spec) then 1501 Generate_Parent_References; 1502 1503 while Scope (Par) /= Standard_Standard 1504 and then Is_Public_Child (Id, Par) 1505 and then In_Open_Scopes (Par) 1506 loop 1507 Public_Child := True; 1508 Par := Scope (Par); 1509 Install_Private_Declarations (Par); 1510 Install_Private_With_Clauses (Par); 1511 Pack_Decl := Unit_Declaration_Node (Par); 1512 Set_Use (Private_Declarations (Specification (Pack_Decl))); 1513 end loop; 1514 end if; 1515 end; 1516 1517 if Is_Compilation_Unit (Id) then 1518 Install_Private_With_Clauses (Id); 1519 else 1520 1521 -- The current compilation unit may include private with_clauses, 1522 -- which are visible in the private part of the current nested 1523 -- package, and have to be installed now. This is not done for 1524 -- nested instantiations, where the private with_clauses of the 1525 -- enclosing unit have no effect once the instantiation info is 1526 -- established and we start analyzing the package declaration. 1527 1528 declare 1529 Comp_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 1530 begin 1531 if Is_Package_Or_Generic_Package (Comp_Unit) 1532 and then not In_Private_Part (Comp_Unit) 1533 and then not In_Instance 1534 then 1535 Install_Private_With_Clauses (Comp_Unit); 1536 Private_With_Clauses_Installed := True; 1537 end if; 1538 end; 1539 end if; 1540 1541 -- If this is a package associated with a generic instance or formal 1542 -- package, then the private declarations of each of the generic's 1543 -- parents must be installed at this point. 1544 1545 if Is_Generic_Instance (Id) then 1546 Install_Parent_Private_Declarations (Id); 1547 end if; 1548 1549 -- Analyze private part if present. The flag In_Private_Part is reset 1550 -- in End_Package_Scope. 1551 1552 L := Last_Entity (Id); 1553 1554 if Present (Priv_Decls) then 1555 Set_In_Private_Part (Id); 1556 1557 -- Upon entering a public child's private part, it may be necessary 1558 -- to declare subprograms that were derived in the package's visible 1559 -- part but not yet made visible. 1560 1561 if Public_Child then 1562 Declare_Inherited_Private_Subprograms (Id); 1563 end if; 1564 1565 Analyze_Declarations (Priv_Decls); 1566 1567 -- Check the private declarations for incomplete deferred constants 1568 1569 Inspect_Deferred_Constant_Completion (Priv_Decls); 1570 1571 -- The first private entity is the immediate follower of the last 1572 -- visible entity, if there was one. 1573 1574 if Present (L) then 1575 Set_First_Private_Entity (Id, Next_Entity (L)); 1576 else 1577 Set_First_Private_Entity (Id, First_Entity (Id)); 1578 end if; 1579 1580 -- There may be inherited private subprograms that need to be declared, 1581 -- even in the absence of an explicit private part. If there are any 1582 -- public declarations in the package and the package is a public child 1583 -- unit, then an implicit private part is assumed. 1584 1585 elsif Present (L) and then Public_Child then 1586 Set_In_Private_Part (Id); 1587 Declare_Inherited_Private_Subprograms (Id); 1588 Set_First_Private_Entity (Id, Next_Entity (L)); 1589 end if; 1590 1591 E := First_Entity (Id); 1592 while Present (E) loop 1593 1594 -- Check rule of 3.6(11), which in general requires waiting till all 1595 -- full types have been seen. 1596 1597 if Ekind (E) = E_Record_Type or else Ekind (E) = E_Array_Type then 1598 Check_Aliased_Component_Types (E); 1599 end if; 1600 1601 -- Check preelaborable initialization for full type completing a 1602 -- private type for which pragma Preelaborable_Initialization given. 1603 1604 if Is_Type (E) 1605 and then Must_Have_Preelab_Init (E) 1606 and then not Has_Preelaborable_Initialization (E) 1607 then 1608 Error_Msg_N 1609 ("full view of & does not have preelaborable initialization", E); 1610 end if; 1611 1612 -- An invariant may appear on a full view of a type 1613 1614 if Is_Type (E) 1615 and then Has_Private_Declaration (E) 1616 and then Nkind (Parent (E)) = N_Full_Type_Declaration 1617 then 1618 declare 1619 IP_Built : Boolean := False; 1620 1621 begin 1622 if Has_Aspects (Parent (E)) then 1623 declare 1624 ASN : Node_Id; 1625 1626 begin 1627 ASN := First (Aspect_Specifications (Parent (E))); 1628 while Present (ASN) loop 1629 if Nam_In (Chars (Identifier (ASN)), 1630 Name_Invariant, 1631 Name_Type_Invariant) 1632 then 1633 Build_Invariant_Procedure (E, N); 1634 IP_Built := True; 1635 exit; 1636 end if; 1637 1638 Next (ASN); 1639 end loop; 1640 end; 1641 end if; 1642 1643 -- Invariants may have been inherited from progenitors 1644 1645 if not IP_Built 1646 and then Has_Interfaces (E) 1647 and then Has_Inheritable_Invariants (E) 1648 and then not Is_Interface (E) 1649 and then not Is_Class_Wide_Type (E) 1650 then 1651 Build_Invariant_Procedure (E, N); 1652 end if; 1653 end; 1654 end if; 1655 1656 Next_Entity (E); 1657 end loop; 1658 1659 -- Ada 2005 (AI-216): The completion of an incomplete or private type 1660 -- declaration having a known_discriminant_part shall not be an 1661 -- unchecked union type. 1662 1663 if Present (Vis_Decls) then 1664 Inspect_Unchecked_Union_Completion (Vis_Decls); 1665 end if; 1666 1667 if Present (Priv_Decls) then 1668 Inspect_Unchecked_Union_Completion (Priv_Decls); 1669 end if; 1670 1671 if Ekind (Id) = E_Generic_Package 1672 and then Nkind (Orig_Decl) = N_Generic_Package_Declaration 1673 and then Present (Priv_Decls) 1674 then 1675 -- Save global references in private declarations, ignoring the 1676 -- visible declarations that were processed earlier. 1677 1678 declare 1679 Orig_Spec : constant Node_Id := Specification (Orig_Decl); 1680 Save_Vis : constant List_Id := Visible_Declarations (Orig_Spec); 1681 Save_Form : constant List_Id := 1682 Generic_Formal_Declarations (Orig_Decl); 1683 1684 begin 1685 Set_Visible_Declarations (Orig_Spec, Empty_List); 1686 Set_Generic_Formal_Declarations (Orig_Decl, Empty_List); 1687 Save_Global_References (Orig_Decl); 1688 Set_Generic_Formal_Declarations (Orig_Decl, Save_Form); 1689 Set_Visible_Declarations (Orig_Spec, Save_Vis); 1690 end; 1691 end if; 1692 1693 Process_End_Label (N, 'e', Id); 1694 1695 -- Remove private_with_clauses of enclosing compilation unit, if they 1696 -- were installed. 1697 1698 if Private_With_Clauses_Installed then 1699 Remove_Private_With_Clauses (Cunit (Current_Sem_Unit)); 1700 end if; 1701 1702 -- For the case of a library level package, we must go through all the 1703 -- entities clearing the indications that the value may be constant and 1704 -- not modified. Why? Because any client of this package may modify 1705 -- these values freely from anywhere. This also applies to any nested 1706 -- packages or generic packages. 1707 1708 -- For now we unconditionally clear constants for packages that are 1709 -- instances of generic packages. The reason is that we do not have the 1710 -- body yet, and we otherwise think things are unreferenced when they 1711 -- are not. This should be fixed sometime (the effect is not terrible, 1712 -- we just lose some warnings, and also some cases of value propagation) 1713 -- ??? 1714 1715 if Is_Library_Level_Entity (Id) 1716 or else Is_Generic_Instance (Id) 1717 then 1718 Clear_Constants (Id, First_Entity (Id)); 1719 Clear_Constants (Id, First_Private_Entity (Id)); 1720 end if; 1721 1722 -- Issue an error in SPARK mode if a package specification contains 1723 -- more than one tagged type or type extension. 1724 1725 Check_One_Tagged_Type_Or_Extension_At_Most; 1726 1727 -- If switch set, output information on why body required 1728 1729 if List_Body_Required_Info 1730 and then In_Extended_Main_Source_Unit (Id) 1731 and then Unit_Requires_Body (Id) 1732 then 1733 Unit_Requires_Body_Info (Id); 1734 end if; 1735 end Analyze_Package_Specification; 1736 1737 -------------------------------------- 1738 -- Analyze_Private_Type_Declaration -- 1739 -------------------------------------- 1740 1741 procedure Analyze_Private_Type_Declaration (N : Node_Id) is 1742 Id : constant Entity_Id := Defining_Identifier (N); 1743 PF : constant Boolean := Is_Pure (Enclosing_Lib_Unit_Entity); 1744 1745 begin 1746 Generate_Definition (Id); 1747 Set_Is_Pure (Id, PF); 1748 Init_Size_Align (Id); 1749 1750 if not Is_Package_Or_Generic_Package (Current_Scope) 1751 or else In_Private_Part (Current_Scope) 1752 then 1753 Error_Msg_N ("invalid context for private declaration", N); 1754 end if; 1755 1756 New_Private_Type (N, Id, N); 1757 Set_Depends_On_Private (Id); 1758 1759 -- A type declared within a Ghost region is automatically Ghost 1760 -- (SPARK RM 6.9(2)). 1761 1762 if Ghost_Mode > None then 1763 Set_Is_Ghost_Entity (Id); 1764 end if; 1765 1766 if Has_Aspects (N) then 1767 Analyze_Aspect_Specifications (N, Id); 1768 end if; 1769 end Analyze_Private_Type_Declaration; 1770 1771 ---------------------------------- 1772 -- Check_Anonymous_Access_Types -- 1773 ---------------------------------- 1774 1775 procedure Check_Anonymous_Access_Types 1776 (Spec_Id : Entity_Id; 1777 P_Body : Node_Id) 1778 is 1779 E : Entity_Id; 1780 IR : Node_Id; 1781 1782 begin 1783 -- Itype references are only needed by gigi, to force elaboration of 1784 -- itypes. In the absence of code generation, they are not needed. 1785 1786 if not Expander_Active then 1787 return; 1788 end if; 1789 1790 E := First_Entity (Spec_Id); 1791 while Present (E) loop 1792 if Ekind (E) = E_Anonymous_Access_Type 1793 and then From_Limited_With (E) 1794 then 1795 IR := Make_Itype_Reference (Sloc (P_Body)); 1796 Set_Itype (IR, E); 1797 1798 if No (Declarations (P_Body)) then 1799 Set_Declarations (P_Body, New_List (IR)); 1800 else 1801 Prepend (IR, Declarations (P_Body)); 1802 end if; 1803 end if; 1804 1805 Next_Entity (E); 1806 end loop; 1807 end Check_Anonymous_Access_Types; 1808 1809 ------------------------------------------- 1810 -- Declare_Inherited_Private_Subprograms -- 1811 ------------------------------------------- 1812 1813 procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is 1814 1815 function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean; 1816 -- Check whether an inherited subprogram S is an operation of an 1817 -- untagged derived type T. 1818 1819 --------------------- 1820 -- Is_Primitive_Of -- 1821 --------------------- 1822 1823 function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean is 1824 Formal : Entity_Id; 1825 1826 begin 1827 -- If the full view is a scalar type, the type is the anonymous base 1828 -- type, but the operation mentions the first subtype, so check the 1829 -- signature against the base type. 1830 1831 if Base_Type (Etype (S)) = Base_Type (T) then 1832 return True; 1833 1834 else 1835 Formal := First_Formal (S); 1836 while Present (Formal) loop 1837 if Base_Type (Etype (Formal)) = Base_Type (T) then 1838 return True; 1839 end if; 1840 1841 Next_Formal (Formal); 1842 end loop; 1843 1844 return False; 1845 end if; 1846 end Is_Primitive_Of; 1847 1848 -- Local variables 1849 1850 E : Entity_Id; 1851 Op_List : Elist_Id; 1852 Op_Elmt : Elmt_Id; 1853 Op_Elmt_2 : Elmt_Id; 1854 Prim_Op : Entity_Id; 1855 New_Op : Entity_Id := Empty; 1856 Parent_Subp : Entity_Id; 1857 Tag : Entity_Id; 1858 1859 -- Start of processing for Declare_Inherited_Private_Subprograms 1860 1861 begin 1862 E := First_Entity (Id); 1863 while Present (E) loop 1864 1865 -- If the entity is a nonprivate type extension whose parent type 1866 -- is declared in an open scope, then the type may have inherited 1867 -- operations that now need to be made visible. Ditto if the entity 1868 -- is a formal derived type in a child unit. 1869 1870 if ((Is_Derived_Type (E) and then not Is_Private_Type (E)) 1871 or else 1872 (Nkind (Parent (E)) = N_Private_Extension_Declaration 1873 and then Is_Generic_Type (E))) 1874 and then In_Open_Scopes (Scope (Etype (E))) 1875 and then Is_Base_Type (E) 1876 then 1877 if Is_Tagged_Type (E) then 1878 Op_List := Primitive_Operations (E); 1879 New_Op := Empty; 1880 Tag := First_Tag_Component (E); 1881 1882 Op_Elmt := First_Elmt (Op_List); 1883 while Present (Op_Elmt) loop 1884 Prim_Op := Node (Op_Elmt); 1885 1886 -- Search primitives that are implicit operations with an 1887 -- internal name whose parent operation has a normal name. 1888 1889 if Present (Alias (Prim_Op)) 1890 and then Find_Dispatching_Type (Alias (Prim_Op)) /= E 1891 and then not Comes_From_Source (Prim_Op) 1892 and then Is_Internal_Name (Chars (Prim_Op)) 1893 and then not Is_Internal_Name (Chars (Alias (Prim_Op))) 1894 then 1895 Parent_Subp := Alias (Prim_Op); 1896 1897 -- Case 1: Check if the type has also an explicit 1898 -- overriding for this primitive. 1899 1900 Op_Elmt_2 := Next_Elmt (Op_Elmt); 1901 while Present (Op_Elmt_2) loop 1902 1903 -- Skip entities with attribute Interface_Alias since 1904 -- they are not overriding primitives (these entities 1905 -- link an interface primitive with their covering 1906 -- primitive) 1907 1908 if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp) 1909 and then Type_Conformant (Prim_Op, Node (Op_Elmt_2)) 1910 and then No (Interface_Alias (Node (Op_Elmt_2))) 1911 then 1912 -- The private inherited operation has been 1913 -- overridden by an explicit subprogram: 1914 -- replace the former by the latter. 1915 1916 New_Op := Node (Op_Elmt_2); 1917 Replace_Elmt (Op_Elmt, New_Op); 1918 Remove_Elmt (Op_List, Op_Elmt_2); 1919 Set_Overridden_Operation (New_Op, Parent_Subp); 1920 1921 -- We don't need to inherit its dispatching slot. 1922 -- Set_All_DT_Position has previously ensured that 1923 -- the same slot was assigned to the two primitives 1924 1925 if Present (Tag) 1926 and then Present (DTC_Entity (New_Op)) 1927 and then Present (DTC_Entity (Prim_Op)) 1928 then 1929 pragma Assert 1930 (DT_Position (New_Op) = DT_Position (Prim_Op)); 1931 null; 1932 end if; 1933 1934 goto Next_Primitive; 1935 end if; 1936 1937 Next_Elmt (Op_Elmt_2); 1938 end loop; 1939 1940 -- Case 2: We have not found any explicit overriding and 1941 -- hence we need to declare the operation (i.e., make it 1942 -- visible). 1943 1944 Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E)); 1945 1946 -- Inherit the dispatching slot if E is already frozen 1947 1948 if Is_Frozen (E) 1949 and then Present (DTC_Entity (Alias (Prim_Op))) 1950 then 1951 Set_DTC_Entity_Value (E, New_Op); 1952 Set_DT_Position_Value (New_Op, 1953 DT_Position (Alias (Prim_Op))); 1954 end if; 1955 1956 pragma Assert 1957 (Is_Dispatching_Operation (New_Op) 1958 and then Node (Last_Elmt (Op_List)) = New_Op); 1959 1960 -- Substitute the new operation for the old one in the 1961 -- type's primitive operations list. Since the new 1962 -- operation was also just added to the end of list, 1963 -- the last element must be removed. 1964 1965 -- (Question: is there a simpler way of declaring the 1966 -- operation, say by just replacing the name of the 1967 -- earlier operation, reentering it in the in the symbol 1968 -- table (how?), and marking it as private???) 1969 1970 Replace_Elmt (Op_Elmt, New_Op); 1971 Remove_Last_Elmt (Op_List); 1972 end if; 1973 1974 <<Next_Primitive>> 1975 Next_Elmt (Op_Elmt); 1976 end loop; 1977 1978 -- Generate listing showing the contents of the dispatch table 1979 1980 if Debug_Flag_ZZ then 1981 Write_DT (E); 1982 end if; 1983 1984 else 1985 -- For untagged type, scan forward to locate inherited hidden 1986 -- operations. 1987 1988 Prim_Op := Next_Entity (E); 1989 while Present (Prim_Op) loop 1990 if Is_Subprogram (Prim_Op) 1991 and then Present (Alias (Prim_Op)) 1992 and then not Comes_From_Source (Prim_Op) 1993 and then Is_Internal_Name (Chars (Prim_Op)) 1994 and then not Is_Internal_Name (Chars (Alias (Prim_Op))) 1995 and then Is_Primitive_Of (E, Prim_Op) 1996 then 1997 Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E)); 1998 end if; 1999 2000 Next_Entity (Prim_Op); 2001 2002 -- Derived operations appear immediately after the type 2003 -- declaration (or the following subtype indication for 2004 -- a derived scalar type). Further declarations cannot 2005 -- include inherited operations of the type. 2006 2007 if Present (Prim_Op) then 2008 exit when Ekind (Prim_Op) not in Overloadable_Kind; 2009 end if; 2010 end loop; 2011 end if; 2012 end if; 2013 2014 Next_Entity (E); 2015 end loop; 2016 end Declare_Inherited_Private_Subprograms; 2017 2018 ----------------------- 2019 -- End_Package_Scope -- 2020 ----------------------- 2021 2022 procedure End_Package_Scope (P : Entity_Id) is 2023 begin 2024 Uninstall_Declarations (P); 2025 Pop_Scope; 2026 end End_Package_Scope; 2027 2028 --------------------------- 2029 -- Exchange_Declarations -- 2030 --------------------------- 2031 2032 procedure Exchange_Declarations (Id : Entity_Id) is 2033 Full_Id : constant Entity_Id := Full_View (Id); 2034 H1 : constant Entity_Id := Homonym (Id); 2035 Next1 : constant Entity_Id := Next_Entity (Id); 2036 H2 : Entity_Id; 2037 Next2 : Entity_Id; 2038 2039 begin 2040 -- If missing full declaration for type, nothing to exchange 2041 2042 if No (Full_Id) then 2043 return; 2044 end if; 2045 2046 -- Otherwise complete the exchange, and preserve semantic links 2047 2048 Next2 := Next_Entity (Full_Id); 2049 H2 := Homonym (Full_Id); 2050 2051 -- Reset full declaration pointer to reflect the switched entities and 2052 -- readjust the next entity chains. 2053 2054 Exchange_Entities (Id, Full_Id); 2055 2056 Set_Next_Entity (Id, Next1); 2057 Set_Homonym (Id, H1); 2058 2059 Set_Full_View (Full_Id, Id); 2060 Set_Next_Entity (Full_Id, Next2); 2061 Set_Homonym (Full_Id, H2); 2062 end Exchange_Declarations; 2063 2064 ---------------------------- 2065 -- Install_Package_Entity -- 2066 ---------------------------- 2067 2068 procedure Install_Package_Entity (Id : Entity_Id) is 2069 begin 2070 if not Is_Internal (Id) then 2071 if Debug_Flag_E then 2072 Write_Str ("Install: "); 2073 Write_Name (Chars (Id)); 2074 Write_Eol; 2075 end if; 2076 2077 if Is_Child_Unit (Id) then 2078 null; 2079 2080 -- Do not enter implicitly inherited non-overridden subprograms of 2081 -- a tagged type back into visibility if they have non-conformant 2082 -- homographs (Ada RM 8.3 12.3/2). 2083 2084 elsif Is_Hidden_Non_Overridden_Subpgm (Id) then 2085 null; 2086 2087 else 2088 Set_Is_Immediately_Visible (Id); 2089 end if; 2090 end if; 2091 end Install_Package_Entity; 2092 2093 ---------------------------------- 2094 -- Install_Private_Declarations -- 2095 ---------------------------------- 2096 2097 procedure Install_Private_Declarations (P : Entity_Id) is 2098 Id : Entity_Id; 2099 Full : Entity_Id; 2100 Priv_Deps : Elist_Id; 2101 2102 procedure Swap_Private_Dependents (Priv_Deps : Elist_Id); 2103 -- When the full view of a private type is made available, we do the 2104 -- same for its private dependents under proper visibility conditions. 2105 -- When compiling a grand-chid unit this needs to be done recursively. 2106 2107 ----------------------------- 2108 -- Swap_Private_Dependents -- 2109 ----------------------------- 2110 2111 procedure Swap_Private_Dependents (Priv_Deps : Elist_Id) is 2112 Deps : Elist_Id; 2113 Priv : Entity_Id; 2114 Priv_Elmt : Elmt_Id; 2115 Is_Priv : Boolean; 2116 2117 begin 2118 Priv_Elmt := First_Elmt (Priv_Deps); 2119 while Present (Priv_Elmt) loop 2120 Priv := Node (Priv_Elmt); 2121 2122 -- Before the exchange, verify that the presence of the Full_View 2123 -- field. This field will be empty if the entity has already been 2124 -- installed due to a previous call. 2125 2126 if Present (Full_View (Priv)) and then Is_Visible_Dependent (Priv) 2127 then 2128 if Is_Private_Type (Priv) then 2129 Deps := Private_Dependents (Priv); 2130 Is_Priv := True; 2131 else 2132 Is_Priv := False; 2133 end if; 2134 2135 -- For each subtype that is swapped, we also swap the reference 2136 -- to it in Private_Dependents, to allow access to it when we 2137 -- swap them out in End_Package_Scope. 2138 2139 Replace_Elmt (Priv_Elmt, Full_View (Priv)); 2140 2141 -- Ensure that both views of the dependent private subtype are 2142 -- immediately visible if within some open scope. Check full 2143 -- view before exchanging views. 2144 2145 if In_Open_Scopes (Scope (Full_View (Priv))) then 2146 Set_Is_Immediately_Visible (Priv); 2147 end if; 2148 2149 Exchange_Declarations (Priv); 2150 Set_Is_Immediately_Visible 2151 (Priv, In_Open_Scopes (Scope (Priv))); 2152 2153 Set_Is_Potentially_Use_Visible 2154 (Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt))); 2155 2156 -- Within a child unit, recurse, except in generic child unit, 2157 -- which (unfortunately) handle private_dependents separately. 2158 2159 if Is_Priv 2160 and then Is_Child_Unit (Cunit_Entity (Current_Sem_Unit)) 2161 and then not Is_Empty_Elmt_List (Deps) 2162 and then not Inside_A_Generic 2163 then 2164 Swap_Private_Dependents (Deps); 2165 end if; 2166 end if; 2167 2168 Next_Elmt (Priv_Elmt); 2169 end loop; 2170 end Swap_Private_Dependents; 2171 2172 -- Start of processing for Install_Private_Declarations 2173 2174 begin 2175 -- First exchange declarations for private types, so that the full 2176 -- declaration is visible. For each private type, we check its 2177 -- Private_Dependents list and also exchange any subtypes of or derived 2178 -- types from it. Finally, if this is a Taft amendment type, the 2179 -- incomplete declaration is irrelevant, and we want to link the 2180 -- eventual full declaration with the original private one so we 2181 -- also skip the exchange. 2182 2183 Id := First_Entity (P); 2184 while Present (Id) and then Id /= First_Private_Entity (P) loop 2185 if Is_Private_Base_Type (Id) 2186 and then Present (Full_View (Id)) 2187 and then Comes_From_Source (Full_View (Id)) 2188 and then Scope (Full_View (Id)) = Scope (Id) 2189 and then Ekind (Full_View (Id)) /= E_Incomplete_Type 2190 then 2191 -- If there is a use-type clause on the private type, set the full 2192 -- view accordingly. 2193 2194 Set_In_Use (Full_View (Id), In_Use (Id)); 2195 Full := Full_View (Id); 2196 2197 if Is_Private_Base_Type (Full) 2198 and then Has_Private_Declaration (Full) 2199 and then Nkind (Parent (Full)) = N_Full_Type_Declaration 2200 and then In_Open_Scopes (Scope (Etype (Full))) 2201 and then In_Package_Body (Current_Scope) 2202 and then not Is_Private_Type (Etype (Full)) 2203 then 2204 -- This is the completion of a private type by a derivation 2205 -- from another private type which is not private anymore. This 2206 -- can only happen in a package nested within a child package, 2207 -- when the parent type is defined in the parent unit. At this 2208 -- point the current type is not private either, and we have 2209 -- to install the underlying full view, which is now visible. 2210 -- Save the current full view as well, so that all views can be 2211 -- restored on exit. It may seem that after compiling the child 2212 -- body there are not environments to restore, but the back-end 2213 -- expects those links to be valid, and freeze nodes depend on 2214 -- them. 2215 2216 if No (Full_View (Full)) 2217 and then Present (Underlying_Full_View (Full)) 2218 then 2219 Set_Full_View (Id, Underlying_Full_View (Full)); 2220 Set_Underlying_Full_View (Id, Full); 2221 2222 Set_Underlying_Full_View (Full, Empty); 2223 Set_Is_Frozen (Full_View (Id)); 2224 end if; 2225 end if; 2226 2227 Priv_Deps := Private_Dependents (Id); 2228 Exchange_Declarations (Id); 2229 Set_Is_Immediately_Visible (Id); 2230 Swap_Private_Dependents (Priv_Deps); 2231 end if; 2232 2233 Next_Entity (Id); 2234 end loop; 2235 2236 -- Next make other declarations in the private part visible as well 2237 2238 Id := First_Private_Entity (P); 2239 while Present (Id) loop 2240 Install_Package_Entity (Id); 2241 Set_Is_Hidden (Id, False); 2242 Next_Entity (Id); 2243 end loop; 2244 2245 -- Indicate that the private part is currently visible, so it can be 2246 -- properly reset on exit. 2247 2248 Set_In_Private_Part (P); 2249 end Install_Private_Declarations; 2250 2251 ---------------------------------- 2252 -- Install_Visible_Declarations -- 2253 ---------------------------------- 2254 2255 procedure Install_Visible_Declarations (P : Entity_Id) is 2256 Id : Entity_Id; 2257 Last_Entity : Entity_Id; 2258 2259 begin 2260 pragma Assert 2261 (Is_Package_Or_Generic_Package (P) or else Is_Record_Type (P)); 2262 2263 if Is_Package_Or_Generic_Package (P) then 2264 Last_Entity := First_Private_Entity (P); 2265 else 2266 Last_Entity := Empty; 2267 end if; 2268 2269 Id := First_Entity (P); 2270 while Present (Id) and then Id /= Last_Entity loop 2271 Install_Package_Entity (Id); 2272 Next_Entity (Id); 2273 end loop; 2274 end Install_Visible_Declarations; 2275 2276 -------------------------- 2277 -- Is_Private_Base_Type -- 2278 -------------------------- 2279 2280 function Is_Private_Base_Type (E : Entity_Id) return Boolean is 2281 begin 2282 return Ekind (E) = E_Private_Type 2283 or else Ekind (E) = E_Limited_Private_Type 2284 or else Ekind (E) = E_Record_Type_With_Private; 2285 end Is_Private_Base_Type; 2286 2287 -------------------------- 2288 -- Is_Visible_Dependent -- 2289 -------------------------- 2290 2291 function Is_Visible_Dependent (Dep : Entity_Id) return Boolean 2292 is 2293 S : constant Entity_Id := Scope (Dep); 2294 2295 begin 2296 -- Renamings created for actual types have the visibility of the actual 2297 2298 if Ekind (S) = E_Package 2299 and then Is_Generic_Instance (S) 2300 and then (Is_Generic_Actual_Type (Dep) 2301 or else Is_Generic_Actual_Type (Full_View (Dep))) 2302 then 2303 return True; 2304 2305 elsif not (Is_Derived_Type (Dep)) 2306 and then Is_Derived_Type (Full_View (Dep)) 2307 then 2308 -- When instantiating a package body, the scope stack is empty, so 2309 -- check instead whether the dependent type is defined in the same 2310 -- scope as the instance itself. 2311 2312 return In_Open_Scopes (S) 2313 or else (Is_Generic_Instance (Current_Scope) 2314 and then Scope (Dep) = Scope (Current_Scope)); 2315 else 2316 return True; 2317 end if; 2318 end Is_Visible_Dependent; 2319 2320 ---------------------------- 2321 -- May_Need_Implicit_Body -- 2322 ---------------------------- 2323 2324 procedure May_Need_Implicit_Body (E : Entity_Id) is 2325 P : constant Node_Id := Unit_Declaration_Node (E); 2326 S : constant Node_Id := Parent (P); 2327 B : Node_Id; 2328 Decls : List_Id; 2329 2330 begin 2331 if not Has_Completion (E) 2332 and then Nkind (P) = N_Package_Declaration 2333 and then (Present (Activation_Chain_Entity (P)) or else Has_RACW (E)) 2334 then 2335 B := 2336 Make_Package_Body (Sloc (E), 2337 Defining_Unit_Name => Make_Defining_Identifier (Sloc (E), 2338 Chars => Chars (E)), 2339 Declarations => New_List); 2340 2341 if Nkind (S) = N_Package_Specification then 2342 if Present (Private_Declarations (S)) then 2343 Decls := Private_Declarations (S); 2344 else 2345 Decls := Visible_Declarations (S); 2346 end if; 2347 else 2348 Decls := Declarations (S); 2349 end if; 2350 2351 Append (B, Decls); 2352 Analyze (B); 2353 end if; 2354 end May_Need_Implicit_Body; 2355 2356 ---------------------- 2357 -- New_Private_Type -- 2358 ---------------------- 2359 2360 procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id) is 2361 begin 2362 -- For other than Ada 2012, enter the name in the current scope 2363 2364 if Ada_Version < Ada_2012 then 2365 Enter_Name (Id); 2366 2367 -- Ada 2012 (AI05-0162): Enter the name in the current scope. Note that 2368 -- there may be an incomplete previous view. 2369 2370 else 2371 declare 2372 Prev : Entity_Id; 2373 begin 2374 Prev := Find_Type_Name (N); 2375 pragma Assert (Prev = Id 2376 or else (Ekind (Prev) = E_Incomplete_Type 2377 and then Present (Full_View (Prev)) 2378 and then Full_View (Prev) = Id)); 2379 end; 2380 end if; 2381 2382 if Limited_Present (Def) then 2383 Set_Ekind (Id, E_Limited_Private_Type); 2384 else 2385 Set_Ekind (Id, E_Private_Type); 2386 end if; 2387 2388 Set_Etype (Id, Id); 2389 Set_Has_Delayed_Freeze (Id); 2390 Set_Is_First_Subtype (Id); 2391 Init_Size_Align (Id); 2392 2393 Set_Is_Constrained (Id, 2394 No (Discriminant_Specifications (N)) 2395 and then not Unknown_Discriminants_Present (N)); 2396 2397 -- Set tagged flag before processing discriminants, to catch illegal 2398 -- usage. 2399 2400 Set_Is_Tagged_Type (Id, Tagged_Present (Def)); 2401 2402 Set_Discriminant_Constraint (Id, No_Elist); 2403 Set_Stored_Constraint (Id, No_Elist); 2404 2405 if Present (Discriminant_Specifications (N)) then 2406 Push_Scope (Id); 2407 Process_Discriminants (N); 2408 End_Scope; 2409 2410 elsif Unknown_Discriminants_Present (N) then 2411 Set_Has_Unknown_Discriminants (Id); 2412 end if; 2413 2414 Set_Private_Dependents (Id, New_Elmt_List); 2415 2416 if Tagged_Present (Def) then 2417 Set_Ekind (Id, E_Record_Type_With_Private); 2418 Set_Direct_Primitive_Operations (Id, New_Elmt_List); 2419 Set_Is_Abstract_Type (Id, Abstract_Present (Def)); 2420 Set_Is_Limited_Record (Id, Limited_Present (Def)); 2421 Set_Has_Delayed_Freeze (Id, True); 2422 2423 -- Create a class-wide type with the same attributes 2424 2425 Make_Class_Wide_Type (Id); 2426 2427 elsif Abstract_Present (Def) then 2428 Error_Msg_N ("only a tagged type can be abstract", N); 2429 end if; 2430 end New_Private_Type; 2431 2432 --------------------------------- 2433 -- Requires_Completion_In_Body -- 2434 --------------------------------- 2435 2436 function Requires_Completion_In_Body 2437 (Id : Entity_Id; 2438 Pack_Id : Entity_Id) return Boolean 2439 is 2440 begin 2441 -- Always ignore child units. Child units get added to the entity list 2442 -- of a parent unit, but are not original entities of the parent, and 2443 -- so do not affect whether the parent needs a body. 2444 2445 if Is_Child_Unit (Id) then 2446 return False; 2447 2448 -- Ignore formal packages and their renamings 2449 2450 elsif Ekind (Id) = E_Package 2451 and then Nkind (Original_Node (Unit_Declaration_Node (Id))) = 2452 N_Formal_Package_Declaration 2453 then 2454 return False; 2455 2456 -- Otherwise test to see if entity requires a completion. Note that 2457 -- subprogram entities whose declaration does not come from source are 2458 -- ignored here on the basis that we assume the expander will provide an 2459 -- implicit completion at some point. 2460 2461 elsif (Is_Overloadable (Id) 2462 and then Ekind (Id) /= E_Enumeration_Literal 2463 and then Ekind (Id) /= E_Operator 2464 and then not Is_Abstract_Subprogram (Id) 2465 and then not Has_Completion (Id) 2466 and then Comes_From_Source (Parent (Id))) 2467 2468 or else 2469 (Ekind (Id) = E_Package 2470 and then Id /= Pack_Id 2471 and then not Has_Completion (Id) 2472 and then Unit_Requires_Body (Id)) 2473 2474 or else 2475 (Ekind (Id) = E_Incomplete_Type 2476 and then No (Full_View (Id)) 2477 and then not Is_Generic_Type (Id)) 2478 2479 or else 2480 (Ekind_In (Id, E_Task_Type, E_Protected_Type) 2481 and then not Has_Completion (Id)) 2482 2483 or else 2484 (Ekind (Id) = E_Generic_Package 2485 and then Id /= Pack_Id 2486 and then not Has_Completion (Id) 2487 and then Unit_Requires_Body (Id)) 2488 2489 or else 2490 (Is_Generic_Subprogram (Id) 2491 and then not Has_Completion (Id)) 2492 2493 then 2494 return True; 2495 2496 -- Otherwise the entity does not require completion in a package body 2497 2498 else 2499 return False; 2500 end if; 2501 end Requires_Completion_In_Body; 2502 2503 ---------------------------- 2504 -- Uninstall_Declarations -- 2505 ---------------------------- 2506 2507 procedure Uninstall_Declarations (P : Entity_Id) is 2508 Decl : constant Node_Id := Unit_Declaration_Node (P); 2509 Id : Entity_Id; 2510 Full : Entity_Id; 2511 Priv_Elmt : Elmt_Id; 2512 Priv_Sub : Entity_Id; 2513 2514 procedure Preserve_Full_Attributes (Priv, Full : Entity_Id); 2515 -- Copy to the private declaration the attributes of the full view that 2516 -- need to be available for the partial view also. 2517 2518 function Type_In_Use (T : Entity_Id) return Boolean; 2519 -- Check whether type or base type appear in an active use_type clause 2520 2521 ------------------------------ 2522 -- Preserve_Full_Attributes -- 2523 ------------------------------ 2524 2525 procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is 2526 Priv_Is_Base_Type : constant Boolean := Is_Base_Type (Priv); 2527 2528 begin 2529 Set_Size_Info (Priv, (Full)); 2530 Set_RM_Size (Priv, RM_Size (Full)); 2531 Set_Size_Known_At_Compile_Time 2532 (Priv, Size_Known_At_Compile_Time (Full)); 2533 Set_Is_Volatile (Priv, Is_Volatile (Full)); 2534 Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full)); 2535 Set_Is_Ada_2005_Only (Priv, Is_Ada_2005_Only (Full)); 2536 Set_Is_Ada_2012_Only (Priv, Is_Ada_2012_Only (Full)); 2537 Set_Has_Pragma_Unmodified (Priv, Has_Pragma_Unmodified (Full)); 2538 Set_Has_Pragma_Unreferenced (Priv, Has_Pragma_Unreferenced (Full)); 2539 Set_Has_Pragma_Unreferenced_Objects 2540 (Priv, Has_Pragma_Unreferenced_Objects 2541 (Full)); 2542 if Is_Unchecked_Union (Full) then 2543 Set_Is_Unchecked_Union (Base_Type (Priv)); 2544 end if; 2545 -- Why is atomic not copied here ??? 2546 2547 if Referenced (Full) then 2548 Set_Referenced (Priv); 2549 end if; 2550 2551 if Priv_Is_Base_Type then 2552 Set_Is_Controlled (Priv, Is_Controlled (Base_Type (Full))); 2553 Set_Finalize_Storage_Only 2554 (Priv, Finalize_Storage_Only 2555 (Base_Type (Full))); 2556 Set_Has_Task (Priv, Has_Task (Base_Type (Full))); 2557 Set_Has_Protected (Priv, Has_Protected (Base_Type (Full))); 2558 Set_Has_Controlled_Component 2559 (Priv, Has_Controlled_Component 2560 (Base_Type (Full))); 2561 end if; 2562 2563 Set_Freeze_Node (Priv, Freeze_Node (Full)); 2564 2565 -- Propagate information of type invariants, which may be specified 2566 -- for the full view. 2567 2568 if Has_Invariants (Full) and not Has_Invariants (Priv) then 2569 Set_Has_Invariants (Priv); 2570 Set_Subprograms_For_Type (Priv, Subprograms_For_Type (Full)); 2571 end if; 2572 2573 if Is_Tagged_Type (Priv) 2574 and then Is_Tagged_Type (Full) 2575 and then not Error_Posted (Full) 2576 then 2577 if Is_Tagged_Type (Priv) then 2578 2579 -- If the type is tagged, the tag itself must be available on 2580 -- the partial view, for expansion purposes. 2581 2582 Set_First_Entity (Priv, First_Entity (Full)); 2583 2584 -- If there are discriminants in the partial view, these remain 2585 -- visible. Otherwise only the tag itself is visible, and there 2586 -- are no nameable components in the partial view. 2587 2588 if No (Last_Entity (Priv)) then 2589 Set_Last_Entity (Priv, First_Entity (Priv)); 2590 end if; 2591 end if; 2592 2593 Set_Has_Discriminants (Priv, Has_Discriminants (Full)); 2594 2595 if Has_Discriminants (Full) then 2596 Set_Discriminant_Constraint (Priv, 2597 Discriminant_Constraint (Full)); 2598 end if; 2599 end if; 2600 end Preserve_Full_Attributes; 2601 2602 ----------------- 2603 -- Type_In_Use -- 2604 ----------------- 2605 2606 function Type_In_Use (T : Entity_Id) return Boolean is 2607 begin 2608 return Scope (Base_Type (T)) = P 2609 and then (In_Use (T) or else In_Use (Base_Type (T))); 2610 end Type_In_Use; 2611 2612 -- Start of processing for Uninstall_Declarations 2613 2614 begin 2615 Id := First_Entity (P); 2616 while Present (Id) and then Id /= First_Private_Entity (P) loop 2617 if Debug_Flag_E then 2618 Write_Str ("unlinking visible entity "); 2619 Write_Int (Int (Id)); 2620 Write_Eol; 2621 end if; 2622 2623 -- On exit from the package scope, we must preserve the visibility 2624 -- established by use clauses in the current scope. Two cases: 2625 2626 -- a) If the entity is an operator, it may be a primitive operator of 2627 -- a type for which there is a visible use-type clause. 2628 2629 -- b) for other entities, their use-visibility is determined by a 2630 -- visible use clause for the package itself. For a generic instance, 2631 -- the instantiation of the formals appears in the visible part, 2632 -- but the formals are private and remain so. 2633 2634 if Ekind (Id) = E_Function 2635 and then Is_Operator_Symbol_Name (Chars (Id)) 2636 and then not Is_Hidden (Id) 2637 and then not Error_Posted (Id) 2638 then 2639 Set_Is_Potentially_Use_Visible (Id, 2640 In_Use (P) 2641 or else Type_In_Use (Etype (Id)) 2642 or else Type_In_Use (Etype (First_Formal (Id))) 2643 or else (Present (Next_Formal (First_Formal (Id))) 2644 and then 2645 Type_In_Use 2646 (Etype (Next_Formal (First_Formal (Id)))))); 2647 else 2648 if In_Use (P) and then not Is_Hidden (Id) then 2649 2650 -- A child unit of a use-visible package remains use-visible 2651 -- only if it is itself a visible child unit. Otherwise it 2652 -- would remain visible in other contexts where P is use- 2653 -- visible, because once compiled it stays in the entity list 2654 -- of its parent unit. 2655 2656 if Is_Child_Unit (Id) then 2657 Set_Is_Potentially_Use_Visible 2658 (Id, Is_Visible_Lib_Unit (Id)); 2659 else 2660 Set_Is_Potentially_Use_Visible (Id); 2661 end if; 2662 2663 else 2664 Set_Is_Potentially_Use_Visible (Id, False); 2665 end if; 2666 end if; 2667 2668 -- Local entities are not immediately visible outside of the package 2669 2670 Set_Is_Immediately_Visible (Id, False); 2671 2672 -- If this is a private type with a full view (for example a local 2673 -- subtype of a private type declared elsewhere), ensure that the 2674 -- full view is also removed from visibility: it may be exposed when 2675 -- swapping views in an instantiation. Similarly, ensure that the 2676 -- use-visibility is properly set on both views. 2677 2678 if Is_Type (Id) and then Present (Full_View (Id)) then 2679 Set_Is_Immediately_Visible (Full_View (Id), False); 2680 Set_Is_Potentially_Use_Visible (Full_View (Id), 2681 Is_Potentially_Use_Visible (Id)); 2682 end if; 2683 2684 if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then 2685 Check_Abstract_Overriding (Id); 2686 Check_Conventions (Id); 2687 end if; 2688 2689 if Ekind_In (Id, E_Private_Type, E_Limited_Private_Type) 2690 and then No (Full_View (Id)) 2691 and then not Is_Generic_Type (Id) 2692 and then not Is_Derived_Type (Id) 2693 then 2694 Error_Msg_N ("missing full declaration for private type&", Id); 2695 2696 elsif Ekind (Id) = E_Record_Type_With_Private 2697 and then not Is_Generic_Type (Id) 2698 and then No (Full_View (Id)) 2699 then 2700 if Nkind (Parent (Id)) = N_Private_Type_Declaration then 2701 Error_Msg_N ("missing full declaration for private type&", Id); 2702 else 2703 Error_Msg_N 2704 ("missing full declaration for private extension", Id); 2705 end if; 2706 2707 -- Case of constant, check for deferred constant declaration with 2708 -- no full view. Likely just a matter of a missing expression, or 2709 -- accidental use of the keyword constant. 2710 2711 elsif Ekind (Id) = E_Constant 2712 2713 -- OK if constant value present 2714 2715 and then No (Constant_Value (Id)) 2716 2717 -- OK if full view present 2718 2719 and then No (Full_View (Id)) 2720 2721 -- OK if imported, since that provides the completion 2722 2723 and then not Is_Imported (Id) 2724 2725 -- OK if object declaration replaced by renaming declaration as 2726 -- a result of OK_To_Rename processing (e.g. for concatenation) 2727 2728 and then Nkind (Parent (Id)) /= N_Object_Renaming_Declaration 2729 2730 -- OK if object declaration with the No_Initialization flag set 2731 2732 and then not (Nkind (Parent (Id)) = N_Object_Declaration 2733 and then No_Initialization (Parent (Id))) 2734 then 2735 -- If no private declaration is present, we assume the user did 2736 -- not intend a deferred constant declaration and the problem 2737 -- is simply that the initializing expression is missing. 2738 2739 if not Has_Private_Declaration (Etype (Id)) then 2740 2741 -- We assume that the user did not intend a deferred constant 2742 -- declaration, and the expression is just missing. 2743 2744 Error_Msg_N 2745 ("constant declaration requires initialization expression", 2746 Parent (Id)); 2747 2748 if Is_Limited_Type (Etype (Id)) then 2749 Error_Msg_N 2750 ("\if variable intended, remove CONSTANT from declaration", 2751 Parent (Id)); 2752 end if; 2753 2754 -- Otherwise if a private declaration is present, then we are 2755 -- missing the full declaration for the deferred constant. 2756 2757 else 2758 Error_Msg_N 2759 ("missing full declaration for deferred constant (RM 7.4)", 2760 Id); 2761 2762 if Is_Limited_Type (Etype (Id)) then 2763 Error_Msg_N 2764 ("\if variable intended, remove CONSTANT from declaration", 2765 Parent (Id)); 2766 end if; 2767 end if; 2768 end if; 2769 2770 Next_Entity (Id); 2771 end loop; 2772 2773 -- If the specification was installed as the parent of a public child 2774 -- unit, the private declarations were not installed, and there is 2775 -- nothing to do. 2776 2777 if not In_Private_Part (P) then 2778 return; 2779 else 2780 Set_In_Private_Part (P, False); 2781 end if; 2782 2783 -- Make private entities invisible and exchange full and private 2784 -- declarations for private types. Id is now the first private entity 2785 -- in the package. 2786 2787 while Present (Id) loop 2788 if Debug_Flag_E then 2789 Write_Str ("unlinking private entity "); 2790 Write_Int (Int (Id)); 2791 Write_Eol; 2792 end if; 2793 2794 if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then 2795 Check_Abstract_Overriding (Id); 2796 Check_Conventions (Id); 2797 end if; 2798 2799 Set_Is_Immediately_Visible (Id, False); 2800 2801 if Is_Private_Base_Type (Id) and then Present (Full_View (Id)) then 2802 Full := Full_View (Id); 2803 2804 -- If the partial view is not declared in the visible part of the 2805 -- package (as is the case when it is a type derived from some 2806 -- other private type in the private part of the current package), 2807 -- no exchange takes place. 2808 2809 if No (Parent (Id)) 2810 or else List_Containing (Parent (Id)) /= 2811 Visible_Declarations (Specification (Decl)) 2812 then 2813 goto Next_Id; 2814 end if; 2815 2816 -- The entry in the private part points to the full declaration, 2817 -- which is currently visible. Exchange them so only the private 2818 -- type declaration remains accessible, and link private and full 2819 -- declaration in the opposite direction. Before the actual 2820 -- exchange, we copy back attributes of the full view that must 2821 -- be available to the partial view too. 2822 2823 Preserve_Full_Attributes (Id, Full); 2824 2825 Set_Is_Potentially_Use_Visible (Id, In_Use (P)); 2826 2827 -- The following test may be redundant, as this is already 2828 -- diagnosed in sem_ch3. ??? 2829 2830 if not Is_Definite_Subtype (Full) 2831 and then Is_Definite_Subtype (Id) 2832 then 2833 Error_Msg_Sloc := Sloc (Parent (Id)); 2834 Error_Msg_NE 2835 ("full view of& not compatible with declaration#", Full, Id); 2836 end if; 2837 2838 -- Swap out the subtypes and derived types of Id that 2839 -- were compiled in this scope, or installed previously 2840 -- by Install_Private_Declarations. 2841 2842 -- Before we do the swap, we verify the presence of the Full_View 2843 -- field which may be empty due to a swap by a previous call to 2844 -- End_Package_Scope (e.g. from the freezing mechanism). 2845 2846 Priv_Elmt := First_Elmt (Private_Dependents (Id)); 2847 while Present (Priv_Elmt) loop 2848 Priv_Sub := Node (Priv_Elmt); 2849 2850 if Present (Full_View (Priv_Sub)) then 2851 if Scope (Priv_Sub) = P 2852 or else not In_Open_Scopes (Scope (Priv_Sub)) 2853 then 2854 Set_Is_Immediately_Visible (Priv_Sub, False); 2855 end if; 2856 2857 if Is_Visible_Dependent (Priv_Sub) then 2858 Preserve_Full_Attributes 2859 (Priv_Sub, Full_View (Priv_Sub)); 2860 Replace_Elmt (Priv_Elmt, Full_View (Priv_Sub)); 2861 Exchange_Declarations (Priv_Sub); 2862 end if; 2863 end if; 2864 2865 Next_Elmt (Priv_Elmt); 2866 end loop; 2867 2868 -- Now restore the type itself to its private view 2869 2870 Exchange_Declarations (Id); 2871 2872 -- If we have installed an underlying full view for a type derived 2873 -- from a private type in a child unit, restore the proper views 2874 -- of private and full view. See corresponding code in 2875 -- Install_Private_Declarations. 2876 2877 -- After the exchange, Full denotes the private type in the 2878 -- visible part of the package. 2879 2880 if Is_Private_Base_Type (Full) 2881 and then Present (Full_View (Full)) 2882 and then Present (Underlying_Full_View (Full)) 2883 and then In_Package_Body (Current_Scope) 2884 then 2885 Set_Full_View (Full, Underlying_Full_View (Full)); 2886 Set_Underlying_Full_View (Full, Empty); 2887 end if; 2888 2889 elsif Ekind (Id) = E_Incomplete_Type 2890 and then Comes_From_Source (Id) 2891 and then No (Full_View (Id)) 2892 then 2893 -- Mark Taft amendment types. Verify that there are no primitive 2894 -- operations declared for the type (3.10.1(9)). 2895 2896 Set_Has_Completion_In_Body (Id); 2897 2898 declare 2899 Elmt : Elmt_Id; 2900 Subp : Entity_Id; 2901 2902 begin 2903 Elmt := First_Elmt (Private_Dependents (Id)); 2904 while Present (Elmt) loop 2905 Subp := Node (Elmt); 2906 2907 -- Is_Primitive is tested because there can be cases where 2908 -- nonprimitive subprograms (in nested packages) are added 2909 -- to the Private_Dependents list. 2910 2911 if Is_Overloadable (Subp) and then Is_Primitive (Subp) then 2912 Error_Msg_NE 2913 ("type& must be completed in the private part", 2914 Parent (Subp), Id); 2915 2916 -- The result type of an access-to-function type cannot be a 2917 -- Taft-amendment type, unless the version is Ada 2012 or 2918 -- later (see AI05-151). 2919 2920 elsif Ada_Version < Ada_2012 2921 and then Ekind (Subp) = E_Subprogram_Type 2922 then 2923 if Etype (Subp) = Id 2924 or else 2925 (Is_Class_Wide_Type (Etype (Subp)) 2926 and then Etype (Etype (Subp)) = Id) 2927 then 2928 Error_Msg_NE 2929 ("type& must be completed in the private part", 2930 Associated_Node_For_Itype (Subp), Id); 2931 end if; 2932 end if; 2933 2934 Next_Elmt (Elmt); 2935 end loop; 2936 end; 2937 2938 elsif not Is_Child_Unit (Id) 2939 and then (not Is_Private_Type (Id) or else No (Full_View (Id))) 2940 then 2941 Set_Is_Hidden (Id); 2942 Set_Is_Potentially_Use_Visible (Id, False); 2943 end if; 2944 2945 <<Next_Id>> 2946 Next_Entity (Id); 2947 end loop; 2948 end Uninstall_Declarations; 2949 2950 ------------------------ 2951 -- Unit_Requires_Body -- 2952 ------------------------ 2953 2954 function Unit_Requires_Body 2955 (Pack_Id : Entity_Id; 2956 Ignore_Abstract_State : Boolean := False) return Boolean 2957 is 2958 E : Entity_Id; 2959 2960 begin 2961 -- Imported entity never requires body. Right now, only subprograms can 2962 -- be imported, but perhaps in the future we will allow import of 2963 -- packages. 2964 2965 if Is_Imported (Pack_Id) then 2966 return False; 2967 2968 -- Body required if library package with pragma Elaborate_Body 2969 2970 elsif Has_Pragma_Elaborate_Body (Pack_Id) then 2971 return True; 2972 2973 -- Body required if subprogram 2974 2975 elsif Is_Subprogram_Or_Generic_Subprogram (Pack_Id) then 2976 return True; 2977 2978 -- Treat a block as requiring a body 2979 2980 elsif Ekind (Pack_Id) = E_Block then 2981 return True; 2982 2983 elsif Ekind (Pack_Id) = E_Package 2984 and then Nkind (Parent (Pack_Id)) = N_Package_Specification 2985 and then Present (Generic_Parent (Parent (Pack_Id))) 2986 then 2987 declare 2988 G_P : constant Entity_Id := Generic_Parent (Parent (Pack_Id)); 2989 begin 2990 if Has_Pragma_Elaborate_Body (G_P) then 2991 return True; 2992 end if; 2993 end; 2994 2995 -- A [generic] package that introduces at least one non-null abstract 2996 -- state requires completion. However, there is a separate rule that 2997 -- requires that such a package have a reason other than this for a 2998 -- body being required (if necessary a pragma Elaborate_Body must be 2999 -- provided). If Ignore_Abstract_State is True, we don't do this check 3000 -- (so we can use Unit_Requires_Body to check for some other reason). 3001 3002 elsif Ekind_In (Pack_Id, E_Generic_Package, E_Package) 3003 and then not Ignore_Abstract_State 3004 and then Present (Abstract_States (Pack_Id)) 3005 and then not Is_Null_State 3006 (Node (First_Elmt (Abstract_States (Pack_Id)))) 3007 then 3008 return True; 3009 end if; 3010 3011 -- Otherwise search entity chain for entity requiring completion 3012 3013 E := First_Entity (Pack_Id); 3014 while Present (E) loop 3015 if Requires_Completion_In_Body (E, Pack_Id) then 3016 return True; 3017 end if; 3018 3019 Next_Entity (E); 3020 end loop; 3021 3022 return False; 3023 end Unit_Requires_Body; 3024 3025 ----------------------------- 3026 -- Unit_Requires_Body_Info -- 3027 ----------------------------- 3028 3029 procedure Unit_Requires_Body_Info (Pack_Id : Entity_Id) is 3030 E : Entity_Id; 3031 3032 begin 3033 -- An imported entity never requires body. Right now, only subprograms 3034 -- can be imported, but perhaps in the future we will allow import of 3035 -- packages. 3036 3037 if Is_Imported (Pack_Id) then 3038 return; 3039 3040 -- Body required if library package with pragma Elaborate_Body 3041 3042 elsif Has_Pragma_Elaborate_Body (Pack_Id) then 3043 Error_Msg_N ("info: & requires body (Elaborate_Body)?Y?", Pack_Id); 3044 3045 -- Body required if subprogram 3046 3047 elsif Is_Subprogram_Or_Generic_Subprogram (Pack_Id) then 3048 Error_Msg_N ("info: & requires body (subprogram case)?Y?", Pack_Id); 3049 3050 -- Body required if generic parent has Elaborate_Body 3051 3052 elsif Ekind (Pack_Id) = E_Package 3053 and then Nkind (Parent (Pack_Id)) = N_Package_Specification 3054 and then Present (Generic_Parent (Parent (Pack_Id))) 3055 then 3056 declare 3057 G_P : constant Entity_Id := Generic_Parent (Parent (Pack_Id)); 3058 begin 3059 if Has_Pragma_Elaborate_Body (G_P) then 3060 Error_Msg_N 3061 ("info: & requires body (generic parent Elaborate_Body)?Y?", 3062 Pack_Id); 3063 end if; 3064 end; 3065 3066 -- A [generic] package that introduces at least one non-null abstract 3067 -- state requires completion. However, there is a separate rule that 3068 -- requires that such a package have a reason other than this for a 3069 -- body being required (if necessary a pragma Elaborate_Body must be 3070 -- provided). If Ignore_Abstract_State is True, we don't do this check 3071 -- (so we can use Unit_Requires_Body to check for some other reason). 3072 3073 elsif Ekind_In (Pack_Id, E_Generic_Package, E_Package) 3074 and then Present (Abstract_States (Pack_Id)) 3075 and then not Is_Null_State 3076 (Node (First_Elmt (Abstract_States (Pack_Id)))) 3077 then 3078 Error_Msg_N 3079 ("info: & requires body (non-null abstract state aspect)?Y?", 3080 Pack_Id); 3081 end if; 3082 3083 -- Otherwise search entity chain for entity requiring completion 3084 3085 E := First_Entity (Pack_Id); 3086 while Present (E) loop 3087 if Requires_Completion_In_Body (E, Pack_Id) then 3088 Error_Msg_Node_2 := E; 3089 Error_Msg_NE 3090 ("info: & requires body (& requires completion)?Y?", E, Pack_Id); 3091 end if; 3092 3093 Next_Entity (E); 3094 end loop; 3095 end Unit_Requires_Body_Info; 3096end Sem_Ch7; 3097