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