1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ C H 1 2 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Contracts; use Contracts; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Expander; use Expander; 33with Fname; use Fname; 34with Fname.UF; use Fname.UF; 35with Freeze; use Freeze; 36with Ghost; use Ghost; 37with Itypes; use Itypes; 38with Lib; use Lib; 39with Lib.Load; use Lib.Load; 40with Lib.Xref; use Lib.Xref; 41with Nlists; use Nlists; 42with Namet; use Namet; 43with Nmake; use Nmake; 44with Opt; use Opt; 45with Rident; use Rident; 46with Restrict; use Restrict; 47with Rtsfind; use Rtsfind; 48with Sem; use Sem; 49with Sem_Aux; use Sem_Aux; 50with Sem_Cat; use Sem_Cat; 51with Sem_Ch3; use Sem_Ch3; 52with Sem_Ch6; use Sem_Ch6; 53with Sem_Ch7; use Sem_Ch7; 54with Sem_Ch8; use Sem_Ch8; 55with Sem_Ch10; use Sem_Ch10; 56with Sem_Ch13; use Sem_Ch13; 57with Sem_Dim; use Sem_Dim; 58with Sem_Disp; use Sem_Disp; 59with Sem_Elab; use Sem_Elab; 60with Sem_Elim; use Sem_Elim; 61with Sem_Eval; use Sem_Eval; 62with Sem_Prag; use Sem_Prag; 63with Sem_Res; use Sem_Res; 64with Sem_Type; use Sem_Type; 65with Sem_Util; use Sem_Util; 66with Sem_Warn; use Sem_Warn; 67with Stand; use Stand; 68with Sinfo; use Sinfo; 69with Sinfo.CN; use Sinfo.CN; 70with Sinput; use Sinput; 71with Sinput.L; use Sinput.L; 72with Snames; use Snames; 73with Stringt; use Stringt; 74with Uname; use Uname; 75with Table; 76with Tbuild; use Tbuild; 77with Uintp; use Uintp; 78with Urealp; use Urealp; 79with Warnsw; use Warnsw; 80 81with GNAT.HTable; 82 83package body Sem_Ch12 is 84 85 ---------------------------------------------------------- 86 -- Implementation of Generic Analysis and Instantiation -- 87 ---------------------------------------------------------- 88 89 -- GNAT implements generics by macro expansion. No attempt is made to share 90 -- generic instantiations (for now). Analysis of a generic definition does 91 -- not perform any expansion action, but the expander must be called on the 92 -- tree for each instantiation, because the expansion may of course depend 93 -- on the generic actuals. All of this is best achieved as follows: 94 -- 95 -- a) Semantic analysis of a generic unit is performed on a copy of the 96 -- tree for the generic unit. All tree modifications that follow analysis 97 -- do not affect the original tree. Links are kept between the original 98 -- tree and the copy, in order to recognize non-local references within 99 -- the generic, and propagate them to each instance (recall that name 100 -- resolution is done on the generic declaration: generics are not really 101 -- macros). This is summarized in the following diagram: 102 103 -- .-----------. .----------. 104 -- | semantic |<--------------| generic | 105 -- | copy | | unit | 106 -- | |==============>| | 107 -- |___________| global |__________| 108 -- references | | | 109 -- | | | 110 -- .-----|--|. 111 -- | .-----|---. 112 -- | | .----------. 113 -- | | | generic | 114 -- |__| | | 115 -- |__| instance | 116 -- |__________| 117 118 -- b) Each instantiation copies the original tree, and inserts into it a 119 -- series of declarations that describe the mapping between generic formals 120 -- and actuals. For example, a generic In OUT parameter is an object 121 -- renaming of the corresponding actual, etc. Generic IN parameters are 122 -- constant declarations. 123 124 -- c) In order to give the right visibility for these renamings, we use 125 -- a different scheme for package and subprogram instantiations. For 126 -- packages, the list of renamings is inserted into the package 127 -- specification, before the visible declarations of the package. The 128 -- renamings are analyzed before any of the text of the instance, and are 129 -- thus visible at the right place. Furthermore, outside of the instance, 130 -- the generic parameters are visible and denote their corresponding 131 -- actuals. 132 133 -- For subprograms, we create a container package to hold the renamings 134 -- and the subprogram instance itself. Analysis of the package makes the 135 -- renaming declarations visible to the subprogram. After analyzing the 136 -- package, the defining entity for the subprogram is touched-up so that 137 -- it appears declared in the current scope, and not inside the container 138 -- package. 139 140 -- If the instantiation is a compilation unit, the container package is 141 -- given the same name as the subprogram instance. This ensures that 142 -- the elaboration procedure called by the binder, using the compilation 143 -- unit name, calls in fact the elaboration procedure for the package. 144 145 -- Not surprisingly, private types complicate this approach. By saving in 146 -- the original generic object the non-local references, we guarantee that 147 -- the proper entities are referenced at the point of instantiation. 148 -- However, for private types, this by itself does not insure that the 149 -- proper VIEW of the entity is used (the full type may be visible at the 150 -- point of generic definition, but not at instantiation, or vice-versa). 151 -- In order to reference the proper view, we special-case any reference 152 -- to private types in the generic object, by saving both views, one in 153 -- the generic and one in the semantic copy. At time of instantiation, we 154 -- check whether the two views are consistent, and exchange declarations if 155 -- necessary, in order to restore the correct visibility. Similarly, if 156 -- the instance view is private when the generic view was not, we perform 157 -- the exchange. After completing the instantiation, we restore the 158 -- current visibility. The flag Has_Private_View marks identifiers in the 159 -- the generic unit that require checking. 160 161 -- Visibility within nested generic units requires special handling. 162 -- Consider the following scheme: 163 164 -- type Global is ... -- outside of generic unit. 165 -- generic ... 166 -- package Outer is 167 -- ... 168 -- type Semi_Global is ... -- global to inner. 169 170 -- generic ... -- 1 171 -- procedure inner (X1 : Global; X2 : Semi_Global); 172 173 -- procedure in2 is new inner (...); -- 4 174 -- end Outer; 175 176 -- package New_Outer is new Outer (...); -- 2 177 -- procedure New_Inner is new New_Outer.Inner (...); -- 3 178 179 -- The semantic analysis of Outer captures all occurrences of Global. 180 -- The semantic analysis of Inner (at 1) captures both occurrences of 181 -- Global and Semi_Global. 182 183 -- At point 2 (instantiation of Outer), we also produce a generic copy 184 -- of Inner, even though Inner is, at that point, not being instantiated. 185 -- (This is just part of the semantic analysis of New_Outer). 186 187 -- Critically, references to Global within Inner must be preserved, while 188 -- references to Semi_Global should not preserved, because they must now 189 -- resolve to an entity within New_Outer. To distinguish between these, we 190 -- use a global variable, Current_Instantiated_Parent, which is set when 191 -- performing a generic copy during instantiation (at 2). This variable is 192 -- used when performing a generic copy that is not an instantiation, but 193 -- that is nested within one, as the occurrence of 1 within 2. The analysis 194 -- of a nested generic only preserves references that are global to the 195 -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to 196 -- determine whether a reference is external to the given parent. 197 198 -- The instantiation at point 3 requires no special treatment. The method 199 -- works as well for further nestings of generic units, but of course the 200 -- variable Current_Instantiated_Parent must be stacked because nested 201 -- instantiations can occur, e.g. the occurrence of 4 within 2. 202 203 -- The instantiation of package and subprogram bodies is handled in a 204 -- similar manner, except that it is delayed until after semantic 205 -- analysis is complete. In this fashion complex cross-dependencies 206 -- between several package declarations and bodies containing generics 207 -- can be compiled which otherwise would diagnose spurious circularities. 208 209 -- For example, it is possible to compile two packages A and B that 210 -- have the following structure: 211 212 -- package A is package B is 213 -- generic ... generic ... 214 -- package G_A is package G_B is 215 216 -- with B; with A; 217 -- package body A is package body B is 218 -- package N_B is new G_B (..) package N_A is new G_A (..) 219 220 -- The table Pending_Instantiations in package Inline is used to keep 221 -- track of body instantiations that are delayed in this manner. Inline 222 -- handles the actual calls to do the body instantiations. This activity 223 -- is part of Inline, since the processing occurs at the same point, and 224 -- for essentially the same reason, as the handling of inlined routines. 225 226 ---------------------------------------------- 227 -- Detection of Instantiation Circularities -- 228 ---------------------------------------------- 229 230 -- If we have a chain of instantiations that is circular, this is static 231 -- error which must be detected at compile time. The detection of these 232 -- circularities is carried out at the point that we insert a generic 233 -- instance spec or body. If there is a circularity, then the analysis of 234 -- the offending spec or body will eventually result in trying to load the 235 -- same unit again, and we detect this problem as we analyze the package 236 -- instantiation for the second time. 237 238 -- At least in some cases after we have detected the circularity, we get 239 -- into trouble if we try to keep going. The following flag is set if a 240 -- circularity is detected, and used to abandon compilation after the 241 -- messages have been posted. 242 243 ----------------------------------------- 244 -- Implementation of Generic Contracts -- 245 ----------------------------------------- 246 247 -- A "contract" is a collection of aspects and pragmas that either verify a 248 -- property of a construct at runtime or classify the data flow to and from 249 -- the construct in some fashion. 250 251 -- Generic packages, subprograms and their respective bodies may be subject 252 -- to the following contract-related aspects or pragmas collectively known 253 -- as annotations: 254 255 -- package subprogram [body] 256 -- Abstract_State Contract_Cases 257 -- Initial_Condition Depends 258 -- Initializes Extensions_Visible 259 -- Global 260 -- package body Post 261 -- Refined_State Post_Class 262 -- Postcondition 263 -- Pre 264 -- Pre_Class 265 -- Precondition 266 -- Refined_Depends 267 -- Refined_Global 268 -- Refined_Post 269 -- Test_Case 270 271 -- Most package contract annotations utilize forward references to classify 272 -- data declared within the package [body]. Subprogram annotations then use 273 -- the classifications to further refine them. These inter dependencies are 274 -- problematic with respect to the implementation of generics because their 275 -- analysis, capture of global references and instantiation does not mesh 276 -- well with the existing mechanism. 277 278 -- 1) Analysis of generic contracts is carried out the same way non-generic 279 -- contracts are analyzed: 280 281 -- 1.1) General rule - a contract is analyzed after all related aspects 282 -- and pragmas are analyzed. This is done by routines 283 284 -- Analyze_Package_Body_Contract 285 -- Analyze_Package_Contract 286 -- Analyze_Subprogram_Body_Contract 287 -- Analyze_Subprogram_Contract 288 289 -- 1.2) Compilation unit - the contract is analyzed after Pragmas_After 290 -- are processed. 291 292 -- 1.3) Compilation unit body - the contract is analyzed at the end of 293 -- the body declaration list. 294 295 -- 1.4) Package - the contract is analyzed at the end of the private or 296 -- visible declarations, prior to analyzing the contracts of any nested 297 -- packages or subprograms. 298 299 -- 1.5) Package body - the contract is analyzed at the end of the body 300 -- declaration list, prior to analyzing the contracts of any nested 301 -- packages or subprograms. 302 303 -- 1.6) Subprogram - if the subprogram is declared inside a block, a 304 -- package or a subprogram, then its contract is analyzed at the end of 305 -- the enclosing declarations, otherwise the subprogram is a compilation 306 -- unit 1.2). 307 308 -- 1.7) Subprogram body - if the subprogram body is declared inside a 309 -- block, a package body or a subprogram body, then its contract is 310 -- analyzed at the end of the enclosing declarations, otherwise the 311 -- subprogram is a compilation unit 1.3). 312 313 -- 2) Capture of global references within contracts is done after capturing 314 -- global references within the generic template. There are two reasons for 315 -- this delay - pragma annotations are not part of the generic template in 316 -- the case of a generic subprogram declaration, and analysis of contracts 317 -- is delayed. 318 319 -- Contract-related source pragmas within generic templates are prepared 320 -- for delayed capture of global references by routine 321 322 -- Create_Generic_Contract 323 324 -- The routine associates these pragmas with the contract of the template. 325 -- In the case of a generic subprogram declaration, the routine creates 326 -- generic templates for the pragmas declared after the subprogram because 327 -- they are not part of the template. 328 329 -- generic -- template starts 330 -- procedure Gen_Proc (Input : Integer); -- template ends 331 -- pragma Precondition (Input > 0); -- requires own template 332 333 -- 2.1) The capture of global references with aspect specifications and 334 -- source pragmas that apply to a generic unit must be suppressed when 335 -- the generic template is being processed because the contracts have not 336 -- been analyzed yet. Any attempts to capture global references at that 337 -- point will destroy the Associated_Node linkages and leave the template 338 -- undecorated. This delay is controlled by routine 339 340 -- Requires_Delayed_Save 341 342 -- 2.2) The real capture of global references within a contract is done 343 -- after the contract has been analyzed, by routine 344 345 -- Save_Global_References_In_Contract 346 347 -- 3) The instantiation of a generic contract occurs as part of the 348 -- instantiation of the contract owner. Generic subprogram declarations 349 -- require additional processing when the contract is specified by pragmas 350 -- because the pragmas are not part of the generic template. This is done 351 -- by routine 352 353 -- Instantiate_Subprogram_Contract 354 355 Circularity_Detected : Boolean := False; 356 -- This should really be reset on encountering a new main unit, but in 357 -- practice we are not using multiple main units so it is not critical. 358 359 -------------------------------------------------- 360 -- Formal packages and partial parameterization -- 361 -------------------------------------------------- 362 363 -- When compiling a generic, a formal package is a local instantiation. If 364 -- declared with a box, its generic formals are visible in the enclosing 365 -- generic. If declared with a partial list of actuals, those actuals that 366 -- are defaulted (covered by an Others clause, or given an explicit box 367 -- initialization) are also visible in the enclosing generic, while those 368 -- that have a corresponding actual are not. 369 370 -- In our source model of instantiation, the same visibility must be 371 -- present in the spec and body of an instance: the names of the formals 372 -- that are defaulted must be made visible within the instance, and made 373 -- invisible (hidden) after the instantiation is complete, so that they 374 -- are not accessible outside of the instance. 375 376 -- In a generic, a formal package is treated like a special instantiation. 377 -- Our Ada 95 compiler handled formals with and without box in different 378 -- ways. With partial parameterization, we use a single model for both. 379 -- We create a package declaration that consists of the specification of 380 -- the generic package, and a set of declarations that map the actuals 381 -- into local renamings, just as we do for bona fide instantiations. For 382 -- defaulted parameters and formals with a box, we copy directly the 383 -- declarations of the formal into this local package. The result is a 384 -- a package whose visible declarations may include generic formals. This 385 -- package is only used for type checking and visibility analysis, and 386 -- never reaches the back-end, so it can freely violate the placement 387 -- rules for generic formal declarations. 388 389 -- The list of declarations (renamings and copies of formals) is built 390 -- by Analyze_Associations, just as for regular instantiations. 391 392 -- At the point of instantiation, conformance checking must be applied only 393 -- to those parameters that were specified in the formal. We perform this 394 -- checking by creating another internal instantiation, this one including 395 -- only the renamings and the formals (the rest of the package spec is not 396 -- relevant to conformance checking). We can then traverse two lists: the 397 -- list of actuals in the instance that corresponds to the formal package, 398 -- and the list of actuals produced for this bogus instantiation. We apply 399 -- the conformance rules to those actuals that are not defaulted (i.e. 400 -- which still appear as generic formals. 401 402 -- When we compile an instance body we must make the right parameters 403 -- visible again. The predicate Is_Generic_Formal indicates which of the 404 -- formals should have its Is_Hidden flag reset. 405 406 ----------------------- 407 -- Local subprograms -- 408 ----------------------- 409 410 procedure Abandon_Instantiation (N : Node_Id); 411 pragma No_Return (Abandon_Instantiation); 412 -- Posts an error message "instantiation abandoned" at the indicated node 413 -- and then raises the exception Instantiation_Error to do it. 414 415 procedure Analyze_Formal_Array_Type 416 (T : in out Entity_Id; 417 Def : Node_Id); 418 -- A formal array type is treated like an array type declaration, and 419 -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is 420 -- in-out, because in the case of an anonymous type the entity is 421 -- actually created in the procedure. 422 423 -- The following procedures treat other kinds of formal parameters 424 425 procedure Analyze_Formal_Derived_Interface_Type 426 (N : Node_Id; 427 T : Entity_Id; 428 Def : Node_Id); 429 430 procedure Analyze_Formal_Derived_Type 431 (N : Node_Id; 432 T : Entity_Id; 433 Def : Node_Id); 434 435 procedure Analyze_Formal_Interface_Type 436 (N : Node_Id; 437 T : Entity_Id; 438 Def : Node_Id); 439 440 -- The following subprograms create abbreviated declarations for formal 441 -- scalar types. We introduce an anonymous base of the proper class for 442 -- each of them, and define the formals as constrained first subtypes of 443 -- their bases. The bounds are expressions that are non-static in the 444 -- generic. 445 446 procedure Analyze_Formal_Decimal_Fixed_Point_Type 447 (T : Entity_Id; Def : Node_Id); 448 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id); 449 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id); 450 procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id); 451 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id); 452 procedure Analyze_Formal_Ordinary_Fixed_Point_Type 453 (T : Entity_Id; Def : Node_Id); 454 455 procedure Analyze_Formal_Private_Type 456 (N : Node_Id; 457 T : Entity_Id; 458 Def : Node_Id); 459 -- Creates a new private type, which does not require completion 460 461 procedure Analyze_Formal_Incomplete_Type (T : Entity_Id; Def : Node_Id); 462 -- Ada 2012: Creates a new incomplete type whose actual does not freeze 463 464 procedure Analyze_Generic_Formal_Part (N : Node_Id); 465 -- Analyze generic formal part 466 467 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id); 468 -- Create a new access type with the given designated type 469 470 function Analyze_Associations 471 (I_Node : Node_Id; 472 Formals : List_Id; 473 F_Copy : List_Id) return List_Id; 474 -- At instantiation time, build the list of associations between formals 475 -- and actuals. Each association becomes a renaming declaration for the 476 -- formal entity. F_Copy is the analyzed list of formals in the generic 477 -- copy. It is used to apply legality checks to the actuals. I_Node is the 478 -- instantiation node itself. 479 480 procedure Analyze_Subprogram_Instantiation 481 (N : Node_Id; 482 K : Entity_Kind); 483 484 procedure Build_Instance_Compilation_Unit_Nodes 485 (N : Node_Id; 486 Act_Body : Node_Id; 487 Act_Decl : Node_Id); 488 -- This procedure is used in the case where the generic instance of a 489 -- subprogram body or package body is a library unit. In this case, the 490 -- original library unit node for the generic instantiation must be 491 -- replaced by the resulting generic body, and a link made to a new 492 -- compilation unit node for the generic declaration. The argument N is 493 -- the original generic instantiation. Act_Body and Act_Decl are the body 494 -- and declaration of the instance (either package body and declaration 495 -- nodes or subprogram body and declaration nodes depending on the case). 496 -- On return, the node N has been rewritten with the actual body. 497 498 procedure Check_Access_Definition (N : Node_Id); 499 -- Subsidiary routine to null exclusion processing. Perform an assertion 500 -- check on Ada version and the presence of an access definition in N. 501 502 procedure Check_Formal_Packages (P_Id : Entity_Id); 503 -- Apply the following to all formal packages in generic associations. 504 -- Restore the visibility of the formals of the instance that are not 505 -- defaulted (see RM 12.7 (10)). Remove the anonymous package declaration 506 -- created for formal instances that are not defaulted. 507 508 procedure Check_Formal_Package_Instance 509 (Formal_Pack : Entity_Id; 510 Actual_Pack : Entity_Id); 511 -- Verify that the actuals of the actual instance match the actuals of 512 -- the template for a formal package that is not declared with a box. 513 514 procedure Check_Forward_Instantiation (Decl : Node_Id); 515 -- If the generic is a local entity and the corresponding body has not 516 -- been seen yet, flag enclosing packages to indicate that it will be 517 -- elaborated after the generic body. Subprograms declared in the same 518 -- package cannot be inlined by the front end because front-end inlining 519 -- requires a strict linear order of elaboration. 520 521 function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id; 522 -- Check if some association between formals and actuals requires to make 523 -- visible primitives of a tagged type, and make those primitives visible. 524 -- Return the list of primitives whose visibility is modified (to restore 525 -- their visibility later through Restore_Hidden_Primitives). If no 526 -- candidate is found then return No_Elist. 527 528 procedure Check_Hidden_Child_Unit 529 (N : Node_Id; 530 Gen_Unit : Entity_Id; 531 Act_Decl_Id : Entity_Id); 532 -- If the generic unit is an implicit child instance within a parent 533 -- instance, we need to make an explicit test that it is not hidden by 534 -- a child instance of the same name and parent. 535 536 procedure Check_Generic_Actuals 537 (Instance : Entity_Id; 538 Is_Formal_Box : Boolean); 539 -- Similar to previous one. Check the actuals in the instantiation, 540 -- whose views can change between the point of instantiation and the point 541 -- of instantiation of the body. In addition, mark the generic renamings 542 -- as generic actuals, so that they are not compatible with other actuals. 543 -- Recurse on an actual that is a formal package whose declaration has 544 -- a box. 545 546 function Contains_Instance_Of 547 (Inner : Entity_Id; 548 Outer : Entity_Id; 549 N : Node_Id) return Boolean; 550 -- Inner is instantiated within the generic Outer. Check whether Inner 551 -- directly or indirectly contains an instance of Outer or of one of its 552 -- parents, in the case of a subunit. Each generic unit holds a list of 553 -- the entities instantiated within (at any depth). This procedure 554 -- determines whether the set of such lists contains a cycle, i.e. an 555 -- illegal circular instantiation. 556 557 function Denotes_Formal_Package 558 (Pack : Entity_Id; 559 On_Exit : Boolean := False; 560 Instance : Entity_Id := Empty) return Boolean; 561 -- Returns True if E is a formal package of an enclosing generic, or 562 -- the actual for such a formal in an enclosing instantiation. If such 563 -- a package is used as a formal in an nested generic, or as an actual 564 -- in a nested instantiation, the visibility of ITS formals should not 565 -- be modified. When called from within Restore_Private_Views, the flag 566 -- On_Exit is true, to indicate that the search for a possible enclosing 567 -- instance should ignore the current one. In that case Instance denotes 568 -- the declaration for which this is an actual. This declaration may be 569 -- an instantiation in the source, or the internal instantiation that 570 -- corresponds to the actual for a formal package. 571 572 function Earlier (N1, N2 : Node_Id) return Boolean; 573 -- Yields True if N1 and N2 appear in the same compilation unit, 574 -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right 575 -- traversal of the tree for the unit. Used to determine the placement 576 -- of freeze nodes for instance bodies that may depend on other instances. 577 578 function Find_Actual_Type 579 (Typ : Entity_Id; 580 Gen_Type : Entity_Id) return Entity_Id; 581 -- When validating the actual types of a child instance, check whether 582 -- the formal is a formal type of the parent unit, and retrieve the current 583 -- actual for it. Typ is the entity in the analyzed formal type declaration 584 -- (component or index type of an array type, or designated type of an 585 -- access formal) and Gen_Type is the enclosing analyzed formal array 586 -- or access type. The desired actual may be a formal of a parent, or may 587 -- be declared in a formal package of a parent. In both cases it is a 588 -- generic actual type because it appears within a visible instance. 589 -- Finally, it may be declared in a parent unit without being a formal 590 -- of that unit, in which case it must be retrieved by visibility. 591 -- Ambiguities may still arise if two homonyms are declared in two formal 592 -- packages, and the prefix of the formal type may be needed to resolve 593 -- the ambiguity in the instance ??? 594 595 procedure Freeze_Subprogram_Body 596 (Inst_Node : Node_Id; 597 Gen_Body : Node_Id; 598 Pack_Id : Entity_Id); 599 -- The generic body may appear textually after the instance, including 600 -- in the proper body of a stub, or within a different package instance. 601 -- Given that the instance can only be elaborated after the generic, we 602 -- place freeze_nodes for the instance and/or for packages that may enclose 603 -- the instance and the generic, so that the back-end can establish the 604 -- proper order of elaboration. 605 606 function Get_Associated_Node (N : Node_Id) return Node_Id; 607 -- In order to propagate semantic information back from the analyzed copy 608 -- to the original generic, we maintain links between selected nodes in the 609 -- generic and their corresponding copies. At the end of generic analysis, 610 -- the routine Save_Global_References traverses the generic tree, examines 611 -- the semantic information, and preserves the links to those nodes that 612 -- contain global information. At instantiation, the information from the 613 -- associated node is placed on the new copy, so that name resolution is 614 -- not repeated. 615 -- 616 -- Three kinds of source nodes have associated nodes: 617 -- 618 -- a) those that can reference (denote) entities, that is identifiers, 619 -- character literals, expanded_names, operator symbols, operators, 620 -- and attribute reference nodes. These nodes have an Entity field 621 -- and are the set of nodes that are in N_Has_Entity. 622 -- 623 -- b) aggregates (N_Aggregate and N_Extension_Aggregate) 624 -- 625 -- c) selected components (N_Selected_Component) 626 -- 627 -- For the first class, the associated node preserves the entity if it is 628 -- global. If the generic contains nested instantiations, the associated 629 -- node itself has been recopied, and a chain of them must be followed. 630 -- 631 -- For aggregates, the associated node allows retrieval of the type, which 632 -- may otherwise not appear in the generic. The view of this type may be 633 -- different between generic and instantiation, and the full view can be 634 -- installed before the instantiation is analyzed. For aggregates of type 635 -- extensions, the same view exchange may have to be performed for some of 636 -- the ancestor types, if their view is private at the point of 637 -- instantiation. 638 -- 639 -- Nodes that are selected components in the parse tree may be rewritten 640 -- as expanded names after resolution, and must be treated as potential 641 -- entity holders, which is why they also have an Associated_Node. 642 -- 643 -- Nodes that do not come from source, such as freeze nodes, do not appear 644 -- in the generic tree, and need not have an associated node. 645 -- 646 -- The associated node is stored in the Associated_Node field. Note that 647 -- this field overlaps Entity, which is fine, because the whole point is 648 -- that we don't need or want the normal Entity field in this situation. 649 650 function Has_Been_Exchanged (E : Entity_Id) return Boolean; 651 -- Traverse the Exchanged_Views list to see if a type was private 652 -- and has already been flipped during this phase of instantiation. 653 654 procedure Hide_Current_Scope; 655 -- When instantiating a generic child unit, the parent context must be 656 -- present, but the instance and all entities that may be generated 657 -- must be inserted in the current scope. We leave the current scope 658 -- on the stack, but make its entities invisible to avoid visibility 659 -- problems. This is reversed at the end of the instantiation. This is 660 -- not done for the instantiation of the bodies, which only require the 661 -- instances of the generic parents to be in scope. 662 663 function In_Main_Context (E : Entity_Id) return Boolean; 664 -- Check whether an instantiation is in the context of the main unit. 665 -- Used to determine whether its body should be elaborated to allow 666 -- front-end inlining. 667 668 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id); 669 -- Add the context clause of the unit containing a generic unit to a 670 -- compilation unit that is, or contains, an instantiation. 671 672 procedure Init_Env; 673 -- Establish environment for subsequent instantiation. Separated from 674 -- Save_Env because data-structures for visibility handling must be 675 -- initialized before call to Check_Generic_Child_Unit. 676 677 procedure Inline_Instance_Body 678 (N : Node_Id; 679 Gen_Unit : Entity_Id; 680 Act_Decl : Node_Id); 681 -- If front-end inlining is requested, instantiate the package body, 682 -- and preserve the visibility of its compilation unit, to insure 683 -- that successive instantiations succeed. 684 685 procedure Insert_Freeze_Node_For_Instance 686 (N : Node_Id; 687 F_Node : Node_Id); 688 -- N denotes a package or a subprogram instantiation and F_Node is the 689 -- associated freeze node. Insert the freeze node before the first source 690 -- body which follows immediately after N. If no such body is found, the 691 -- freeze node is inserted at the end of the declarative region which 692 -- contains N. 693 694 procedure Install_Body 695 (Act_Body : Node_Id; 696 N : Node_Id; 697 Gen_Body : Node_Id; 698 Gen_Decl : Node_Id); 699 -- If the instantiation happens textually before the body of the generic, 700 -- the instantiation of the body must be analyzed after the generic body, 701 -- and not at the point of instantiation. Such early instantiations can 702 -- happen if the generic and the instance appear in a package declaration 703 -- because the generic body can only appear in the corresponding package 704 -- body. Early instantiations can also appear if generic, instance and 705 -- body are all in the declarative part of a subprogram or entry. Entities 706 -- of packages that are early instantiations are delayed, and their freeze 707 -- node appears after the generic body. This rather complex machinery is 708 -- needed when nested instantiations are present, because the source does 709 -- not carry any indication of where the corresponding instance bodies must 710 -- be installed and frozen. 711 712 procedure Install_Formal_Packages (Par : Entity_Id); 713 -- Install the visible part of any formal of the parent that is a formal 714 -- package. Note that for the case of a formal package with a box, this 715 -- includes the formal part of the formal package (12.7(10/2)). 716 717 procedure Install_Hidden_Primitives 718 (Prims_List : in out Elist_Id; 719 Gen_T : Entity_Id; 720 Act_T : Entity_Id); 721 -- Remove suffix 'P' from hidden primitives of Act_T to match the 722 -- visibility of primitives of Gen_T. The list of primitives to which 723 -- the suffix is removed is added to Prims_List to restore them later. 724 725 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False); 726 -- When compiling an instance of a child unit the parent (which is 727 -- itself an instance) is an enclosing scope that must be made 728 -- immediately visible. This procedure is also used to install the non- 729 -- generic parent of a generic child unit when compiling its body, so 730 -- that full views of types in the parent are made visible. 731 732 -- The functions Instantiate_XXX perform various legality checks and build 733 -- the declarations for instantiated generic parameters. In all of these 734 -- Formal is the entity in the generic unit, Actual is the entity of 735 -- expression in the generic associations, and Analyzed_Formal is the 736 -- formal in the generic copy, which contains the semantic information to 737 -- be used to validate the actual. 738 739 function Instantiate_Object 740 (Formal : Node_Id; 741 Actual : Node_Id; 742 Analyzed_Formal : Node_Id) return List_Id; 743 744 function Instantiate_Type 745 (Formal : Node_Id; 746 Actual : Node_Id; 747 Analyzed_Formal : Node_Id; 748 Actual_Decls : List_Id) return List_Id; 749 750 function Instantiate_Formal_Subprogram 751 (Formal : Node_Id; 752 Actual : Node_Id; 753 Analyzed_Formal : Node_Id) return Node_Id; 754 755 function Instantiate_Formal_Package 756 (Formal : Node_Id; 757 Actual : Node_Id; 758 Analyzed_Formal : Node_Id) return List_Id; 759 -- If the formal package is declared with a box, special visibility rules 760 -- apply to its formals: they are in the visible part of the package. This 761 -- is true in the declarative region of the formal package, that is to say 762 -- in the enclosing generic or instantiation. For an instantiation, the 763 -- parameters of the formal package are made visible in an explicit step. 764 -- Furthermore, if the actual has a visible USE clause, these formals must 765 -- be made potentially use-visible as well. On exit from the enclosing 766 -- instantiation, the reverse must be done. 767 768 -- For a formal package declared without a box, there are conformance rules 769 -- that apply to the actuals in the generic declaration and the actuals of 770 -- the actual package in the enclosing instantiation. The simplest way to 771 -- apply these rules is to repeat the instantiation of the formal package 772 -- in the context of the enclosing instance, and compare the generic 773 -- associations of this instantiation with those of the actual package. 774 -- This internal instantiation only needs to contain the renamings of the 775 -- formals: the visible and private declarations themselves need not be 776 -- created. 777 778 -- In Ada 2005, the formal package may be only partially parameterized. 779 -- In that case the visibility step must make visible those actuals whose 780 -- corresponding formals were given with a box. A final complication 781 -- involves inherited operations from formal derived types, which must 782 -- be visible if the type is. 783 784 function Is_In_Main_Unit (N : Node_Id) return Boolean; 785 -- Test if given node is in the main unit 786 787 procedure Load_Parent_Of_Generic 788 (N : Node_Id; 789 Spec : Node_Id; 790 Body_Optional : Boolean := False); 791 -- If the generic appears in a separate non-generic library unit, load the 792 -- corresponding body to retrieve the body of the generic. N is the node 793 -- for the generic instantiation, Spec is the generic package declaration. 794 -- 795 -- Body_Optional is a flag that indicates that the body is being loaded to 796 -- ensure that temporaries are generated consistently when there are other 797 -- instances in the current declarative part that precede the one being 798 -- loaded. In that case a missing body is acceptable. 799 800 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id); 801 -- Within the generic part, entities in the formal package are 802 -- visible. To validate subsequent type declarations, indicate 803 -- the correspondence between the entities in the analyzed formal, 804 -- and the entities in the actual package. There are three packages 805 -- involved in the instantiation of a formal package: the parent 806 -- generic P1 which appears in the generic declaration, the fake 807 -- instantiation P2 which appears in the analyzed generic, and whose 808 -- visible entities may be used in subsequent formals, and the actual 809 -- P3 in the instance. To validate subsequent formals, me indicate 810 -- that the entities in P2 are mapped into those of P3. The mapping of 811 -- entities has to be done recursively for nested packages. 812 813 procedure Move_Freeze_Nodes 814 (Out_Of : Entity_Id; 815 After : Node_Id; 816 L : List_Id); 817 -- Freeze nodes can be generated in the analysis of a generic unit, but 818 -- will not be seen by the back-end. It is necessary to move those nodes 819 -- to the enclosing scope if they freeze an outer entity. We place them 820 -- at the end of the enclosing generic package, which is semantically 821 -- neutral. 822 823 procedure Preanalyze_Actuals (N : Node_Id; Inst : Entity_Id := Empty); 824 -- Analyze actuals to perform name resolution. Full resolution is done 825 -- later, when the expected types are known, but names have to be captured 826 -- before installing parents of generics, that are not visible for the 827 -- actuals themselves. 828 -- 829 -- If Inst is present, it is the entity of the package instance. This 830 -- entity is marked as having a limited_view actual when some actual is 831 -- a limited view. This is used to place the instance body properly. 832 833 procedure Provide_Completing_Bodies (N : Node_Id); 834 -- Generate completing bodies for all subprograms found within package or 835 -- subprogram declaration N. 836 837 procedure Remove_Parent (In_Body : Boolean := False); 838 -- Reverse effect after instantiation of child is complete 839 840 procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id); 841 -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List 842 -- set to No_Elist. 843 844 procedure Set_Instance_Env 845 (Gen_Unit : Entity_Id; 846 Act_Unit : Entity_Id); 847 -- Save current instance on saved environment, to be used to determine 848 -- the global status of entities in nested instances. Part of Save_Env. 849 -- called after verifying that the generic unit is legal for the instance, 850 -- The procedure also examines whether the generic unit is a predefined 851 -- unit, in order to set configuration switches accordingly. As a result 852 -- the procedure must be called after analyzing and freezing the actuals. 853 854 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id); 855 -- Associate analyzed generic parameter with corresponding instance. Used 856 -- for semantic checks at instantiation time. 857 858 function True_Parent (N : Node_Id) return Node_Id; 859 -- For a subunit, return parent of corresponding stub, else return 860 -- parent of node. 861 862 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id); 863 -- Verify that an attribute that appears as the default for a formal 864 -- subprogram is a function or procedure with the correct profile. 865 866 ------------------------------------------- 867 -- Data Structures for Generic Renamings -- 868 ------------------------------------------- 869 870 -- The map Generic_Renamings associates generic entities with their 871 -- corresponding actuals. Currently used to validate type instances. It 872 -- will eventually be used for all generic parameters to eliminate the 873 -- need for overload resolution in the instance. 874 875 type Assoc_Ptr is new Int; 876 877 Assoc_Null : constant Assoc_Ptr := -1; 878 879 type Assoc is record 880 Gen_Id : Entity_Id; 881 Act_Id : Entity_Id; 882 Next_In_HTable : Assoc_Ptr; 883 end record; 884 885 package Generic_Renamings is new Table.Table 886 (Table_Component_Type => Assoc, 887 Table_Index_Type => Assoc_Ptr, 888 Table_Low_Bound => 0, 889 Table_Initial => 10, 890 Table_Increment => 100, 891 Table_Name => "Generic_Renamings"); 892 893 -- Variable to hold enclosing instantiation. When the environment is 894 -- saved for a subprogram inlining, the corresponding Act_Id is empty. 895 896 Current_Instantiated_Parent : Assoc := (Empty, Empty, Assoc_Null); 897 898 -- Hash table for associations 899 900 HTable_Size : constant := 37; 901 type HTable_Range is range 0 .. HTable_Size - 1; 902 903 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr); 904 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr; 905 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id; 906 function Hash (F : Entity_Id) return HTable_Range; 907 908 package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable ( 909 Header_Num => HTable_Range, 910 Element => Assoc, 911 Elmt_Ptr => Assoc_Ptr, 912 Null_Ptr => Assoc_Null, 913 Set_Next => Set_Next_Assoc, 914 Next => Next_Assoc, 915 Key => Entity_Id, 916 Get_Key => Get_Gen_Id, 917 Hash => Hash, 918 Equal => "="); 919 920 Exchanged_Views : Elist_Id; 921 -- This list holds the private views that have been exchanged during 922 -- instantiation to restore the visibility of the generic declaration. 923 -- (see comments above). After instantiation, the current visibility is 924 -- reestablished by means of a traversal of this list. 925 926 Hidden_Entities : Elist_Id; 927 -- This list holds the entities of the current scope that are removed 928 -- from immediate visibility when instantiating a child unit. Their 929 -- visibility is restored in Remove_Parent. 930 931 -- Because instantiations can be recursive, the following must be saved 932 -- on entry and restored on exit from an instantiation (spec or body). 933 -- This is done by the two procedures Save_Env and Restore_Env. For 934 -- package and subprogram instantiations (but not for the body instances) 935 -- the action of Save_Env is done in two steps: Init_Env is called before 936 -- Check_Generic_Child_Unit, because setting the parent instances requires 937 -- that the visibility data structures be properly initialized. Once the 938 -- generic is unit is validated, Set_Instance_Env completes Save_Env. 939 940 Parent_Unit_Visible : Boolean := False; 941 -- Parent_Unit_Visible is used when the generic is a child unit, and 942 -- indicates whether the ultimate parent of the generic is visible in the 943 -- instantiation environment. It is used to reset the visibility of the 944 -- parent at the end of the instantiation (see Remove_Parent). 945 946 Instance_Parent_Unit : Entity_Id := Empty; 947 -- This records the ultimate parent unit of an instance of a generic 948 -- child unit and is used in conjunction with Parent_Unit_Visible to 949 -- indicate the unit to which the Parent_Unit_Visible flag corresponds. 950 951 type Instance_Env is record 952 Instantiated_Parent : Assoc; 953 Exchanged_Views : Elist_Id; 954 Hidden_Entities : Elist_Id; 955 Current_Sem_Unit : Unit_Number_Type; 956 Parent_Unit_Visible : Boolean := False; 957 Instance_Parent_Unit : Entity_Id := Empty; 958 Switches : Config_Switches_Type; 959 end record; 960 961 package Instance_Envs is new Table.Table ( 962 Table_Component_Type => Instance_Env, 963 Table_Index_Type => Int, 964 Table_Low_Bound => 0, 965 Table_Initial => 32, 966 Table_Increment => 100, 967 Table_Name => "Instance_Envs"); 968 969 procedure Restore_Private_Views 970 (Pack_Id : Entity_Id; 971 Is_Package : Boolean := True); 972 -- Restore the private views of external types, and unmark the generic 973 -- renamings of actuals, so that they become compatible subtypes again. 974 -- For subprograms, Pack_Id is the package constructed to hold the 975 -- renamings. 976 977 procedure Switch_View (T : Entity_Id); 978 -- Switch the partial and full views of a type and its private 979 -- dependents (i.e. its subtypes and derived types). 980 981 ------------------------------------ 982 -- Structures for Error Reporting -- 983 ------------------------------------ 984 985 Instantiation_Node : Node_Id; 986 -- Used by subprograms that validate instantiation of formal parameters 987 -- where there might be no actual on which to place the error message. 988 -- Also used to locate the instantiation node for generic subunits. 989 990 Instantiation_Error : exception; 991 -- When there is a semantic error in the generic parameter matching, 992 -- there is no point in continuing the instantiation, because the 993 -- number of cascaded errors is unpredictable. This exception aborts 994 -- the instantiation process altogether. 995 996 S_Adjustment : Sloc_Adjustment; 997 -- Offset created for each node in an instantiation, in order to keep 998 -- track of the source position of the instantiation in each of its nodes. 999 -- A subsequent semantic error or warning on a construct of the instance 1000 -- points to both places: the original generic node, and the point of 1001 -- instantiation. See Sinput and Sinput.L for additional details. 1002 1003 ------------------------------------------------------------ 1004 -- Data structure for keeping track when inside a Generic -- 1005 ------------------------------------------------------------ 1006 1007 -- The following table is used to save values of the Inside_A_Generic 1008 -- flag (see spec of Sem) when they are saved by Start_Generic. 1009 1010 package Generic_Flags is new Table.Table ( 1011 Table_Component_Type => Boolean, 1012 Table_Index_Type => Int, 1013 Table_Low_Bound => 0, 1014 Table_Initial => 32, 1015 Table_Increment => 200, 1016 Table_Name => "Generic_Flags"); 1017 1018 --------------------------- 1019 -- Abandon_Instantiation -- 1020 --------------------------- 1021 1022 procedure Abandon_Instantiation (N : Node_Id) is 1023 begin 1024 Error_Msg_N ("\instantiation abandoned!", N); 1025 raise Instantiation_Error; 1026 end Abandon_Instantiation; 1027 1028 -------------------------------- 1029 -- Add_Pending_Instantiation -- 1030 -------------------------------- 1031 1032 procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id) is 1033 begin 1034 -- Capture the body of the generic instantiation along with its context 1035 -- for later processing by Instantiate_Bodies. 1036 1037 Pending_Instantiations.Append 1038 ((Act_Decl => Act_Decl, 1039 Config_Switches => Save_Config_Switches, 1040 Current_Sem_Unit => Current_Sem_Unit, 1041 Expander_Status => Expander_Active, 1042 Inst_Node => Inst, 1043 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 1044 Scope_Suppress => Scope_Suppress, 1045 Warnings => Save_Warnings)); 1046 end Add_Pending_Instantiation; 1047 1048 ---------------------------------- 1049 -- Adjust_Inherited_Pragma_Sloc -- 1050 ---------------------------------- 1051 1052 procedure Adjust_Inherited_Pragma_Sloc (N : Node_Id) is 1053 begin 1054 Adjust_Instantiation_Sloc (N, S_Adjustment); 1055 end Adjust_Inherited_Pragma_Sloc; 1056 1057 -------------------------- 1058 -- Analyze_Associations -- 1059 -------------------------- 1060 1061 function Analyze_Associations 1062 (I_Node : Node_Id; 1063 Formals : List_Id; 1064 F_Copy : List_Id) return List_Id 1065 is 1066 Actuals_To_Freeze : constant Elist_Id := New_Elmt_List; 1067 Assoc_List : constant List_Id := New_List; 1068 Default_Actuals : constant List_Id := New_List; 1069 Gen_Unit : constant Entity_Id := 1070 Defining_Entity (Parent (F_Copy)); 1071 1072 Actuals : List_Id; 1073 Actual : Node_Id; 1074 Analyzed_Formal : Node_Id; 1075 First_Named : Node_Id := Empty; 1076 Formal : Node_Id; 1077 Match : Node_Id; 1078 Named : Node_Id; 1079 Saved_Formal : Node_Id; 1080 1081 Default_Formals : constant List_Id := New_List; 1082 -- If an Others_Choice is present, some of the formals may be defaulted. 1083 -- To simplify the treatment of visibility in an instance, we introduce 1084 -- individual defaults for each such formal. These defaults are 1085 -- appended to the list of associations and replace the Others_Choice. 1086 1087 Found_Assoc : Node_Id; 1088 -- Association for the current formal being match. Empty if there are 1089 -- no remaining actuals, or if there is no named association with the 1090 -- name of the formal. 1091 1092 Is_Named_Assoc : Boolean; 1093 Num_Matched : Nat := 0; 1094 Num_Actuals : Nat := 0; 1095 1096 Others_Present : Boolean := False; 1097 Others_Choice : Node_Id := Empty; 1098 -- In Ada 2005, indicates partial parameterization of a formal 1099 -- package. As usual an other association must be last in the list. 1100 1101 procedure Check_Fixed_Point_Actual (Actual : Node_Id); 1102 -- Warn if an actual fixed-point type has user-defined arithmetic 1103 -- operations, but there is no corresponding formal in the generic, 1104 -- in which case the predefined operations will be used. This merits 1105 -- a warning because of the special semantics of fixed point ops. 1106 1107 procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id); 1108 -- Apply RM 12.3(9): if a formal subprogram is overloaded, the instance 1109 -- cannot have a named association for it. AI05-0025 extends this rule 1110 -- to formals of formal packages by AI05-0025, and it also applies to 1111 -- box-initialized formals. 1112 1113 function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean; 1114 -- Determine whether the parameter types and the return type of Subp 1115 -- are fully defined at the point of instantiation. 1116 1117 function Matching_Actual 1118 (F : Entity_Id; 1119 A_F : Entity_Id) return Node_Id; 1120 -- Find actual that corresponds to a given a formal parameter. If the 1121 -- actuals are positional, return the next one, if any. If the actuals 1122 -- are named, scan the parameter associations to find the right one. 1123 -- A_F is the corresponding entity in the analyzed generic, which is 1124 -- placed on the selector name for ASIS use. 1125 -- 1126 -- In Ada 2005, a named association may be given with a box, in which 1127 -- case Matching_Actual sets Found_Assoc to the generic association, 1128 -- but return Empty for the actual itself. In this case the code below 1129 -- creates a corresponding declaration for the formal. 1130 1131 function Partial_Parameterization return Boolean; 1132 -- Ada 2005: if no match is found for a given formal, check if the 1133 -- association for it includes a box, or whether the associations 1134 -- include an Others clause. 1135 1136 procedure Process_Default (F : Entity_Id); 1137 -- Add a copy of the declaration of generic formal F to the list of 1138 -- associations, and add an explicit box association for F if there 1139 -- is none yet, and the default comes from an Others_Choice. 1140 1141 function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean; 1142 -- Determine whether Subp renames one of the subprograms defined in the 1143 -- generated package Standard. 1144 1145 procedure Set_Analyzed_Formal; 1146 -- Find the node in the generic copy that corresponds to a given formal. 1147 -- The semantic information on this node is used to perform legality 1148 -- checks on the actuals. Because semantic analysis can introduce some 1149 -- anonymous entities or modify the declaration node itself, the 1150 -- correspondence between the two lists is not one-one. In addition to 1151 -- anonymous types, the presence a formal equality will introduce an 1152 -- implicit declaration for the corresponding inequality. 1153 1154 ---------------------------------------- 1155 -- Check_Overloaded_Formal_Subprogram -- 1156 ---------------------------------------- 1157 1158 procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id) is 1159 Temp_Formal : Entity_Id; 1160 1161 begin 1162 Temp_Formal := First (Formals); 1163 while Present (Temp_Formal) loop 1164 if Nkind (Temp_Formal) in N_Formal_Subprogram_Declaration 1165 and then Temp_Formal /= Formal 1166 and then 1167 Chars (Defining_Unit_Name (Specification (Formal))) = 1168 Chars (Defining_Unit_Name (Specification (Temp_Formal))) 1169 then 1170 if Present (Found_Assoc) then 1171 Error_Msg_N 1172 ("named association not allowed for overloaded formal", 1173 Found_Assoc); 1174 1175 else 1176 Error_Msg_N 1177 ("named association not allowed for overloaded formal", 1178 Others_Choice); 1179 end if; 1180 1181 Abandon_Instantiation (Instantiation_Node); 1182 end if; 1183 1184 Next (Temp_Formal); 1185 end loop; 1186 end Check_Overloaded_Formal_Subprogram; 1187 1188 ------------------------------- 1189 -- Check_Fixed_Point_Actual -- 1190 ------------------------------- 1191 1192 procedure Check_Fixed_Point_Actual (Actual : Node_Id) is 1193 Typ : constant Entity_Id := Entity (Actual); 1194 Prims : constant Elist_Id := Collect_Primitive_Operations (Typ); 1195 Elem : Elmt_Id; 1196 Formal : Node_Id; 1197 Op : Entity_Id; 1198 1199 begin 1200 -- Locate primitive operations of the type that are arithmetic 1201 -- operations. 1202 1203 Elem := First_Elmt (Prims); 1204 while Present (Elem) loop 1205 if Nkind (Node (Elem)) = N_Defining_Operator_Symbol then 1206 1207 -- Check whether the generic unit has a formal subprogram of 1208 -- the same name. This does not check types but is good enough 1209 -- to justify a warning. 1210 1211 Formal := First_Non_Pragma (Formals); 1212 Op := Alias (Node (Elem)); 1213 1214 while Present (Formal) loop 1215 if Nkind (Formal) = N_Formal_Concrete_Subprogram_Declaration 1216 and then Chars (Defining_Entity (Formal)) = 1217 Chars (Node (Elem)) 1218 then 1219 exit; 1220 1221 elsif Nkind (Formal) = N_Formal_Package_Declaration then 1222 declare 1223 Assoc : Node_Id; 1224 Ent : Entity_Id; 1225 1226 begin 1227 -- Locate corresponding actual, and check whether it 1228 -- includes a fixed-point type. 1229 1230 Assoc := First (Assoc_List); 1231 while Present (Assoc) loop 1232 exit when 1233 Nkind (Assoc) = N_Package_Renaming_Declaration 1234 and then Chars (Defining_Unit_Name (Assoc)) = 1235 Chars (Defining_Identifier (Formal)); 1236 1237 Next (Assoc); 1238 end loop; 1239 1240 if Present (Assoc) then 1241 1242 -- If formal package declares a fixed-point type, 1243 -- and the user-defined operator is derived from 1244 -- a generic instance package, the fixed-point type 1245 -- does not use the corresponding predefined op. 1246 1247 Ent := First_Entity (Entity (Name (Assoc))); 1248 while Present (Ent) loop 1249 if Is_Fixed_Point_Type (Ent) 1250 and then Present (Op) 1251 and then Is_Generic_Instance (Scope (Op)) 1252 then 1253 return; 1254 end if; 1255 1256 Next_Entity (Ent); 1257 end loop; 1258 end if; 1259 end; 1260 end if; 1261 1262 Next (Formal); 1263 end loop; 1264 1265 if No (Formal) then 1266 Error_Msg_Sloc := Sloc (Node (Elem)); 1267 Error_Msg_NE 1268 ("?instance uses predefined operation, not primitive " 1269 & "operation&#", Actual, Node (Elem)); 1270 end if; 1271 end if; 1272 1273 Next_Elmt (Elem); 1274 end loop; 1275 end Check_Fixed_Point_Actual; 1276 1277 ------------------------------- 1278 -- Has_Fully_Defined_Profile -- 1279 ------------------------------- 1280 1281 function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean is 1282 function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean; 1283 -- Determine whethet type Typ is fully defined 1284 1285 --------------------------- 1286 -- Is_Fully_Defined_Type -- 1287 --------------------------- 1288 1289 function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean is 1290 begin 1291 -- A private type without a full view is not fully defined 1292 1293 if Is_Private_Type (Typ) 1294 and then No (Full_View (Typ)) 1295 then 1296 return False; 1297 1298 -- An incomplete type is never fully defined 1299 1300 elsif Is_Incomplete_Type (Typ) then 1301 return False; 1302 1303 -- All other types are fully defined 1304 1305 else 1306 return True; 1307 end if; 1308 end Is_Fully_Defined_Type; 1309 1310 -- Local declarations 1311 1312 Param : Entity_Id; 1313 1314 -- Start of processing for Has_Fully_Defined_Profile 1315 1316 begin 1317 -- Check the parameters 1318 1319 Param := First_Formal (Subp); 1320 while Present (Param) loop 1321 if not Is_Fully_Defined_Type (Etype (Param)) then 1322 return False; 1323 end if; 1324 1325 Next_Formal (Param); 1326 end loop; 1327 1328 -- Check the return type 1329 1330 return Is_Fully_Defined_Type (Etype (Subp)); 1331 end Has_Fully_Defined_Profile; 1332 1333 --------------------- 1334 -- Matching_Actual -- 1335 --------------------- 1336 1337 function Matching_Actual 1338 (F : Entity_Id; 1339 A_F : Entity_Id) return Node_Id 1340 is 1341 Prev : Node_Id; 1342 Act : Node_Id; 1343 1344 begin 1345 Is_Named_Assoc := False; 1346 1347 -- End of list of purely positional parameters 1348 1349 if No (Actual) or else Nkind (Actual) = N_Others_Choice then 1350 Found_Assoc := Empty; 1351 Act := Empty; 1352 1353 -- Case of positional parameter corresponding to current formal 1354 1355 elsif No (Selector_Name (Actual)) then 1356 Found_Assoc := Actual; 1357 Act := Explicit_Generic_Actual_Parameter (Actual); 1358 Num_Matched := Num_Matched + 1; 1359 Next (Actual); 1360 1361 -- Otherwise scan list of named actuals to find the one with the 1362 -- desired name. All remaining actuals have explicit names. 1363 1364 else 1365 Is_Named_Assoc := True; 1366 Found_Assoc := Empty; 1367 Act := Empty; 1368 Prev := Empty; 1369 1370 while Present (Actual) loop 1371 if Nkind (Actual) = N_Others_Choice then 1372 Found_Assoc := Empty; 1373 Act := Empty; 1374 1375 elsif Chars (Selector_Name (Actual)) = Chars (F) then 1376 Set_Entity (Selector_Name (Actual), A_F); 1377 Set_Etype (Selector_Name (Actual), Etype (A_F)); 1378 Generate_Reference (A_F, Selector_Name (Actual)); 1379 1380 Found_Assoc := Actual; 1381 Act := Explicit_Generic_Actual_Parameter (Actual); 1382 Num_Matched := Num_Matched + 1; 1383 exit; 1384 end if; 1385 1386 Prev := Actual; 1387 Next (Actual); 1388 end loop; 1389 1390 -- Reset for subsequent searches. In most cases the named 1391 -- associations are in order. If they are not, we reorder them 1392 -- to avoid scanning twice the same actual. This is not just a 1393 -- question of efficiency: there may be multiple defaults with 1394 -- boxes that have the same name. In a nested instantiation we 1395 -- insert actuals for those defaults, and cannot rely on their 1396 -- names to disambiguate them. 1397 1398 if Actual = First_Named then 1399 Next (First_Named); 1400 1401 elsif Present (Actual) then 1402 Insert_Before (First_Named, Remove_Next (Prev)); 1403 end if; 1404 1405 Actual := First_Named; 1406 end if; 1407 1408 if Is_Entity_Name (Act) and then Present (Entity (Act)) then 1409 Set_Used_As_Generic_Actual (Entity (Act)); 1410 end if; 1411 1412 return Act; 1413 end Matching_Actual; 1414 1415 ------------------------------ 1416 -- Partial_Parameterization -- 1417 ------------------------------ 1418 1419 function Partial_Parameterization return Boolean is 1420 begin 1421 return Others_Present 1422 or else (Present (Found_Assoc) and then Box_Present (Found_Assoc)); 1423 end Partial_Parameterization; 1424 1425 --------------------- 1426 -- Process_Default -- 1427 --------------------- 1428 1429 procedure Process_Default (F : Entity_Id) is 1430 Loc : constant Source_Ptr := Sloc (I_Node); 1431 F_Id : constant Entity_Id := Defining_Entity (F); 1432 Decl : Node_Id; 1433 Default : Node_Id; 1434 Id : Entity_Id; 1435 1436 begin 1437 -- Append copy of formal declaration to associations, and create new 1438 -- defining identifier for it. 1439 1440 Decl := New_Copy_Tree (F); 1441 Id := Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id)); 1442 1443 if Nkind (F) in N_Formal_Subprogram_Declaration then 1444 Set_Defining_Unit_Name (Specification (Decl), Id); 1445 1446 else 1447 Set_Defining_Identifier (Decl, Id); 1448 end if; 1449 1450 Append (Decl, Assoc_List); 1451 1452 if No (Found_Assoc) then 1453 Default := 1454 Make_Generic_Association (Loc, 1455 Selector_Name => 1456 New_Occurrence_Of (Id, Loc), 1457 Explicit_Generic_Actual_Parameter => Empty); 1458 Set_Box_Present (Default); 1459 Append (Default, Default_Formals); 1460 end if; 1461 end Process_Default; 1462 1463 --------------------------------- 1464 -- Renames_Standard_Subprogram -- 1465 --------------------------------- 1466 1467 function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean is 1468 Id : Entity_Id; 1469 1470 begin 1471 Id := Alias (Subp); 1472 while Present (Id) loop 1473 if Scope (Id) = Standard_Standard then 1474 return True; 1475 end if; 1476 1477 Id := Alias (Id); 1478 end loop; 1479 1480 return False; 1481 end Renames_Standard_Subprogram; 1482 1483 ------------------------- 1484 -- Set_Analyzed_Formal -- 1485 ------------------------- 1486 1487 procedure Set_Analyzed_Formal is 1488 Kind : Node_Kind; 1489 1490 begin 1491 while Present (Analyzed_Formal) loop 1492 Kind := Nkind (Analyzed_Formal); 1493 1494 case Nkind (Formal) is 1495 when N_Formal_Subprogram_Declaration => 1496 exit when Kind in N_Formal_Subprogram_Declaration 1497 and then 1498 Chars 1499 (Defining_Unit_Name (Specification (Formal))) = 1500 Chars 1501 (Defining_Unit_Name (Specification (Analyzed_Formal))); 1502 1503 when N_Formal_Package_Declaration => 1504 exit when Nkind_In (Kind, N_Formal_Package_Declaration, 1505 N_Generic_Package_Declaration, 1506 N_Package_Declaration); 1507 1508 when N_Use_Package_Clause 1509 | N_Use_Type_Clause 1510 => 1511 exit; 1512 1513 when others => 1514 1515 -- Skip freeze nodes, and nodes inserted to replace 1516 -- unrecognized pragmas. 1517 1518 exit when 1519 Kind not in N_Formal_Subprogram_Declaration 1520 and then not Nkind_In (Kind, N_Subprogram_Declaration, 1521 N_Freeze_Entity, 1522 N_Null_Statement, 1523 N_Itype_Reference) 1524 and then Chars (Defining_Identifier (Formal)) = 1525 Chars (Defining_Identifier (Analyzed_Formal)); 1526 end case; 1527 1528 Next (Analyzed_Formal); 1529 end loop; 1530 end Set_Analyzed_Formal; 1531 1532 -- Start of processing for Analyze_Associations 1533 1534 begin 1535 Actuals := Generic_Associations (I_Node); 1536 1537 if Present (Actuals) then 1538 1539 -- Check for an Others choice, indicating a partial parameterization 1540 -- for a formal package. 1541 1542 Actual := First (Actuals); 1543 while Present (Actual) loop 1544 if Nkind (Actual) = N_Others_Choice then 1545 Others_Present := True; 1546 Others_Choice := Actual; 1547 1548 if Present (Next (Actual)) then 1549 Error_Msg_N ("others must be last association", Actual); 1550 end if; 1551 1552 -- This subprogram is used both for formal packages and for 1553 -- instantiations. For the latter, associations must all be 1554 -- explicit. 1555 1556 if Nkind (I_Node) /= N_Formal_Package_Declaration 1557 and then Comes_From_Source (I_Node) 1558 then 1559 Error_Msg_N 1560 ("others association not allowed in an instance", 1561 Actual); 1562 end if; 1563 1564 -- In any case, nothing to do after the others association 1565 1566 exit; 1567 1568 elsif Box_Present (Actual) 1569 and then Comes_From_Source (I_Node) 1570 and then Nkind (I_Node) /= N_Formal_Package_Declaration 1571 then 1572 Error_Msg_N 1573 ("box association not allowed in an instance", Actual); 1574 end if; 1575 1576 Next (Actual); 1577 end loop; 1578 1579 -- If named associations are present, save first named association 1580 -- (it may of course be Empty) to facilitate subsequent name search. 1581 1582 First_Named := First (Actuals); 1583 while Present (First_Named) 1584 and then Nkind (First_Named) /= N_Others_Choice 1585 and then No (Selector_Name (First_Named)) 1586 loop 1587 Num_Actuals := Num_Actuals + 1; 1588 Next (First_Named); 1589 end loop; 1590 end if; 1591 1592 Named := First_Named; 1593 while Present (Named) loop 1594 if Nkind (Named) /= N_Others_Choice 1595 and then No (Selector_Name (Named)) 1596 then 1597 Error_Msg_N ("invalid positional actual after named one", Named); 1598 Abandon_Instantiation (Named); 1599 end if; 1600 1601 -- A named association may lack an actual parameter, if it was 1602 -- introduced for a default subprogram that turns out to be local 1603 -- to the outer instantiation. If it has a box association it must 1604 -- correspond to some formal in the generic. 1605 1606 if Nkind (Named) /= N_Others_Choice 1607 and then (Present (Explicit_Generic_Actual_Parameter (Named)) 1608 or else Box_Present (Named)) 1609 then 1610 Num_Actuals := Num_Actuals + 1; 1611 end if; 1612 1613 Next (Named); 1614 end loop; 1615 1616 if Present (Formals) then 1617 Formal := First_Non_Pragma (Formals); 1618 Analyzed_Formal := First_Non_Pragma (F_Copy); 1619 1620 if Present (Actuals) then 1621 Actual := First (Actuals); 1622 1623 -- All formals should have default values 1624 1625 else 1626 Actual := Empty; 1627 end if; 1628 1629 while Present (Formal) loop 1630 Set_Analyzed_Formal; 1631 Saved_Formal := Next_Non_Pragma (Formal); 1632 1633 case Nkind (Formal) is 1634 when N_Formal_Object_Declaration => 1635 Match := 1636 Matching_Actual 1637 (Defining_Identifier (Formal), 1638 Defining_Identifier (Analyzed_Formal)); 1639 1640 if No (Match) and then Partial_Parameterization then 1641 Process_Default (Formal); 1642 1643 else 1644 Append_List 1645 (Instantiate_Object (Formal, Match, Analyzed_Formal), 1646 Assoc_List); 1647 1648 -- For a defaulted in_parameter, create an entry in the 1649 -- the list of defaulted actuals, for GNATProve use. Do 1650 -- not included these defaults for an instance nested 1651 -- within a generic, because the defaults are also used 1652 -- in the analysis of the enclosing generic, and only 1653 -- defaulted subprograms are relevant there. 1654 1655 if No (Match) and then not Inside_A_Generic then 1656 Append_To (Default_Actuals, 1657 Make_Generic_Association (Sloc (I_Node), 1658 Selector_Name => 1659 New_Occurrence_Of 1660 (Defining_Identifier (Formal), Sloc (I_Node)), 1661 Explicit_Generic_Actual_Parameter => 1662 New_Copy_Tree (Default_Expression (Formal)))); 1663 end if; 1664 end if; 1665 1666 -- If the object is a call to an expression function, this 1667 -- is a freezing point for it. 1668 1669 if Is_Entity_Name (Match) 1670 and then Present (Entity (Match)) 1671 and then Nkind 1672 (Original_Node (Unit_Declaration_Node (Entity (Match)))) 1673 = N_Expression_Function 1674 then 1675 Append_Elmt (Entity (Match), Actuals_To_Freeze); 1676 end if; 1677 1678 when N_Formal_Type_Declaration => 1679 Match := 1680 Matching_Actual 1681 (Defining_Identifier (Formal), 1682 Defining_Identifier (Analyzed_Formal)); 1683 1684 if No (Match) then 1685 if Partial_Parameterization then 1686 Process_Default (Formal); 1687 1688 else 1689 Error_Msg_Sloc := Sloc (Gen_Unit); 1690 Error_Msg_NE 1691 ("missing actual&", 1692 Instantiation_Node, Defining_Identifier (Formal)); 1693 Error_Msg_NE 1694 ("\in instantiation of & declared#", 1695 Instantiation_Node, Gen_Unit); 1696 Abandon_Instantiation (Instantiation_Node); 1697 end if; 1698 1699 else 1700 Analyze (Match); 1701 Append_List 1702 (Instantiate_Type 1703 (Formal, Match, Analyzed_Formal, Assoc_List), 1704 Assoc_List); 1705 1706 -- Warn when an actual is a fixed-point with user- 1707 -- defined promitives. The warning is superfluous 1708 -- if the fornal is private, because there can be 1709 -- no arithmetic operations in the generic so there 1710 -- no danger of confusion. 1711 1712 if Is_Fixed_Point_Type (Entity (Match)) 1713 and then not Is_Private_Type 1714 (Defining_Identifier (Analyzed_Formal)) 1715 then 1716 Check_Fixed_Point_Actual (Match); 1717 end if; 1718 1719 -- An instantiation is a freeze point for the actuals, 1720 -- unless this is a rewritten formal package, or the 1721 -- formal is an Ada 2012 formal incomplete type. 1722 1723 if Nkind (I_Node) = N_Formal_Package_Declaration 1724 or else 1725 (Ada_Version >= Ada_2012 1726 and then 1727 Ekind (Defining_Identifier (Analyzed_Formal)) = 1728 E_Incomplete_Type) 1729 then 1730 null; 1731 1732 else 1733 Append_Elmt (Entity (Match), Actuals_To_Freeze); 1734 end if; 1735 end if; 1736 1737 -- A remote access-to-class-wide type is not a legal actual 1738 -- for a generic formal of an access type (E.2.2(17/2)). 1739 -- In GNAT an exception to this rule is introduced when 1740 -- the formal is marked as remote using implementation 1741 -- defined aspect/pragma Remote_Access_Type. In that case 1742 -- the actual must be remote as well. 1743 1744 -- If the current instantiation is the construction of a 1745 -- local copy for a formal package the actuals may be 1746 -- defaulted, and there is no matching actual to check. 1747 1748 if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration 1749 and then 1750 Nkind (Formal_Type_Definition (Analyzed_Formal)) = 1751 N_Access_To_Object_Definition 1752 and then Present (Match) 1753 then 1754 declare 1755 Formal_Ent : constant Entity_Id := 1756 Defining_Identifier (Analyzed_Formal); 1757 begin 1758 if Is_Remote_Access_To_Class_Wide_Type (Entity (Match)) 1759 = Is_Remote_Types (Formal_Ent) 1760 then 1761 -- Remoteness of formal and actual match 1762 1763 null; 1764 1765 elsif Is_Remote_Types (Formal_Ent) then 1766 1767 -- Remote formal, non-remote actual 1768 1769 Error_Msg_NE 1770 ("actual for& must be remote", Match, Formal_Ent); 1771 1772 else 1773 -- Non-remote formal, remote actual 1774 1775 Error_Msg_NE 1776 ("actual for& may not be remote", 1777 Match, Formal_Ent); 1778 end if; 1779 end; 1780 end if; 1781 1782 when N_Formal_Subprogram_Declaration => 1783 Match := 1784 Matching_Actual 1785 (Defining_Unit_Name (Specification (Formal)), 1786 Defining_Unit_Name (Specification (Analyzed_Formal))); 1787 1788 -- If the formal subprogram has the same name as another 1789 -- formal subprogram of the generic, then a named 1790 -- association is illegal (12.3(9)). Exclude named 1791 -- associations that are generated for a nested instance. 1792 1793 if Present (Match) 1794 and then Is_Named_Assoc 1795 and then Comes_From_Source (Found_Assoc) 1796 then 1797 Check_Overloaded_Formal_Subprogram (Formal); 1798 end if; 1799 1800 -- If there is no corresponding actual, this may be case 1801 -- of partial parameterization, or else the formal has a 1802 -- default or a box. 1803 1804 if No (Match) and then Partial_Parameterization then 1805 Process_Default (Formal); 1806 1807 if Nkind (I_Node) = N_Formal_Package_Declaration then 1808 Check_Overloaded_Formal_Subprogram (Formal); 1809 end if; 1810 1811 else 1812 Append_To (Assoc_List, 1813 Instantiate_Formal_Subprogram 1814 (Formal, Match, Analyzed_Formal)); 1815 1816 -- An instantiation is a freeze point for the actuals, 1817 -- unless this is a rewritten formal package. 1818 1819 if Nkind (I_Node) /= N_Formal_Package_Declaration 1820 and then Nkind (Match) = N_Identifier 1821 and then Is_Subprogram (Entity (Match)) 1822 1823 -- The actual subprogram may rename a routine defined 1824 -- in Standard. Avoid freezing such renamings because 1825 -- subprograms coming from Standard cannot be frozen. 1826 1827 and then 1828 not Renames_Standard_Subprogram (Entity (Match)) 1829 1830 -- If the actual subprogram comes from a different 1831 -- unit, it is already frozen, either by a body in 1832 -- that unit or by the end of the declarative part 1833 -- of the unit. This check avoids the freezing of 1834 -- subprograms defined in Standard which are used 1835 -- as generic actuals. 1836 1837 and then In_Same_Code_Unit (Entity (Match), I_Node) 1838 and then Has_Fully_Defined_Profile (Entity (Match)) 1839 then 1840 -- Mark the subprogram as having a delayed freeze 1841 -- since this may be an out-of-order action. 1842 1843 Set_Has_Delayed_Freeze (Entity (Match)); 1844 Append_Elmt (Entity (Match), Actuals_To_Freeze); 1845 end if; 1846 end if; 1847 1848 -- If this is a nested generic, preserve default for later 1849 -- instantiations. We do this as well for GNATProve use, 1850 -- so that the list of generic associations is complete. 1851 1852 if No (Match) and then Box_Present (Formal) then 1853 declare 1854 Subp : constant Entity_Id := 1855 Defining_Unit_Name 1856 (Specification (Last (Assoc_List))); 1857 1858 begin 1859 Append_To (Default_Actuals, 1860 Make_Generic_Association (Sloc (I_Node), 1861 Selector_Name => 1862 New_Occurrence_Of (Subp, Sloc (I_Node)), 1863 Explicit_Generic_Actual_Parameter => 1864 New_Occurrence_Of (Subp, Sloc (I_Node)))); 1865 end; 1866 end if; 1867 1868 when N_Formal_Package_Declaration => 1869 Match := 1870 Matching_Actual 1871 (Defining_Identifier (Formal), 1872 Defining_Identifier (Original_Node (Analyzed_Formal))); 1873 1874 if No (Match) then 1875 if Partial_Parameterization then 1876 Process_Default (Formal); 1877 1878 else 1879 Error_Msg_Sloc := Sloc (Gen_Unit); 1880 Error_Msg_NE 1881 ("missing actual&", 1882 Instantiation_Node, Defining_Identifier (Formal)); 1883 Error_Msg_NE 1884 ("\in instantiation of & declared#", 1885 Instantiation_Node, Gen_Unit); 1886 1887 Abandon_Instantiation (Instantiation_Node); 1888 end if; 1889 1890 else 1891 Analyze (Match); 1892 Append_List 1893 (Instantiate_Formal_Package 1894 (Formal, Match, Analyzed_Formal), 1895 Assoc_List); 1896 1897 -- Determine whether the actual package needs an explicit 1898 -- freeze node. This is only the case if the actual is 1899 -- declared in the same unit and has a body. Normally 1900 -- packages do not have explicit freeze nodes, and gigi 1901 -- only uses them to elaborate entities in a package 1902 -- body. 1903 1904 Explicit_Freeze_Check : declare 1905 Actual : constant Entity_Id := Entity (Match); 1906 Gen_Par : Entity_Id; 1907 1908 Needs_Freezing : Boolean; 1909 S : Entity_Id; 1910 1911 procedure Check_Generic_Parent; 1912 -- The actual may be an instantiation of a unit 1913 -- declared in a previous instantiation. If that 1914 -- one is also in the current compilation, it must 1915 -- itself be frozen before the actual. The actual 1916 -- may be an instantiation of a generic child unit, 1917 -- in which case the same applies to the instance 1918 -- of the parent which must be frozen before the 1919 -- actual. 1920 -- Should this itself be recursive ??? 1921 1922 -------------------------- 1923 -- Check_Generic_Parent -- 1924 -------------------------- 1925 1926 procedure Check_Generic_Parent is 1927 Inst : constant Node_Id := 1928 Next (Unit_Declaration_Node (Actual)); 1929 Par : Entity_Id; 1930 1931 begin 1932 Par := Empty; 1933 1934 if Nkind (Parent (Actual)) = N_Package_Specification 1935 then 1936 Par := Scope (Generic_Parent (Parent (Actual))); 1937 1938 if Is_Generic_Instance (Par) then 1939 null; 1940 1941 -- If the actual is a child generic unit, check 1942 -- whether the instantiation of the parent is 1943 -- also local and must also be frozen now. We 1944 -- must retrieve the instance node to locate the 1945 -- parent instance if any. 1946 1947 elsif Ekind (Par) = E_Generic_Package 1948 and then Is_Child_Unit (Gen_Par) 1949 and then Ekind (Scope (Gen_Par)) = 1950 E_Generic_Package 1951 then 1952 if Nkind (Inst) = N_Package_Instantiation 1953 and then Nkind (Name (Inst)) = 1954 N_Expanded_Name 1955 then 1956 -- Retrieve entity of parent instance 1957 1958 Par := Entity (Prefix (Name (Inst))); 1959 end if; 1960 1961 else 1962 Par := Empty; 1963 end if; 1964 end if; 1965 1966 if Present (Par) 1967 and then Is_Generic_Instance (Par) 1968 and then Scope (Par) = Current_Scope 1969 and then 1970 (No (Freeze_Node (Par)) 1971 or else 1972 not Is_List_Member (Freeze_Node (Par))) 1973 then 1974 Set_Has_Delayed_Freeze (Par); 1975 Append_Elmt (Par, Actuals_To_Freeze); 1976 end if; 1977 end Check_Generic_Parent; 1978 1979 -- Start of processing for Explicit_Freeze_Check 1980 1981 begin 1982 if Present (Renamed_Entity (Actual)) then 1983 Gen_Par := 1984 Generic_Parent (Specification 1985 (Unit_Declaration_Node 1986 (Renamed_Entity (Actual)))); 1987 else 1988 Gen_Par := 1989 Generic_Parent (Specification 1990 (Unit_Declaration_Node (Actual))); 1991 end if; 1992 1993 if not Expander_Active 1994 or else not Has_Completion (Actual) 1995 or else not In_Same_Source_Unit (I_Node, Actual) 1996 or else Is_Frozen (Actual) 1997 or else 1998 (Present (Renamed_Entity (Actual)) 1999 and then 2000 not In_Same_Source_Unit 2001 (I_Node, (Renamed_Entity (Actual)))) 2002 then 2003 null; 2004 2005 else 2006 -- Finally we want to exclude such freeze nodes 2007 -- from statement sequences, which freeze 2008 -- everything before them. 2009 -- Is this strictly necessary ??? 2010 2011 Needs_Freezing := True; 2012 2013 S := Current_Scope; 2014 while Present (S) loop 2015 if Ekind_In (S, E_Block, 2016 E_Function, 2017 E_Loop, 2018 E_Procedure) 2019 then 2020 Needs_Freezing := False; 2021 exit; 2022 end if; 2023 2024 S := Scope (S); 2025 end loop; 2026 2027 if Needs_Freezing then 2028 Check_Generic_Parent; 2029 2030 -- If the actual is a renaming of a proper 2031 -- instance of the formal package, indicate 2032 -- that it is the instance that must be frozen. 2033 2034 if Nkind (Parent (Actual)) = 2035 N_Package_Renaming_Declaration 2036 then 2037 Set_Has_Delayed_Freeze 2038 (Renamed_Entity (Actual)); 2039 Append_Elmt 2040 (Renamed_Entity (Actual), 2041 Actuals_To_Freeze); 2042 else 2043 Set_Has_Delayed_Freeze (Actual); 2044 Append_Elmt (Actual, Actuals_To_Freeze); 2045 end if; 2046 end if; 2047 end if; 2048 end Explicit_Freeze_Check; 2049 end if; 2050 2051 -- For use type and use package appearing in the generic part, 2052 -- we have already copied them, so we can just move them where 2053 -- they belong (we mustn't recopy them since this would mess up 2054 -- the Sloc values). 2055 2056 when N_Use_Package_Clause 2057 | N_Use_Type_Clause 2058 => 2059 if Nkind (Original_Node (I_Node)) = 2060 N_Formal_Package_Declaration 2061 then 2062 Append (New_Copy_Tree (Formal), Assoc_List); 2063 else 2064 Remove (Formal); 2065 Append (Formal, Assoc_List); 2066 end if; 2067 2068 when others => 2069 raise Program_Error; 2070 end case; 2071 2072 Formal := Saved_Formal; 2073 Next_Non_Pragma (Analyzed_Formal); 2074 end loop; 2075 2076 if Num_Actuals > Num_Matched then 2077 Error_Msg_Sloc := Sloc (Gen_Unit); 2078 2079 if Present (Selector_Name (Actual)) then 2080 Error_Msg_NE 2081 ("unmatched actual &", Actual, Selector_Name (Actual)); 2082 Error_Msg_NE 2083 ("\in instantiation of & declared#", Actual, Gen_Unit); 2084 else 2085 Error_Msg_NE 2086 ("unmatched actual in instantiation of & declared#", 2087 Actual, Gen_Unit); 2088 end if; 2089 end if; 2090 2091 elsif Present (Actuals) then 2092 Error_Msg_N 2093 ("too many actuals in generic instantiation", Instantiation_Node); 2094 end if; 2095 2096 -- An instantiation freezes all generic actuals. The only exceptions 2097 -- to this are incomplete types and subprograms which are not fully 2098 -- defined at the point of instantiation. 2099 2100 declare 2101 Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze); 2102 begin 2103 while Present (Elmt) loop 2104 Freeze_Before (I_Node, Node (Elmt)); 2105 Next_Elmt (Elmt); 2106 end loop; 2107 end; 2108 2109 -- If there are default subprograms, normalize the tree by adding 2110 -- explicit associations for them. This is required if the instance 2111 -- appears within a generic. 2112 2113 if not Is_Empty_List (Default_Actuals) then 2114 declare 2115 Default : Node_Id; 2116 2117 begin 2118 Default := First (Default_Actuals); 2119 while Present (Default) loop 2120 Mark_Rewrite_Insertion (Default); 2121 Next (Default); 2122 end loop; 2123 2124 if No (Actuals) then 2125 Set_Generic_Associations (I_Node, Default_Actuals); 2126 else 2127 Append_List_To (Actuals, Default_Actuals); 2128 end if; 2129 end; 2130 end if; 2131 2132 -- If this is a formal package, normalize the parameter list by adding 2133 -- explicit box associations for the formals that are covered by an 2134 -- Others_Choice. 2135 2136 if not Is_Empty_List (Default_Formals) then 2137 Append_List (Default_Formals, Formals); 2138 end if; 2139 2140 return Assoc_List; 2141 end Analyze_Associations; 2142 2143 ------------------------------- 2144 -- Analyze_Formal_Array_Type -- 2145 ------------------------------- 2146 2147 procedure Analyze_Formal_Array_Type 2148 (T : in out Entity_Id; 2149 Def : Node_Id) 2150 is 2151 DSS : Node_Id; 2152 2153 begin 2154 -- Treated like a non-generic array declaration, with additional 2155 -- semantic checks. 2156 2157 Enter_Name (T); 2158 2159 if Nkind (Def) = N_Constrained_Array_Definition then 2160 DSS := First (Discrete_Subtype_Definitions (Def)); 2161 while Present (DSS) loop 2162 if Nkind_In (DSS, N_Subtype_Indication, 2163 N_Range, 2164 N_Attribute_Reference) 2165 then 2166 Error_Msg_N ("only a subtype mark is allowed in a formal", DSS); 2167 end if; 2168 2169 Next (DSS); 2170 end loop; 2171 end if; 2172 2173 Array_Type_Declaration (T, Def); 2174 Set_Is_Generic_Type (Base_Type (T)); 2175 2176 if Ekind (Component_Type (T)) = E_Incomplete_Type 2177 and then No (Full_View (Component_Type (T))) 2178 then 2179 Error_Msg_N ("premature usage of incomplete type", Def); 2180 2181 -- Check that range constraint is not allowed on the component type 2182 -- of a generic formal array type (AARM 12.5.3(3)) 2183 2184 elsif Is_Internal (Component_Type (T)) 2185 and then Present (Subtype_Indication (Component_Definition (Def))) 2186 and then Nkind (Original_Node 2187 (Subtype_Indication (Component_Definition (Def)))) = 2188 N_Subtype_Indication 2189 then 2190 Error_Msg_N 2191 ("in a formal, a subtype indication can only be " 2192 & "a subtype mark (RM 12.5.3(3))", 2193 Subtype_Indication (Component_Definition (Def))); 2194 end if; 2195 2196 end Analyze_Formal_Array_Type; 2197 2198 --------------------------------------------- 2199 -- Analyze_Formal_Decimal_Fixed_Point_Type -- 2200 --------------------------------------------- 2201 2202 -- As for other generic types, we create a valid type representation with 2203 -- legal but arbitrary attributes, whose values are never considered 2204 -- static. For all scalar types we introduce an anonymous base type, with 2205 -- the same attributes. We choose the corresponding integer type to be 2206 -- Standard_Integer. 2207 -- Here and in other similar routines, the Sloc of the generated internal 2208 -- type must be the same as the sloc of the defining identifier of the 2209 -- formal type declaration, to provide proper source navigation. 2210 2211 procedure Analyze_Formal_Decimal_Fixed_Point_Type 2212 (T : Entity_Id; 2213 Def : Node_Id) 2214 is 2215 Loc : constant Source_Ptr := Sloc (Def); 2216 2217 Base : constant Entity_Id := 2218 New_Internal_Entity 2219 (E_Decimal_Fixed_Point_Type, 2220 Current_Scope, 2221 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2222 2223 Int_Base : constant Entity_Id := Standard_Integer; 2224 Delta_Val : constant Ureal := Ureal_1; 2225 Digs_Val : constant Uint := Uint_6; 2226 2227 function Make_Dummy_Bound return Node_Id; 2228 -- Return a properly typed universal real literal to use as a bound 2229 2230 ---------------------- 2231 -- Make_Dummy_Bound -- 2232 ---------------------- 2233 2234 function Make_Dummy_Bound return Node_Id is 2235 Bound : constant Node_Id := Make_Real_Literal (Loc, Ureal_1); 2236 begin 2237 Set_Etype (Bound, Universal_Real); 2238 return Bound; 2239 end Make_Dummy_Bound; 2240 2241 -- Start of processing for Analyze_Formal_Decimal_Fixed_Point_Type 2242 2243 begin 2244 Enter_Name (T); 2245 2246 Set_Etype (Base, Base); 2247 Set_Size_Info (Base, Int_Base); 2248 Set_RM_Size (Base, RM_Size (Int_Base)); 2249 Set_First_Rep_Item (Base, First_Rep_Item (Int_Base)); 2250 Set_Digits_Value (Base, Digs_Val); 2251 Set_Delta_Value (Base, Delta_Val); 2252 Set_Small_Value (Base, Delta_Val); 2253 Set_Scalar_Range (Base, 2254 Make_Range (Loc, 2255 Low_Bound => Make_Dummy_Bound, 2256 High_Bound => Make_Dummy_Bound)); 2257 2258 Set_Is_Generic_Type (Base); 2259 Set_Parent (Base, Parent (Def)); 2260 2261 Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); 2262 Set_Etype (T, Base); 2263 Set_Size_Info (T, Int_Base); 2264 Set_RM_Size (T, RM_Size (Int_Base)); 2265 Set_First_Rep_Item (T, First_Rep_Item (Int_Base)); 2266 Set_Digits_Value (T, Digs_Val); 2267 Set_Delta_Value (T, Delta_Val); 2268 Set_Small_Value (T, Delta_Val); 2269 Set_Scalar_Range (T, Scalar_Range (Base)); 2270 Set_Is_Constrained (T); 2271 2272 Check_Restriction (No_Fixed_Point, Def); 2273 end Analyze_Formal_Decimal_Fixed_Point_Type; 2274 2275 ------------------------------------------- 2276 -- Analyze_Formal_Derived_Interface_Type -- 2277 ------------------------------------------- 2278 2279 procedure Analyze_Formal_Derived_Interface_Type 2280 (N : Node_Id; 2281 T : Entity_Id; 2282 Def : Node_Id) 2283 is 2284 Loc : constant Source_Ptr := Sloc (Def); 2285 2286 begin 2287 -- Rewrite as a type declaration of a derived type. This ensures that 2288 -- the interface list and primitive operations are properly captured. 2289 2290 Rewrite (N, 2291 Make_Full_Type_Declaration (Loc, 2292 Defining_Identifier => T, 2293 Type_Definition => Def)); 2294 Analyze (N); 2295 Set_Is_Generic_Type (T); 2296 end Analyze_Formal_Derived_Interface_Type; 2297 2298 --------------------------------- 2299 -- Analyze_Formal_Derived_Type -- 2300 --------------------------------- 2301 2302 procedure Analyze_Formal_Derived_Type 2303 (N : Node_Id; 2304 T : Entity_Id; 2305 Def : Node_Id) 2306 is 2307 Loc : constant Source_Ptr := Sloc (Def); 2308 Unk_Disc : constant Boolean := Unknown_Discriminants_Present (N); 2309 New_N : Node_Id; 2310 2311 begin 2312 Set_Is_Generic_Type (T); 2313 2314 if Private_Present (Def) then 2315 New_N := 2316 Make_Private_Extension_Declaration (Loc, 2317 Defining_Identifier => T, 2318 Discriminant_Specifications => Discriminant_Specifications (N), 2319 Unknown_Discriminants_Present => Unk_Disc, 2320 Subtype_Indication => Subtype_Mark (Def), 2321 Interface_List => Interface_List (Def)); 2322 2323 Set_Abstract_Present (New_N, Abstract_Present (Def)); 2324 Set_Limited_Present (New_N, Limited_Present (Def)); 2325 Set_Synchronized_Present (New_N, Synchronized_Present (Def)); 2326 2327 else 2328 New_N := 2329 Make_Full_Type_Declaration (Loc, 2330 Defining_Identifier => T, 2331 Discriminant_Specifications => 2332 Discriminant_Specifications (Parent (T)), 2333 Type_Definition => 2334 Make_Derived_Type_Definition (Loc, 2335 Subtype_Indication => Subtype_Mark (Def))); 2336 2337 Set_Abstract_Present 2338 (Type_Definition (New_N), Abstract_Present (Def)); 2339 Set_Limited_Present 2340 (Type_Definition (New_N), Limited_Present (Def)); 2341 end if; 2342 2343 Rewrite (N, New_N); 2344 Analyze (N); 2345 2346 if Unk_Disc then 2347 if not Is_Composite_Type (T) then 2348 Error_Msg_N 2349 ("unknown discriminants not allowed for elementary types", N); 2350 else 2351 Set_Has_Unknown_Discriminants (T); 2352 Set_Is_Constrained (T, False); 2353 end if; 2354 end if; 2355 2356 -- If the parent type has a known size, so does the formal, which makes 2357 -- legal representation clauses that involve the formal. 2358 2359 Set_Size_Known_At_Compile_Time 2360 (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def)))); 2361 end Analyze_Formal_Derived_Type; 2362 2363 ---------------------------------- 2364 -- Analyze_Formal_Discrete_Type -- 2365 ---------------------------------- 2366 2367 -- The operations defined for a discrete types are those of an enumeration 2368 -- type. The size is set to an arbitrary value, for use in analyzing the 2369 -- generic unit. 2370 2371 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id) is 2372 Loc : constant Source_Ptr := Sloc (Def); 2373 Lo : Node_Id; 2374 Hi : Node_Id; 2375 2376 Base : constant Entity_Id := 2377 New_Internal_Entity 2378 (E_Floating_Point_Type, Current_Scope, 2379 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2380 2381 begin 2382 Enter_Name (T); 2383 Set_Ekind (T, E_Enumeration_Subtype); 2384 Set_Etype (T, Base); 2385 Init_Size (T, 8); 2386 Init_Alignment (T); 2387 Set_Is_Generic_Type (T); 2388 Set_Is_Constrained (T); 2389 2390 -- For semantic analysis, the bounds of the type must be set to some 2391 -- non-static value. The simplest is to create attribute nodes for those 2392 -- bounds, that refer to the type itself. These bounds are never 2393 -- analyzed but serve as place-holders. 2394 2395 Lo := 2396 Make_Attribute_Reference (Loc, 2397 Attribute_Name => Name_First, 2398 Prefix => New_Occurrence_Of (T, Loc)); 2399 Set_Etype (Lo, T); 2400 2401 Hi := 2402 Make_Attribute_Reference (Loc, 2403 Attribute_Name => Name_Last, 2404 Prefix => New_Occurrence_Of (T, Loc)); 2405 Set_Etype (Hi, T); 2406 2407 Set_Scalar_Range (T, 2408 Make_Range (Loc, 2409 Low_Bound => Lo, 2410 High_Bound => Hi)); 2411 2412 Set_Ekind (Base, E_Enumeration_Type); 2413 Set_Etype (Base, Base); 2414 Init_Size (Base, 8); 2415 Init_Alignment (Base); 2416 Set_Is_Generic_Type (Base); 2417 Set_Scalar_Range (Base, Scalar_Range (T)); 2418 Set_Parent (Base, Parent (Def)); 2419 end Analyze_Formal_Discrete_Type; 2420 2421 ---------------------------------- 2422 -- Analyze_Formal_Floating_Type -- 2423 --------------------------------- 2424 2425 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is 2426 Base : constant Entity_Id := 2427 New_Internal_Entity 2428 (E_Floating_Point_Type, Current_Scope, 2429 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2430 2431 begin 2432 -- The various semantic attributes are taken from the predefined type 2433 -- Float, just so that all of them are initialized. Their values are 2434 -- never used because no constant folding or expansion takes place in 2435 -- the generic itself. 2436 2437 Enter_Name (T); 2438 Set_Ekind (T, E_Floating_Point_Subtype); 2439 Set_Etype (T, Base); 2440 Set_Size_Info (T, (Standard_Float)); 2441 Set_RM_Size (T, RM_Size (Standard_Float)); 2442 Set_Digits_Value (T, Digits_Value (Standard_Float)); 2443 Set_Scalar_Range (T, Scalar_Range (Standard_Float)); 2444 Set_Is_Constrained (T); 2445 2446 Set_Is_Generic_Type (Base); 2447 Set_Etype (Base, Base); 2448 Set_Size_Info (Base, (Standard_Float)); 2449 Set_RM_Size (Base, RM_Size (Standard_Float)); 2450 Set_Digits_Value (Base, Digits_Value (Standard_Float)); 2451 Set_Scalar_Range (Base, Scalar_Range (Standard_Float)); 2452 Set_Parent (Base, Parent (Def)); 2453 2454 Check_Restriction (No_Floating_Point, Def); 2455 end Analyze_Formal_Floating_Type; 2456 2457 ----------------------------------- 2458 -- Analyze_Formal_Interface_Type;-- 2459 ----------------------------------- 2460 2461 procedure Analyze_Formal_Interface_Type 2462 (N : Node_Id; 2463 T : Entity_Id; 2464 Def : Node_Id) 2465 is 2466 Loc : constant Source_Ptr := Sloc (N); 2467 New_N : Node_Id; 2468 2469 begin 2470 New_N := 2471 Make_Full_Type_Declaration (Loc, 2472 Defining_Identifier => T, 2473 Type_Definition => Def); 2474 2475 Rewrite (N, New_N); 2476 Analyze (N); 2477 Set_Is_Generic_Type (T); 2478 end Analyze_Formal_Interface_Type; 2479 2480 --------------------------------- 2481 -- Analyze_Formal_Modular_Type -- 2482 --------------------------------- 2483 2484 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id) is 2485 begin 2486 -- Apart from their entity kind, generic modular types are treated like 2487 -- signed integer types, and have the same attributes. 2488 2489 Analyze_Formal_Signed_Integer_Type (T, Def); 2490 Set_Ekind (T, E_Modular_Integer_Subtype); 2491 Set_Ekind (Etype (T), E_Modular_Integer_Type); 2492 2493 end Analyze_Formal_Modular_Type; 2494 2495 --------------------------------------- 2496 -- Analyze_Formal_Object_Declaration -- 2497 --------------------------------------- 2498 2499 procedure Analyze_Formal_Object_Declaration (N : Node_Id) is 2500 E : constant Node_Id := Default_Expression (N); 2501 Id : constant Node_Id := Defining_Identifier (N); 2502 K : Entity_Kind; 2503 T : Node_Id; 2504 2505 begin 2506 Enter_Name (Id); 2507 2508 -- Determine the mode of the formal object 2509 2510 if Out_Present (N) then 2511 K := E_Generic_In_Out_Parameter; 2512 2513 if not In_Present (N) then 2514 Error_Msg_N ("formal generic objects cannot have mode OUT", N); 2515 end if; 2516 2517 else 2518 K := E_Generic_In_Parameter; 2519 end if; 2520 2521 if Present (Subtype_Mark (N)) then 2522 Find_Type (Subtype_Mark (N)); 2523 T := Entity (Subtype_Mark (N)); 2524 2525 -- Verify that there is no redundant null exclusion 2526 2527 if Null_Exclusion_Present (N) then 2528 if not Is_Access_Type (T) then 2529 Error_Msg_N 2530 ("null exclusion can only apply to an access type", N); 2531 2532 elsif Can_Never_Be_Null (T) then 2533 Error_Msg_NE 2534 ("`NOT NULL` not allowed (& already excludes null)", N, T); 2535 end if; 2536 end if; 2537 2538 -- Ada 2005 (AI-423): Formal object with an access definition 2539 2540 else 2541 Check_Access_Definition (N); 2542 T := Access_Definition 2543 (Related_Nod => N, 2544 N => Access_Definition (N)); 2545 end if; 2546 2547 if Ekind (T) = E_Incomplete_Type then 2548 declare 2549 Error_Node : Node_Id; 2550 2551 begin 2552 if Present (Subtype_Mark (N)) then 2553 Error_Node := Subtype_Mark (N); 2554 else 2555 Check_Access_Definition (N); 2556 Error_Node := Access_Definition (N); 2557 end if; 2558 2559 Error_Msg_N ("premature usage of incomplete type", Error_Node); 2560 end; 2561 end if; 2562 2563 if K = E_Generic_In_Parameter then 2564 2565 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals 2566 2567 if Ada_Version < Ada_2005 and then Is_Limited_Type (T) then 2568 Error_Msg_N 2569 ("generic formal of mode IN must not be of limited type", N); 2570 Explain_Limited_Type (T, N); 2571 end if; 2572 2573 if Is_Abstract_Type (T) then 2574 Error_Msg_N 2575 ("generic formal of mode IN must not be of abstract type", N); 2576 end if; 2577 2578 if Present (E) then 2579 Preanalyze_Spec_Expression (E, T); 2580 2581 if Is_Limited_Type (T) and then not OK_For_Limited_Init (T, E) then 2582 Error_Msg_N 2583 ("initialization not allowed for limited types", E); 2584 Explain_Limited_Type (T, E); 2585 end if; 2586 end if; 2587 2588 Set_Ekind (Id, K); 2589 Set_Etype (Id, T); 2590 2591 -- Case of generic IN OUT parameter 2592 2593 else 2594 -- If the formal has an unconstrained type, construct its actual 2595 -- subtype, as is done for subprogram formals. In this fashion, all 2596 -- its uses can refer to specific bounds. 2597 2598 Set_Ekind (Id, K); 2599 Set_Etype (Id, T); 2600 2601 if (Is_Array_Type (T) and then not Is_Constrained (T)) 2602 or else (Ekind (T) = E_Record_Type and then Has_Discriminants (T)) 2603 then 2604 declare 2605 Non_Freezing_Ref : constant Node_Id := 2606 New_Occurrence_Of (Id, Sloc (Id)); 2607 Decl : Node_Id; 2608 2609 begin 2610 -- Make sure the actual subtype doesn't generate bogus freezing 2611 2612 Set_Must_Not_Freeze (Non_Freezing_Ref); 2613 Decl := Build_Actual_Subtype (T, Non_Freezing_Ref); 2614 Insert_Before_And_Analyze (N, Decl); 2615 Set_Actual_Subtype (Id, Defining_Identifier (Decl)); 2616 end; 2617 else 2618 Set_Actual_Subtype (Id, T); 2619 end if; 2620 2621 if Present (E) then 2622 Error_Msg_N 2623 ("initialization not allowed for `IN OUT` formals", N); 2624 end if; 2625 end if; 2626 2627 if Has_Aspects (N) then 2628 Analyze_Aspect_Specifications (N, Id); 2629 end if; 2630 end Analyze_Formal_Object_Declaration; 2631 2632 ---------------------------------------------- 2633 -- Analyze_Formal_Ordinary_Fixed_Point_Type -- 2634 ---------------------------------------------- 2635 2636 procedure Analyze_Formal_Ordinary_Fixed_Point_Type 2637 (T : Entity_Id; 2638 Def : Node_Id) 2639 is 2640 Loc : constant Source_Ptr := Sloc (Def); 2641 Base : constant Entity_Id := 2642 New_Internal_Entity 2643 (E_Ordinary_Fixed_Point_Type, Current_Scope, 2644 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2645 2646 begin 2647 -- The semantic attributes are set for completeness only, their values 2648 -- will never be used, since all properties of the type are non-static. 2649 2650 Enter_Name (T); 2651 Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); 2652 Set_Etype (T, Base); 2653 Set_Size_Info (T, Standard_Integer); 2654 Set_RM_Size (T, RM_Size (Standard_Integer)); 2655 Set_Small_Value (T, Ureal_1); 2656 Set_Delta_Value (T, Ureal_1); 2657 Set_Scalar_Range (T, 2658 Make_Range (Loc, 2659 Low_Bound => Make_Real_Literal (Loc, Ureal_1), 2660 High_Bound => Make_Real_Literal (Loc, Ureal_1))); 2661 Set_Is_Constrained (T); 2662 2663 Set_Is_Generic_Type (Base); 2664 Set_Etype (Base, Base); 2665 Set_Size_Info (Base, Standard_Integer); 2666 Set_RM_Size (Base, RM_Size (Standard_Integer)); 2667 Set_Small_Value (Base, Ureal_1); 2668 Set_Delta_Value (Base, Ureal_1); 2669 Set_Scalar_Range (Base, Scalar_Range (T)); 2670 Set_Parent (Base, Parent (Def)); 2671 2672 Check_Restriction (No_Fixed_Point, Def); 2673 end Analyze_Formal_Ordinary_Fixed_Point_Type; 2674 2675 ---------------------------------------- 2676 -- Analyze_Formal_Package_Declaration -- 2677 ---------------------------------------- 2678 2679 procedure Analyze_Formal_Package_Declaration (N : Node_Id) is 2680 Gen_Id : constant Node_Id := Name (N); 2681 Loc : constant Source_Ptr := Sloc (N); 2682 Pack_Id : constant Entity_Id := Defining_Identifier (N); 2683 Formal : Entity_Id; 2684 Gen_Decl : Node_Id; 2685 Gen_Unit : Entity_Id; 2686 Renaming : Node_Id; 2687 2688 Vis_Prims_List : Elist_Id := No_Elist; 2689 -- List of primitives made temporarily visible in the instantiation 2690 -- to match the visibility of the formal type. 2691 2692 function Build_Local_Package return Node_Id; 2693 -- The formal package is rewritten so that its parameters are replaced 2694 -- with corresponding declarations. For parameters with bona fide 2695 -- associations these declarations are created by Analyze_Associations 2696 -- as for a regular instantiation. For boxed parameters, we preserve 2697 -- the formal declarations and analyze them, in order to introduce 2698 -- entities of the right kind in the environment of the formal. 2699 2700 ------------------------- 2701 -- Build_Local_Package -- 2702 ------------------------- 2703 2704 function Build_Local_Package return Node_Id is 2705 Decls : List_Id; 2706 Pack_Decl : Node_Id; 2707 2708 begin 2709 -- Within the formal, the name of the generic package is a renaming 2710 -- of the formal (as for a regular instantiation). 2711 2712 Pack_Decl := 2713 Make_Package_Declaration (Loc, 2714 Specification => 2715 Copy_Generic_Node 2716 (Specification (Original_Node (Gen_Decl)), 2717 Empty, Instantiating => True)); 2718 2719 Renaming := 2720 Make_Package_Renaming_Declaration (Loc, 2721 Defining_Unit_Name => 2722 Make_Defining_Identifier (Loc, Chars (Gen_Unit)), 2723 Name => New_Occurrence_Of (Formal, Loc)); 2724 2725 if Nkind (Gen_Id) = N_Identifier 2726 and then Chars (Gen_Id) = Chars (Pack_Id) 2727 then 2728 Error_Msg_NE 2729 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 2730 end if; 2731 2732 -- If the formal is declared with a box, or with an others choice, 2733 -- create corresponding declarations for all entities in the formal 2734 -- part, so that names with the proper types are available in the 2735 -- specification of the formal package. 2736 2737 -- On the other hand, if there are no associations, then all the 2738 -- formals must have defaults, and this will be checked by the 2739 -- call to Analyze_Associations. 2740 2741 if Box_Present (N) 2742 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice 2743 then 2744 declare 2745 Formal_Decl : Node_Id; 2746 2747 begin 2748 -- TBA : for a formal package, need to recurse ??? 2749 2750 Decls := New_List; 2751 Formal_Decl := 2752 First 2753 (Generic_Formal_Declarations (Original_Node (Gen_Decl))); 2754 while Present (Formal_Decl) loop 2755 Append_To 2756 (Decls, 2757 Copy_Generic_Node 2758 (Formal_Decl, Empty, Instantiating => True)); 2759 Next (Formal_Decl); 2760 end loop; 2761 end; 2762 2763 -- If generic associations are present, use Analyze_Associations to 2764 -- create the proper renaming declarations. 2765 2766 else 2767 declare 2768 Act_Tree : constant Node_Id := 2769 Copy_Generic_Node 2770 (Original_Node (Gen_Decl), Empty, 2771 Instantiating => True); 2772 2773 begin 2774 Generic_Renamings.Set_Last (0); 2775 Generic_Renamings_HTable.Reset; 2776 Instantiation_Node := N; 2777 2778 Decls := 2779 Analyze_Associations 2780 (I_Node => Original_Node (N), 2781 Formals => Generic_Formal_Declarations (Act_Tree), 2782 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 2783 2784 Vis_Prims_List := Check_Hidden_Primitives (Decls); 2785 end; 2786 end if; 2787 2788 Append (Renaming, To => Decls); 2789 2790 -- Add generated declarations ahead of local declarations in 2791 -- the package. 2792 2793 if No (Visible_Declarations (Specification (Pack_Decl))) then 2794 Set_Visible_Declarations (Specification (Pack_Decl), Decls); 2795 else 2796 Insert_List_Before 2797 (First (Visible_Declarations (Specification (Pack_Decl))), 2798 Decls); 2799 end if; 2800 2801 return Pack_Decl; 2802 end Build_Local_Package; 2803 2804 -- Local variables 2805 2806 Save_ISMP : constant Boolean := Ignore_SPARK_Mode_Pragmas_In_Instance; 2807 -- Save flag Ignore_SPARK_Mode_Pragmas_In_Instance for restore on exit 2808 2809 Associations : Boolean := True; 2810 New_N : Node_Id; 2811 Parent_Installed : Boolean := False; 2812 Parent_Instance : Entity_Id; 2813 Renaming_In_Par : Entity_Id; 2814 2815 -- Start of processing for Analyze_Formal_Package_Declaration 2816 2817 begin 2818 Check_Text_IO_Special_Unit (Gen_Id); 2819 2820 Init_Env; 2821 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 2822 Gen_Unit := Entity (Gen_Id); 2823 2824 -- Check for a formal package that is a package renaming 2825 2826 if Present (Renamed_Object (Gen_Unit)) then 2827 2828 -- Indicate that unit is used, before replacing it with renamed 2829 -- entity for use below. 2830 2831 if In_Extended_Main_Source_Unit (N) then 2832 Set_Is_Instantiated (Gen_Unit); 2833 Generate_Reference (Gen_Unit, N); 2834 end if; 2835 2836 Gen_Unit := Renamed_Object (Gen_Unit); 2837 end if; 2838 2839 if Ekind (Gen_Unit) /= E_Generic_Package then 2840 Error_Msg_N ("expect generic package name", Gen_Id); 2841 Restore_Env; 2842 goto Leave; 2843 2844 elsif Gen_Unit = Current_Scope then 2845 Error_Msg_N 2846 ("generic package cannot be used as a formal package of itself", 2847 Gen_Id); 2848 Restore_Env; 2849 goto Leave; 2850 2851 elsif In_Open_Scopes (Gen_Unit) then 2852 if Is_Compilation_Unit (Gen_Unit) 2853 and then Is_Child_Unit (Current_Scope) 2854 then 2855 -- Special-case the error when the formal is a parent, and 2856 -- continue analysis to minimize cascaded errors. 2857 2858 Error_Msg_N 2859 ("generic parent cannot be used as formal package of a child " 2860 & "unit", Gen_Id); 2861 2862 else 2863 Error_Msg_N 2864 ("generic package cannot be used as a formal package within " 2865 & "itself", Gen_Id); 2866 Restore_Env; 2867 goto Leave; 2868 end if; 2869 end if; 2870 2871 -- Check that name of formal package does not hide name of generic, 2872 -- or its leading prefix. This check must be done separately because 2873 -- the name of the generic has already been analyzed. 2874 2875 declare 2876 Gen_Name : Entity_Id; 2877 2878 begin 2879 Gen_Name := Gen_Id; 2880 while Nkind (Gen_Name) = N_Expanded_Name loop 2881 Gen_Name := Prefix (Gen_Name); 2882 end loop; 2883 2884 if Chars (Gen_Name) = Chars (Pack_Id) then 2885 Error_Msg_NE 2886 ("& is hidden within declaration of formal package", 2887 Gen_Id, Gen_Name); 2888 end if; 2889 end; 2890 2891 if Box_Present (N) 2892 or else No (Generic_Associations (N)) 2893 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice 2894 then 2895 Associations := False; 2896 end if; 2897 2898 -- If there are no generic associations, the generic parameters appear 2899 -- as local entities and are instantiated like them. We copy the generic 2900 -- package declaration as if it were an instantiation, and analyze it 2901 -- like a regular package, except that we treat the formals as 2902 -- additional visible components. 2903 2904 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 2905 2906 if In_Extended_Main_Source_Unit (N) then 2907 Set_Is_Instantiated (Gen_Unit); 2908 Generate_Reference (Gen_Unit, N); 2909 end if; 2910 2911 Formal := New_Copy (Pack_Id); 2912 Create_Instantiation_Source (N, Gen_Unit, S_Adjustment); 2913 2914 -- Make local generic without formals. The formals will be replaced with 2915 -- internal declarations. 2916 2917 begin 2918 New_N := Build_Local_Package; 2919 2920 -- If there are errors in the parameter list, Analyze_Associations 2921 -- raises Instantiation_Error. Patch the declaration to prevent further 2922 -- exception propagation. 2923 2924 exception 2925 when Instantiation_Error => 2926 Enter_Name (Formal); 2927 Set_Ekind (Formal, E_Variable); 2928 Set_Etype (Formal, Any_Type); 2929 Restore_Hidden_Primitives (Vis_Prims_List); 2930 2931 if Parent_Installed then 2932 Remove_Parent; 2933 end if; 2934 2935 goto Leave; 2936 end; 2937 2938 Rewrite (N, New_N); 2939 Set_Defining_Unit_Name (Specification (New_N), Formal); 2940 Set_Generic_Parent (Specification (N), Gen_Unit); 2941 Set_Instance_Env (Gen_Unit, Formal); 2942 Set_Is_Generic_Instance (Formal); 2943 2944 Enter_Name (Formal); 2945 Set_Ekind (Formal, E_Package); 2946 Set_Etype (Formal, Standard_Void_Type); 2947 Set_Inner_Instances (Formal, New_Elmt_List); 2948 Push_Scope (Formal); 2949 2950 -- Manually set the SPARK_Mode from the context because the package 2951 -- declaration is never analyzed. 2952 2953 Set_SPARK_Pragma (Formal, SPARK_Mode_Pragma); 2954 Set_SPARK_Aux_Pragma (Formal, SPARK_Mode_Pragma); 2955 Set_SPARK_Pragma_Inherited (Formal); 2956 Set_SPARK_Aux_Pragma_Inherited (Formal); 2957 2958 if Is_Child_Unit (Gen_Unit) and then Parent_Installed then 2959 2960 -- Similarly, we have to make the name of the formal visible in the 2961 -- parent instance, to resolve properly fully qualified names that 2962 -- may appear in the generic unit. The parent instance has been 2963 -- placed on the scope stack ahead of the current scope. 2964 2965 Parent_Instance := Scope_Stack.Table (Scope_Stack.Last - 1).Entity; 2966 2967 Renaming_In_Par := 2968 Make_Defining_Identifier (Loc, Chars (Gen_Unit)); 2969 Set_Ekind (Renaming_In_Par, E_Package); 2970 Set_Etype (Renaming_In_Par, Standard_Void_Type); 2971 Set_Scope (Renaming_In_Par, Parent_Instance); 2972 Set_Parent (Renaming_In_Par, Parent (Formal)); 2973 Set_Renamed_Object (Renaming_In_Par, Formal); 2974 Append_Entity (Renaming_In_Par, Parent_Instance); 2975 end if; 2976 2977 -- A formal package declaration behaves as a package instantiation with 2978 -- respect to SPARK_Mode "off". If the annotation is "off" or altogether 2979 -- missing, set the global flag which signals Analyze_Pragma to ingnore 2980 -- all SPARK_Mode pragmas within the generic_package_name. 2981 2982 if SPARK_Mode /= On then 2983 Ignore_SPARK_Mode_Pragmas_In_Instance := True; 2984 2985 -- Mark the formal spec in case the body is instantiated at a later 2986 -- pass. This preserves the original context in effect for the body. 2987 2988 Set_Ignore_SPARK_Mode_Pragmas (Formal); 2989 end if; 2990 2991 Analyze (Specification (N)); 2992 2993 -- The formals for which associations are provided are not visible 2994 -- outside of the formal package. The others are still declared by a 2995 -- formal parameter declaration. 2996 2997 -- If there are no associations, the only local entity to hide is the 2998 -- generated package renaming itself. 2999 3000 declare 3001 E : Entity_Id; 3002 3003 begin 3004 E := First_Entity (Formal); 3005 while Present (E) loop 3006 if Associations and then not Is_Generic_Formal (E) then 3007 Set_Is_Hidden (E); 3008 end if; 3009 3010 if Ekind (E) = E_Package and then Renamed_Entity (E) = Formal then 3011 Set_Is_Hidden (E); 3012 exit; 3013 end if; 3014 3015 Next_Entity (E); 3016 end loop; 3017 end; 3018 3019 End_Package_Scope (Formal); 3020 Restore_Hidden_Primitives (Vis_Prims_List); 3021 3022 if Parent_Installed then 3023 Remove_Parent; 3024 end if; 3025 3026 Restore_Env; 3027 3028 -- Inside the generic unit, the formal package is a regular package, but 3029 -- no body is needed for it. Note that after instantiation, the defining 3030 -- unit name we need is in the new tree and not in the original (see 3031 -- Package_Instantiation). A generic formal package is an instance, and 3032 -- can be used as an actual for an inner instance. 3033 3034 Set_Has_Completion (Formal, True); 3035 3036 -- Add semantic information to the original defining identifier for ASIS 3037 -- use. 3038 3039 Set_Ekind (Pack_Id, E_Package); 3040 Set_Etype (Pack_Id, Standard_Void_Type); 3041 Set_Scope (Pack_Id, Scope (Formal)); 3042 Set_Has_Completion (Pack_Id, True); 3043 3044 <<Leave>> 3045 if Has_Aspects (N) then 3046 Analyze_Aspect_Specifications (N, Pack_Id); 3047 end if; 3048 3049 Ignore_SPARK_Mode_Pragmas_In_Instance := Save_ISMP; 3050 end Analyze_Formal_Package_Declaration; 3051 3052 --------------------------------- 3053 -- Analyze_Formal_Private_Type -- 3054 --------------------------------- 3055 3056 procedure Analyze_Formal_Private_Type 3057 (N : Node_Id; 3058 T : Entity_Id; 3059 Def : Node_Id) 3060 is 3061 begin 3062 New_Private_Type (N, T, Def); 3063 3064 -- Set the size to an arbitrary but legal value 3065 3066 Set_Size_Info (T, Standard_Integer); 3067 Set_RM_Size (T, RM_Size (Standard_Integer)); 3068 end Analyze_Formal_Private_Type; 3069 3070 ------------------------------------ 3071 -- Analyze_Formal_Incomplete_Type -- 3072 ------------------------------------ 3073 3074 procedure Analyze_Formal_Incomplete_Type 3075 (T : Entity_Id; 3076 Def : Node_Id) 3077 is 3078 begin 3079 Enter_Name (T); 3080 Set_Ekind (T, E_Incomplete_Type); 3081 Set_Etype (T, T); 3082 Set_Private_Dependents (T, New_Elmt_List); 3083 3084 if Tagged_Present (Def) then 3085 Set_Is_Tagged_Type (T); 3086 Make_Class_Wide_Type (T); 3087 Set_Direct_Primitive_Operations (T, New_Elmt_List); 3088 end if; 3089 end Analyze_Formal_Incomplete_Type; 3090 3091 ---------------------------------------- 3092 -- Analyze_Formal_Signed_Integer_Type -- 3093 ---------------------------------------- 3094 3095 procedure Analyze_Formal_Signed_Integer_Type 3096 (T : Entity_Id; 3097 Def : Node_Id) 3098 is 3099 Base : constant Entity_Id := 3100 New_Internal_Entity 3101 (E_Signed_Integer_Type, 3102 Current_Scope, 3103 Sloc (Defining_Identifier (Parent (Def))), 'G'); 3104 3105 begin 3106 Enter_Name (T); 3107 3108 Set_Ekind (T, E_Signed_Integer_Subtype); 3109 Set_Etype (T, Base); 3110 Set_Size_Info (T, Standard_Integer); 3111 Set_RM_Size (T, RM_Size (Standard_Integer)); 3112 Set_Scalar_Range (T, Scalar_Range (Standard_Integer)); 3113 Set_Is_Constrained (T); 3114 3115 Set_Is_Generic_Type (Base); 3116 Set_Size_Info (Base, Standard_Integer); 3117 Set_RM_Size (Base, RM_Size (Standard_Integer)); 3118 Set_Etype (Base, Base); 3119 Set_Scalar_Range (Base, Scalar_Range (Standard_Integer)); 3120 Set_Parent (Base, Parent (Def)); 3121 end Analyze_Formal_Signed_Integer_Type; 3122 3123 ------------------------------------------- 3124 -- Analyze_Formal_Subprogram_Declaration -- 3125 ------------------------------------------- 3126 3127 procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id) is 3128 Spec : constant Node_Id := Specification (N); 3129 Def : constant Node_Id := Default_Name (N); 3130 Nam : constant Entity_Id := Defining_Unit_Name (Spec); 3131 Subp : Entity_Id; 3132 3133 begin 3134 if Nam = Error then 3135 return; 3136 end if; 3137 3138 if Nkind (Nam) = N_Defining_Program_Unit_Name then 3139 Error_Msg_N ("name of formal subprogram must be a direct name", Nam); 3140 goto Leave; 3141 end if; 3142 3143 Analyze_Subprogram_Declaration (N); 3144 Set_Is_Formal_Subprogram (Nam); 3145 Set_Has_Completion (Nam); 3146 3147 if Nkind (N) = N_Formal_Abstract_Subprogram_Declaration then 3148 Set_Is_Abstract_Subprogram (Nam); 3149 3150 Set_Is_Dispatching_Operation (Nam); 3151 3152 -- A formal abstract procedure cannot have a null default 3153 -- (RM 12.6(4.1/2)). 3154 3155 if Nkind (Spec) = N_Procedure_Specification 3156 and then Null_Present (Spec) 3157 then 3158 Error_Msg_N 3159 ("a formal abstract subprogram cannot default to null", Spec); 3160 end if; 3161 3162 declare 3163 Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam); 3164 begin 3165 if No (Ctrl_Type) then 3166 Error_Msg_N 3167 ("abstract formal subprogram must have a controlling type", 3168 N); 3169 3170 elsif Ada_Version >= Ada_2012 3171 and then Is_Incomplete_Type (Ctrl_Type) 3172 then 3173 Error_Msg_NE 3174 ("controlling type of abstract formal subprogram cannot " 3175 & "be incomplete type", N, Ctrl_Type); 3176 3177 else 3178 Check_Controlling_Formals (Ctrl_Type, Nam); 3179 end if; 3180 end; 3181 end if; 3182 3183 -- Default name is resolved at the point of instantiation 3184 3185 if Box_Present (N) then 3186 null; 3187 3188 -- Else default is bound at the point of generic declaration 3189 3190 elsif Present (Def) then 3191 if Nkind (Def) = N_Operator_Symbol then 3192 Find_Direct_Name (Def); 3193 3194 elsif Nkind (Def) /= N_Attribute_Reference then 3195 Analyze (Def); 3196 3197 else 3198 -- For an attribute reference, analyze the prefix and verify 3199 -- that it has the proper profile for the subprogram. 3200 3201 Analyze (Prefix (Def)); 3202 Valid_Default_Attribute (Nam, Def); 3203 goto Leave; 3204 end if; 3205 3206 -- Default name may be overloaded, in which case the interpretation 3207 -- with the correct profile must be selected, as for a renaming. 3208 -- If the definition is an indexed component, it must denote a 3209 -- member of an entry family. If it is a selected component, it 3210 -- can be a protected operation. 3211 3212 if Etype (Def) = Any_Type then 3213 goto Leave; 3214 3215 elsif Nkind (Def) = N_Selected_Component then 3216 if not Is_Overloadable (Entity (Selector_Name (Def))) then 3217 Error_Msg_N ("expect valid subprogram name as default", Def); 3218 end if; 3219 3220 elsif Nkind (Def) = N_Indexed_Component then 3221 if Is_Entity_Name (Prefix (Def)) then 3222 if Ekind (Entity (Prefix (Def))) /= E_Entry_Family then 3223 Error_Msg_N ("expect valid subprogram name as default", Def); 3224 end if; 3225 3226 elsif Nkind (Prefix (Def)) = N_Selected_Component then 3227 if Ekind (Entity (Selector_Name (Prefix (Def)))) /= 3228 E_Entry_Family 3229 then 3230 Error_Msg_N ("expect valid subprogram name as default", Def); 3231 end if; 3232 3233 else 3234 Error_Msg_N ("expect valid subprogram name as default", Def); 3235 goto Leave; 3236 end if; 3237 3238 elsif Nkind (Def) = N_Character_Literal then 3239 3240 -- Needs some type checks: subprogram should be parameterless??? 3241 3242 Resolve (Def, (Etype (Nam))); 3243 3244 elsif not Is_Entity_Name (Def) 3245 or else not Is_Overloadable (Entity (Def)) 3246 then 3247 Error_Msg_N ("expect valid subprogram name as default", Def); 3248 goto Leave; 3249 3250 elsif not Is_Overloaded (Def) then 3251 Subp := Entity (Def); 3252 3253 if Subp = Nam then 3254 Error_Msg_N ("premature usage of formal subprogram", Def); 3255 3256 elsif not Entity_Matches_Spec (Subp, Nam) then 3257 Error_Msg_N ("no visible entity matches specification", Def); 3258 end if; 3259 3260 -- More than one interpretation, so disambiguate as for a renaming 3261 3262 else 3263 declare 3264 I : Interp_Index; 3265 I1 : Interp_Index := 0; 3266 It : Interp; 3267 It1 : Interp; 3268 3269 begin 3270 Subp := Any_Id; 3271 Get_First_Interp (Def, I, It); 3272 while Present (It.Nam) loop 3273 if Entity_Matches_Spec (It.Nam, Nam) then 3274 if Subp /= Any_Id then 3275 It1 := Disambiguate (Def, I1, I, Etype (Subp)); 3276 3277 if It1 = No_Interp then 3278 Error_Msg_N ("ambiguous default subprogram", Def); 3279 else 3280 Subp := It1.Nam; 3281 end if; 3282 3283 exit; 3284 3285 else 3286 I1 := I; 3287 Subp := It.Nam; 3288 end if; 3289 end if; 3290 3291 Get_Next_Interp (I, It); 3292 end loop; 3293 end; 3294 3295 if Subp /= Any_Id then 3296 3297 -- Subprogram found, generate reference to it 3298 3299 Set_Entity (Def, Subp); 3300 Generate_Reference (Subp, Def); 3301 3302 if Subp = Nam then 3303 Error_Msg_N ("premature usage of formal subprogram", Def); 3304 3305 elsif Ekind (Subp) /= E_Operator then 3306 Check_Mode_Conformant (Subp, Nam); 3307 end if; 3308 3309 else 3310 Error_Msg_N ("no visible subprogram matches specification", N); 3311 end if; 3312 end if; 3313 end if; 3314 3315 <<Leave>> 3316 if Has_Aspects (N) then 3317 Analyze_Aspect_Specifications (N, Nam); 3318 end if; 3319 3320 end Analyze_Formal_Subprogram_Declaration; 3321 3322 ------------------------------------- 3323 -- Analyze_Formal_Type_Declaration -- 3324 ------------------------------------- 3325 3326 procedure Analyze_Formal_Type_Declaration (N : Node_Id) is 3327 Def : constant Node_Id := Formal_Type_Definition (N); 3328 T : Entity_Id; 3329 3330 begin 3331 T := Defining_Identifier (N); 3332 3333 if Present (Discriminant_Specifications (N)) 3334 and then Nkind (Def) /= N_Formal_Private_Type_Definition 3335 then 3336 Error_Msg_N 3337 ("discriminants not allowed for this formal type", T); 3338 end if; 3339 3340 -- Enter the new name, and branch to specific routine 3341 3342 case Nkind (Def) is 3343 when N_Formal_Private_Type_Definition => 3344 Analyze_Formal_Private_Type (N, T, Def); 3345 3346 when N_Formal_Derived_Type_Definition => 3347 Analyze_Formal_Derived_Type (N, T, Def); 3348 3349 when N_Formal_Incomplete_Type_Definition => 3350 Analyze_Formal_Incomplete_Type (T, Def); 3351 3352 when N_Formal_Discrete_Type_Definition => 3353 Analyze_Formal_Discrete_Type (T, Def); 3354 3355 when N_Formal_Signed_Integer_Type_Definition => 3356 Analyze_Formal_Signed_Integer_Type (T, Def); 3357 3358 when N_Formal_Modular_Type_Definition => 3359 Analyze_Formal_Modular_Type (T, Def); 3360 3361 when N_Formal_Floating_Point_Definition => 3362 Analyze_Formal_Floating_Type (T, Def); 3363 3364 when N_Formal_Ordinary_Fixed_Point_Definition => 3365 Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def); 3366 3367 when N_Formal_Decimal_Fixed_Point_Definition => 3368 Analyze_Formal_Decimal_Fixed_Point_Type (T, Def); 3369 3370 when N_Array_Type_Definition => 3371 Analyze_Formal_Array_Type (T, Def); 3372 3373 when N_Access_Function_Definition 3374 | N_Access_Procedure_Definition 3375 | N_Access_To_Object_Definition 3376 => 3377 Analyze_Generic_Access_Type (T, Def); 3378 3379 -- Ada 2005: a interface declaration is encoded as an abstract 3380 -- record declaration or a abstract type derivation. 3381 3382 when N_Record_Definition => 3383 Analyze_Formal_Interface_Type (N, T, Def); 3384 3385 when N_Derived_Type_Definition => 3386 Analyze_Formal_Derived_Interface_Type (N, T, Def); 3387 3388 when N_Error => 3389 null; 3390 3391 when others => 3392 raise Program_Error; 3393 end case; 3394 3395 Set_Is_Generic_Type (T); 3396 3397 if Has_Aspects (N) then 3398 Analyze_Aspect_Specifications (N, T); 3399 end if; 3400 end Analyze_Formal_Type_Declaration; 3401 3402 ------------------------------------ 3403 -- Analyze_Function_Instantiation -- 3404 ------------------------------------ 3405 3406 procedure Analyze_Function_Instantiation (N : Node_Id) is 3407 begin 3408 Analyze_Subprogram_Instantiation (N, E_Function); 3409 end Analyze_Function_Instantiation; 3410 3411 --------------------------------- 3412 -- Analyze_Generic_Access_Type -- 3413 --------------------------------- 3414 3415 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is 3416 begin 3417 Enter_Name (T); 3418 3419 if Nkind (Def) = N_Access_To_Object_Definition then 3420 Access_Type_Declaration (T, Def); 3421 3422 if Is_Incomplete_Or_Private_Type (Designated_Type (T)) 3423 and then No (Full_View (Designated_Type (T))) 3424 and then not Is_Generic_Type (Designated_Type (T)) 3425 then 3426 Error_Msg_N ("premature usage of incomplete type", Def); 3427 3428 elsif not Is_Entity_Name (Subtype_Indication (Def)) then 3429 Error_Msg_N 3430 ("only a subtype mark is allowed in a formal", Def); 3431 end if; 3432 3433 else 3434 Access_Subprogram_Declaration (T, Def); 3435 end if; 3436 end Analyze_Generic_Access_Type; 3437 3438 --------------------------------- 3439 -- Analyze_Generic_Formal_Part -- 3440 --------------------------------- 3441 3442 procedure Analyze_Generic_Formal_Part (N : Node_Id) is 3443 Gen_Parm_Decl : Node_Id; 3444 3445 begin 3446 -- The generic formals are processed in the scope of the generic unit, 3447 -- where they are immediately visible. The scope is installed by the 3448 -- caller. 3449 3450 Gen_Parm_Decl := First (Generic_Formal_Declarations (N)); 3451 while Present (Gen_Parm_Decl) loop 3452 Analyze (Gen_Parm_Decl); 3453 Next (Gen_Parm_Decl); 3454 end loop; 3455 3456 Generate_Reference_To_Generic_Formals (Current_Scope); 3457 end Analyze_Generic_Formal_Part; 3458 3459 ------------------------------------------ 3460 -- Analyze_Generic_Package_Declaration -- 3461 ------------------------------------------ 3462 3463 procedure Analyze_Generic_Package_Declaration (N : Node_Id) is 3464 Decls : constant List_Id := Visible_Declarations (Specification (N)); 3465 Loc : constant Source_Ptr := Sloc (N); 3466 3467 Decl : Node_Id; 3468 Id : Entity_Id; 3469 New_N : Node_Id; 3470 Renaming : Node_Id; 3471 Save_Parent : Node_Id; 3472 3473 begin 3474 Check_SPARK_05_Restriction ("generic is not allowed", N); 3475 3476 -- We introduce a renaming of the enclosing package, to have a usable 3477 -- entity as the prefix of an expanded name for a local entity of the 3478 -- form Par.P.Q, where P is the generic package. This is because a local 3479 -- entity named P may hide it, so that the usual visibility rules in 3480 -- the instance will not resolve properly. 3481 3482 Renaming := 3483 Make_Package_Renaming_Declaration (Loc, 3484 Defining_Unit_Name => 3485 Make_Defining_Identifier (Loc, 3486 Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")), 3487 Name => 3488 Make_Identifier (Loc, Chars (Defining_Entity (N)))); 3489 3490 -- The declaration is inserted before other declarations, but before 3491 -- pragmas that may be library-unit pragmas and must appear before other 3492 -- declarations. The pragma Compile_Time_Error is not in this class, and 3493 -- may contain an expression that includes such a qualified name, so the 3494 -- renaming declaration must appear before it. 3495 3496 -- Are there other pragmas that require this special handling ??? 3497 3498 if Present (Decls) then 3499 Decl := First (Decls); 3500 while Present (Decl) 3501 and then Nkind (Decl) = N_Pragma 3502 and then Get_Pragma_Id (Decl) /= Pragma_Compile_Time_Error 3503 loop 3504 Next (Decl); 3505 end loop; 3506 3507 if Present (Decl) then 3508 Insert_Before (Decl, Renaming); 3509 else 3510 Append (Renaming, Visible_Declarations (Specification (N))); 3511 end if; 3512 3513 else 3514 Set_Visible_Declarations (Specification (N), New_List (Renaming)); 3515 end if; 3516 3517 -- Create copy of generic unit, and save for instantiation. If the unit 3518 -- is a child unit, do not copy the specifications for the parent, which 3519 -- are not part of the generic tree. 3520 3521 Save_Parent := Parent_Spec (N); 3522 Set_Parent_Spec (N, Empty); 3523 3524 New_N := Copy_Generic_Node (N, Empty, Instantiating => False); 3525 Set_Parent_Spec (New_N, Save_Parent); 3526 Rewrite (N, New_N); 3527 3528 -- Once the contents of the generic copy and the template are swapped, 3529 -- do the same for their respective aspect specifications. 3530 3531 Exchange_Aspects (N, New_N); 3532 3533 -- Collect all contract-related source pragmas found within the template 3534 -- and attach them to the contract of the package spec. This contract is 3535 -- used in the capture of global references within annotations. 3536 3537 Create_Generic_Contract (N); 3538 3539 Id := Defining_Entity (N); 3540 Generate_Definition (Id); 3541 3542 -- Expansion is not applied to generic units 3543 3544 Start_Generic; 3545 3546 Enter_Name (Id); 3547 Set_Ekind (Id, E_Generic_Package); 3548 Set_Etype (Id, Standard_Void_Type); 3549 3550 -- Set SPARK_Mode from context 3551 3552 Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); 3553 Set_SPARK_Aux_Pragma (Id, SPARK_Mode_Pragma); 3554 Set_SPARK_Pragma_Inherited (Id); 3555 Set_SPARK_Aux_Pragma_Inherited (Id); 3556 3557 -- Preserve relevant elaboration-related attributes of the context which 3558 -- are no longer available or very expensive to recompute once analysis, 3559 -- resolution, and expansion are over. 3560 3561 Mark_Elaboration_Attributes 3562 (N_Id => Id, 3563 Checks => True, 3564 Warnings => True); 3565 3566 -- Analyze aspects now, so that generated pragmas appear in the 3567 -- declarations before building and analyzing the generic copy. 3568 3569 if Has_Aspects (N) then 3570 Analyze_Aspect_Specifications (N, Id); 3571 end if; 3572 3573 Push_Scope (Id); 3574 Enter_Generic_Scope (Id); 3575 Set_Inner_Instances (Id, New_Elmt_List); 3576 3577 Set_Categorization_From_Pragmas (N); 3578 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3579 3580 -- Link the declaration of the generic homonym in the generic copy to 3581 -- the package it renames, so that it is always resolved properly. 3582 3583 Set_Generic_Homonym (Id, Defining_Unit_Name (Renaming)); 3584 Set_Entity (Associated_Node (Name (Renaming)), Id); 3585 3586 -- For a library unit, we have reconstructed the entity for the unit, 3587 -- and must reset it in the library tables. 3588 3589 if Nkind (Parent (N)) = N_Compilation_Unit then 3590 Set_Cunit_Entity (Current_Sem_Unit, Id); 3591 end if; 3592 3593 Analyze_Generic_Formal_Part (N); 3594 3595 -- After processing the generic formals, analysis proceeds as for a 3596 -- non-generic package. 3597 3598 Analyze (Specification (N)); 3599 3600 Validate_Categorization_Dependency (N, Id); 3601 3602 End_Generic; 3603 3604 End_Package_Scope (Id); 3605 Exit_Generic_Scope (Id); 3606 3607 -- If the generic appears within a package unit, the body of that unit 3608 -- has to be present for instantiation and inlining. 3609 3610 if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration then 3611 Set_Body_Needed_For_Inlining 3612 (Defining_Entity (Unit (Cunit (Current_Sem_Unit)))); 3613 end if; 3614 3615 if Nkind (Parent (N)) /= N_Compilation_Unit then 3616 Move_Freeze_Nodes (Id, N, Visible_Declarations (Specification (N))); 3617 Move_Freeze_Nodes (Id, N, Private_Declarations (Specification (N))); 3618 Move_Freeze_Nodes (Id, N, Generic_Formal_Declarations (N)); 3619 3620 else 3621 Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); 3622 Validate_RT_RAT_Component (N); 3623 3624 -- If this is a spec without a body, check that generic parameters 3625 -- are referenced. 3626 3627 if not Body_Required (Parent (N)) then 3628 Check_References (Id); 3629 end if; 3630 end if; 3631 3632 -- If there is a specified storage pool in the context, create an 3633 -- aspect on the package declaration, so that it is used in any 3634 -- instance that does not override it. 3635 3636 if Present (Default_Pool) then 3637 declare 3638 ASN : Node_Id; 3639 3640 begin 3641 ASN := 3642 Make_Aspect_Specification (Loc, 3643 Identifier => Make_Identifier (Loc, Name_Default_Storage_Pool), 3644 Expression => New_Copy (Default_Pool)); 3645 3646 if No (Aspect_Specifications (Specification (N))) then 3647 Set_Aspect_Specifications (Specification (N), New_List (ASN)); 3648 else 3649 Append (ASN, Aspect_Specifications (Specification (N))); 3650 end if; 3651 end; 3652 end if; 3653 end Analyze_Generic_Package_Declaration; 3654 3655 -------------------------------------------- 3656 -- Analyze_Generic_Subprogram_Declaration -- 3657 -------------------------------------------- 3658 3659 procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is 3660 Formals : List_Id; 3661 Id : Entity_Id; 3662 New_N : Node_Id; 3663 Result_Type : Entity_Id; 3664 Save_Parent : Node_Id; 3665 Spec : Node_Id; 3666 Typ : Entity_Id; 3667 3668 begin 3669 Check_SPARK_05_Restriction ("generic is not allowed", N); 3670 3671 -- Create copy of generic unit, and save for instantiation. If the unit 3672 -- is a child unit, do not copy the specifications for the parent, which 3673 -- are not part of the generic tree. 3674 3675 Save_Parent := Parent_Spec (N); 3676 Set_Parent_Spec (N, Empty); 3677 3678 New_N := Copy_Generic_Node (N, Empty, Instantiating => False); 3679 Set_Parent_Spec (New_N, Save_Parent); 3680 Rewrite (N, New_N); 3681 3682 -- Once the contents of the generic copy and the template are swapped, 3683 -- do the same for their respective aspect specifications. 3684 3685 Exchange_Aspects (N, New_N); 3686 3687 -- Collect all contract-related source pragmas found within the template 3688 -- and attach them to the contract of the subprogram spec. This contract 3689 -- is used in the capture of global references within annotations. 3690 3691 Create_Generic_Contract (N); 3692 3693 Spec := Specification (N); 3694 Id := Defining_Entity (Spec); 3695 Generate_Definition (Id); 3696 3697 if Nkind (Id) = N_Defining_Operator_Symbol then 3698 Error_Msg_N 3699 ("operator symbol not allowed for generic subprogram", Id); 3700 end if; 3701 3702 Start_Generic; 3703 3704 Enter_Name (Id); 3705 Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1); 3706 3707 -- Analyze the aspects of the generic copy to ensure that all generated 3708 -- pragmas (if any) perform their semantic effects. 3709 3710 if Has_Aspects (N) then 3711 Analyze_Aspect_Specifications (N, Id); 3712 end if; 3713 3714 Push_Scope (Id); 3715 Enter_Generic_Scope (Id); 3716 Set_Inner_Instances (Id, New_Elmt_List); 3717 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3718 3719 Analyze_Generic_Formal_Part (N); 3720 3721 if Nkind (Spec) = N_Function_Specification then 3722 Set_Ekind (Id, E_Generic_Function); 3723 else 3724 Set_Ekind (Id, E_Generic_Procedure); 3725 end if; 3726 3727 -- Set SPARK_Mode from context 3728 3729 Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); 3730 Set_SPARK_Pragma_Inherited (Id); 3731 3732 -- Preserve relevant elaboration-related attributes of the context which 3733 -- are no longer available or very expensive to recompute once analysis, 3734 -- resolution, and expansion are over. 3735 3736 Mark_Elaboration_Attributes 3737 (N_Id => Id, 3738 Checks => True, 3739 Warnings => True); 3740 3741 Formals := Parameter_Specifications (Spec); 3742 3743 if Present (Formals) then 3744 Process_Formals (Formals, Spec); 3745 end if; 3746 3747 if Nkind (Spec) = N_Function_Specification then 3748 if Nkind (Result_Definition (Spec)) = N_Access_Definition then 3749 Result_Type := Access_Definition (Spec, Result_Definition (Spec)); 3750 Set_Etype (Id, Result_Type); 3751 3752 -- Check restriction imposed by AI05-073: a generic function 3753 -- cannot return an abstract type or an access to such. 3754 3755 -- This is a binding interpretation should it apply to earlier 3756 -- versions of Ada as well as Ada 2012??? 3757 3758 if Is_Abstract_Type (Designated_Type (Result_Type)) 3759 and then Ada_Version >= Ada_2012 3760 then 3761 Error_Msg_N 3762 ("generic function cannot have an access result " 3763 & "that designates an abstract type", Spec); 3764 end if; 3765 3766 else 3767 Find_Type (Result_Definition (Spec)); 3768 Typ := Entity (Result_Definition (Spec)); 3769 3770 if Is_Abstract_Type (Typ) 3771 and then Ada_Version >= Ada_2012 3772 then 3773 Error_Msg_N 3774 ("generic function cannot have abstract result type", Spec); 3775 end if; 3776 3777 -- If a null exclusion is imposed on the result type, then create 3778 -- a null-excluding itype (an access subtype) and use it as the 3779 -- function's Etype. 3780 3781 if Is_Access_Type (Typ) 3782 and then Null_Exclusion_Present (Spec) 3783 then 3784 Set_Etype (Id, 3785 Create_Null_Excluding_Itype 3786 (T => Typ, 3787 Related_Nod => Spec, 3788 Scope_Id => Defining_Unit_Name (Spec))); 3789 else 3790 Set_Etype (Id, Typ); 3791 end if; 3792 end if; 3793 3794 else 3795 Set_Etype (Id, Standard_Void_Type); 3796 end if; 3797 3798 -- For a library unit, we have reconstructed the entity for the unit, 3799 -- and must reset it in the library tables. We also make sure that 3800 -- Body_Required is set properly in the original compilation unit node. 3801 3802 if Nkind (Parent (N)) = N_Compilation_Unit then 3803 Set_Cunit_Entity (Current_Sem_Unit, Id); 3804 Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); 3805 end if; 3806 3807 -- If the generic appears within a package unit, the body of that unit 3808 -- has to be present for instantiation and inlining. 3809 3810 if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration 3811 and then Unit_Requires_Body (Id) 3812 then 3813 Set_Body_Needed_For_Inlining 3814 (Defining_Entity (Unit (Cunit (Current_Sem_Unit)))); 3815 end if; 3816 3817 Set_Categorization_From_Pragmas (N); 3818 Validate_Categorization_Dependency (N, Id); 3819 3820 -- Capture all global references that occur within the profile of the 3821 -- generic subprogram. Aspects are not part of this processing because 3822 -- they must be delayed. If processed now, Save_Global_References will 3823 -- destroy the Associated_Node links and prevent the capture of global 3824 -- references when the contract of the generic subprogram is analyzed. 3825 3826 Save_Global_References (Original_Node (N)); 3827 3828 End_Generic; 3829 End_Scope; 3830 Exit_Generic_Scope (Id); 3831 Generate_Reference_To_Formals (Id); 3832 3833 List_Inherited_Pre_Post_Aspects (Id); 3834 end Analyze_Generic_Subprogram_Declaration; 3835 3836 ----------------------------------- 3837 -- Analyze_Package_Instantiation -- 3838 ----------------------------------- 3839 3840 -- WARNING: This routine manages Ghost and SPARK regions. Return statements 3841 -- must be replaced by gotos which jump to the end of the routine in order 3842 -- to restore the Ghost and SPARK modes. 3843 3844 procedure Analyze_Package_Instantiation (N : Node_Id) is 3845 Has_Inline_Always : Boolean := False; 3846 3847 procedure Delay_Descriptors (E : Entity_Id); 3848 -- Delay generation of subprogram descriptors for given entity 3849 3850 function Might_Inline_Subp (Gen_Unit : Entity_Id) return Boolean; 3851 -- If inlining is active and the generic contains inlined subprograms, 3852 -- we instantiate the body. This may cause superfluous instantiations, 3853 -- but it is simpler than detecting the need for the body at the point 3854 -- of inlining, when the context of the instance is not available. 3855 3856 ----------------------- 3857 -- Delay_Descriptors -- 3858 ----------------------- 3859 3860 procedure Delay_Descriptors (E : Entity_Id) is 3861 begin 3862 if not Delay_Subprogram_Descriptors (E) then 3863 Set_Delay_Subprogram_Descriptors (E); 3864 Pending_Descriptor.Append (E); 3865 end if; 3866 end Delay_Descriptors; 3867 3868 ----------------------- 3869 -- Might_Inline_Subp -- 3870 ----------------------- 3871 3872 function Might_Inline_Subp (Gen_Unit : Entity_Id) return Boolean is 3873 E : Entity_Id; 3874 3875 begin 3876 if not Inline_Processing_Required then 3877 return False; 3878 3879 else 3880 E := First_Entity (Gen_Unit); 3881 while Present (E) loop 3882 if Is_Subprogram (E) and then Is_Inlined (E) then 3883 -- Remember if there are any subprograms with Inline_Always 3884 3885 if Has_Pragma_Inline_Always (E) then 3886 Has_Inline_Always := True; 3887 end if; 3888 3889 return True; 3890 end if; 3891 3892 Next_Entity (E); 3893 end loop; 3894 end if; 3895 3896 return False; 3897 end Might_Inline_Subp; 3898 3899 -- Local declarations 3900 3901 Gen_Id : constant Node_Id := Name (N); 3902 Is_Actual_Pack : constant Boolean := 3903 Is_Internal (Defining_Entity (N)); 3904 Loc : constant Source_Ptr := Sloc (N); 3905 3906 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 3907 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 3908 Saved_ISMP : constant Boolean := 3909 Ignore_SPARK_Mode_Pragmas_In_Instance; 3910 Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; 3911 Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; 3912 -- Save the Ghost and SPARK mode-related data to restore on exit 3913 3914 Saved_Style_Check : constant Boolean := Style_Check; 3915 -- Save style check mode for restore on exit 3916 3917 Act_Decl : Node_Id; 3918 Act_Decl_Name : Node_Id; 3919 Act_Decl_Id : Entity_Id; 3920 Act_Spec : Node_Id; 3921 Act_Tree : Node_Id; 3922 Env_Installed : Boolean := False; 3923 Gen_Decl : Node_Id; 3924 Gen_Spec : Node_Id; 3925 Gen_Unit : Entity_Id; 3926 Inline_Now : Boolean := False; 3927 Needs_Body : Boolean; 3928 Parent_Installed : Boolean := False; 3929 Renaming_List : List_Id; 3930 Unit_Renaming : Node_Id; 3931 3932 Vis_Prims_List : Elist_Id := No_Elist; 3933 -- List of primitives made temporarily visible in the instantiation 3934 -- to match the visibility of the formal type 3935 3936 -- Start of processing for Analyze_Package_Instantiation 3937 3938 begin 3939 -- Preserve relevant elaboration-related attributes of the context which 3940 -- are no longer available or very expensive to recompute once analysis, 3941 -- resolution, and expansion are over. 3942 3943 Mark_Elaboration_Attributes 3944 (N_Id => N, 3945 Checks => True, 3946 Level => True, 3947 Modes => True, 3948 Warnings => True); 3949 3950 Check_SPARK_05_Restriction ("generic is not allowed", N); 3951 3952 -- Very first thing: check for Text_IO special unit in case we are 3953 -- instantiating one of the children of [[Wide_]Wide_]Text_IO. 3954 3955 Check_Text_IO_Special_Unit (Name (N)); 3956 3957 -- Make node global for error reporting 3958 3959 Instantiation_Node := N; 3960 3961 -- Case of instantiation of a generic package 3962 3963 if Nkind (N) = N_Package_Instantiation then 3964 Act_Decl_Id := New_Copy (Defining_Entity (N)); 3965 Set_Comes_From_Source (Act_Decl_Id, True); 3966 3967 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then 3968 Act_Decl_Name := 3969 Make_Defining_Program_Unit_Name (Loc, 3970 Name => 3971 New_Copy_Tree (Name (Defining_Unit_Name (N))), 3972 Defining_Identifier => Act_Decl_Id); 3973 else 3974 Act_Decl_Name := Act_Decl_Id; 3975 end if; 3976 3977 -- Case of instantiation of a formal package 3978 3979 else 3980 Act_Decl_Id := Defining_Identifier (N); 3981 Act_Decl_Name := Act_Decl_Id; 3982 end if; 3983 3984 Generate_Definition (Act_Decl_Id); 3985 Set_Ekind (Act_Decl_Id, E_Package); 3986 3987 -- Initialize list of incomplete actuals before analysis 3988 3989 Set_Incomplete_Actuals (Act_Decl_Id, New_Elmt_List); 3990 3991 Preanalyze_Actuals (N, Act_Decl_Id); 3992 3993 -- Turn off style checking in instances. If the check is enabled on the 3994 -- generic unit, a warning in an instance would just be noise. If not 3995 -- enabled on the generic, then a warning in an instance is just wrong. 3996 -- This must be done after analyzing the actuals, which do come from 3997 -- source and are subject to style checking. 3998 3999 Style_Check := False; 4000 4001 Init_Env; 4002 Env_Installed := True; 4003 4004 -- Reset renaming map for formal types. The mapping is established 4005 -- when analyzing the generic associations, but some mappings are 4006 -- inherited from formal packages of parent units, and these are 4007 -- constructed when the parents are installed. 4008 4009 Generic_Renamings.Set_Last (0); 4010 Generic_Renamings_HTable.Reset; 4011 4012 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 4013 Gen_Unit := Entity (Gen_Id); 4014 4015 -- A package instantiation is Ghost when it is subject to pragma Ghost 4016 -- or the generic template is Ghost. Set the mode now to ensure that 4017 -- any nodes generated during analysis and expansion are marked as 4018 -- Ghost. 4019 4020 Mark_And_Set_Ghost_Instantiation (N, Gen_Unit); 4021 4022 -- Verify that it is the name of a generic package 4023 4024 -- A visibility glitch: if the instance is a child unit and the generic 4025 -- is the generic unit of a parent instance (i.e. both the parent and 4026 -- the child units are instances of the same package) the name now 4027 -- denotes the renaming within the parent, not the intended generic 4028 -- unit. See if there is a homonym that is the desired generic. The 4029 -- renaming declaration must be visible inside the instance of the 4030 -- child, but not when analyzing the name in the instantiation itself. 4031 4032 if Ekind (Gen_Unit) = E_Package 4033 and then Present (Renamed_Entity (Gen_Unit)) 4034 and then In_Open_Scopes (Renamed_Entity (Gen_Unit)) 4035 and then Is_Generic_Instance (Renamed_Entity (Gen_Unit)) 4036 and then Present (Homonym (Gen_Unit)) 4037 then 4038 Gen_Unit := Homonym (Gen_Unit); 4039 end if; 4040 4041 if Etype (Gen_Unit) = Any_Type then 4042 Restore_Env; 4043 goto Leave; 4044 4045 elsif Ekind (Gen_Unit) /= E_Generic_Package then 4046 4047 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause 4048 4049 if From_Limited_With (Gen_Unit) then 4050 Error_Msg_N 4051 ("cannot instantiate a limited withed package", Gen_Id); 4052 else 4053 Error_Msg_NE 4054 ("& is not the name of a generic package", Gen_Id, Gen_Unit); 4055 end if; 4056 4057 Restore_Env; 4058 goto Leave; 4059 end if; 4060 4061 if In_Extended_Main_Source_Unit (N) then 4062 Set_Is_Instantiated (Gen_Unit); 4063 Generate_Reference (Gen_Unit, N); 4064 4065 if Present (Renamed_Object (Gen_Unit)) then 4066 Set_Is_Instantiated (Renamed_Object (Gen_Unit)); 4067 Generate_Reference (Renamed_Object (Gen_Unit), N); 4068 end if; 4069 end if; 4070 4071 if Nkind (Gen_Id) = N_Identifier 4072 and then Chars (Gen_Unit) = Chars (Defining_Entity (N)) 4073 then 4074 Error_Msg_NE 4075 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 4076 4077 elsif Nkind (Gen_Id) = N_Expanded_Name 4078 and then Is_Child_Unit (Gen_Unit) 4079 and then Nkind (Prefix (Gen_Id)) = N_Identifier 4080 and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id)) 4081 then 4082 Error_Msg_N 4083 ("& is hidden within declaration of instance ", Prefix (Gen_Id)); 4084 end if; 4085 4086 Set_Entity (Gen_Id, Gen_Unit); 4087 4088 -- If generic is a renaming, get original generic unit 4089 4090 if Present (Renamed_Object (Gen_Unit)) 4091 and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package 4092 then 4093 Gen_Unit := Renamed_Object (Gen_Unit); 4094 end if; 4095 4096 -- Verify that there are no circular instantiations 4097 4098 if In_Open_Scopes (Gen_Unit) then 4099 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); 4100 Restore_Env; 4101 goto Leave; 4102 4103 elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then 4104 Error_Msg_Node_2 := Current_Scope; 4105 Error_Msg_NE 4106 ("circular Instantiation: & instantiated in &!", N, Gen_Unit); 4107 Circularity_Detected := True; 4108 Restore_Env; 4109 goto Leave; 4110 4111 else 4112 -- If the context of the instance is subject to SPARK_Mode "off" or 4113 -- the annotation is altogether missing, set the global flag which 4114 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within 4115 -- the instance. 4116 4117 if SPARK_Mode /= On then 4118 Ignore_SPARK_Mode_Pragmas_In_Instance := True; 4119 4120 -- Mark the instance spec in case the body is instantiated at a 4121 -- later pass. This preserves the original context in effect for 4122 -- the body. 4123 4124 Set_Ignore_SPARK_Mode_Pragmas (Act_Decl_Id); 4125 end if; 4126 4127 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 4128 Gen_Spec := Specification (Gen_Decl); 4129 4130 -- Initialize renamings map, for error checking, and the list that 4131 -- holds private entities whose views have changed between generic 4132 -- definition and instantiation. If this is the instance created to 4133 -- validate an actual package, the instantiation environment is that 4134 -- of the enclosing instance. 4135 4136 Create_Instantiation_Source (N, Gen_Unit, S_Adjustment); 4137 4138 -- Copy original generic tree, to produce text for instantiation 4139 4140 Act_Tree := 4141 Copy_Generic_Node 4142 (Original_Node (Gen_Decl), Empty, Instantiating => True); 4143 4144 Act_Spec := Specification (Act_Tree); 4145 4146 -- If this is the instance created to validate an actual package, 4147 -- only the formals matter, do not examine the package spec itself. 4148 4149 if Is_Actual_Pack then 4150 Set_Visible_Declarations (Act_Spec, New_List); 4151 Set_Private_Declarations (Act_Spec, New_List); 4152 end if; 4153 4154 Renaming_List := 4155 Analyze_Associations 4156 (I_Node => N, 4157 Formals => Generic_Formal_Declarations (Act_Tree), 4158 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 4159 4160 Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); 4161 4162 Set_Instance_Env (Gen_Unit, Act_Decl_Id); 4163 Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name); 4164 Set_Is_Generic_Instance (Act_Decl_Id); 4165 Set_Generic_Parent (Act_Spec, Gen_Unit); 4166 4167 -- References to the generic in its own declaration or its body are 4168 -- references to the instance. Add a renaming declaration for the 4169 -- generic unit itself. This declaration, as well as the renaming 4170 -- declarations for the generic formals, must remain private to the 4171 -- unit: the formals, because this is the language semantics, and 4172 -- the unit because its use is an artifact of the implementation. 4173 4174 Unit_Renaming := 4175 Make_Package_Renaming_Declaration (Loc, 4176 Defining_Unit_Name => 4177 Make_Defining_Identifier (Loc, Chars (Gen_Unit)), 4178 Name => New_Occurrence_Of (Act_Decl_Id, Loc)); 4179 4180 Append (Unit_Renaming, Renaming_List); 4181 4182 -- The renaming declarations are the first local declarations of the 4183 -- new unit. 4184 4185 if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then 4186 Insert_List_Before 4187 (First (Visible_Declarations (Act_Spec)), Renaming_List); 4188 else 4189 Set_Visible_Declarations (Act_Spec, Renaming_List); 4190 end if; 4191 4192 Act_Decl := Make_Package_Declaration (Loc, Specification => Act_Spec); 4193 4194 -- Propagate the aspect specifications from the package declaration 4195 -- template to the instantiated version of the package declaration. 4196 4197 if Has_Aspects (Act_Tree) then 4198 Set_Aspect_Specifications (Act_Decl, 4199 New_Copy_List_Tree (Aspect_Specifications (Act_Tree))); 4200 end if; 4201 4202 -- The generic may have a generated Default_Storage_Pool aspect, 4203 -- set at the point of generic declaration. If the instance has 4204 -- that aspect, it overrides the one inherited from the generic. 4205 4206 if Has_Aspects (Gen_Spec) then 4207 if No (Aspect_Specifications (N)) then 4208 Set_Aspect_Specifications (N, 4209 (New_Copy_List_Tree 4210 (Aspect_Specifications (Gen_Spec)))); 4211 4212 else 4213 declare 4214 Inherited_Aspects : constant List_Id := 4215 New_Copy_List_Tree 4216 (Aspect_Specifications (Gen_Spec)); 4217 4218 ASN1 : Node_Id; 4219 ASN2 : Node_Id; 4220 Pool_Present : Boolean := False; 4221 4222 begin 4223 ASN1 := First (Aspect_Specifications (N)); 4224 while Present (ASN1) loop 4225 if Chars (Identifier (ASN1)) = 4226 Name_Default_Storage_Pool 4227 then 4228 Pool_Present := True; 4229 exit; 4230 end if; 4231 4232 Next (ASN1); 4233 end loop; 4234 4235 if Pool_Present then 4236 4237 -- If generic carries a default storage pool, remove it 4238 -- in favor of the instance one. 4239 4240 ASN2 := First (Inherited_Aspects); 4241 while Present (ASN2) loop 4242 if Chars (Identifier (ASN2)) = 4243 Name_Default_Storage_Pool 4244 then 4245 Remove (ASN2); 4246 exit; 4247 end if; 4248 4249 Next (ASN2); 4250 end loop; 4251 end if; 4252 4253 Prepend_List_To 4254 (Aspect_Specifications (N), Inherited_Aspects); 4255 end; 4256 end if; 4257 end if; 4258 4259 -- Save the instantiation node, for subsequent instantiation of the 4260 -- body, if there is one and we are generating code for the current 4261 -- unit. Mark unit as having a body (avoids premature error message). 4262 4263 -- We instantiate the body if we are generating code, if we are 4264 -- generating cross-reference information, or if we are building 4265 -- trees for ASIS use or GNATprove use. 4266 4267 declare 4268 Enclosing_Body_Present : Boolean := False; 4269 -- If the generic unit is not a compilation unit, then a body may 4270 -- be present in its parent even if none is required. We create a 4271 -- tentative pending instantiation for the body, which will be 4272 -- discarded if none is actually present. 4273 4274 Scop : Entity_Id; 4275 4276 begin 4277 if Scope (Gen_Unit) /= Standard_Standard 4278 and then not Is_Child_Unit (Gen_Unit) 4279 then 4280 Scop := Scope (Gen_Unit); 4281 while Present (Scop) and then Scop /= Standard_Standard loop 4282 if Unit_Requires_Body (Scop) then 4283 Enclosing_Body_Present := True; 4284 exit; 4285 4286 elsif In_Open_Scopes (Scop) 4287 and then In_Package_Body (Scop) 4288 then 4289 Enclosing_Body_Present := True; 4290 exit; 4291 end if; 4292 4293 exit when Is_Compilation_Unit (Scop); 4294 Scop := Scope (Scop); 4295 end loop; 4296 end if; 4297 4298 -- If front-end inlining is enabled or there are any subprograms 4299 -- marked with Inline_Always, and this is a unit for which code 4300 -- will be generated, we instantiate the body at once. 4301 4302 -- This is done if the instance is not the main unit, and if the 4303 -- generic is not a child unit of another generic, to avoid scope 4304 -- problems and the reinstallation of parent instances. 4305 4306 if Expander_Active 4307 and then (not Is_Child_Unit (Gen_Unit) 4308 or else not Is_Generic_Unit (Scope (Gen_Unit))) 4309 and then Might_Inline_Subp (Gen_Unit) 4310 and then not Is_Actual_Pack 4311 then 4312 if not Back_End_Inlining 4313 and then (Front_End_Inlining or else Has_Inline_Always) 4314 and then (Is_In_Main_Unit (N) 4315 or else In_Main_Context (Current_Scope)) 4316 and then Nkind (Parent (N)) /= N_Compilation_Unit 4317 then 4318 Inline_Now := True; 4319 4320 -- In configurable_run_time mode we force the inlining of 4321 -- predefined subprograms marked Inline_Always, to minimize 4322 -- the use of the run-time library. 4323 4324 elsif In_Predefined_Unit (Gen_Decl) 4325 and then Configurable_Run_Time_Mode 4326 and then Nkind (Parent (N)) /= N_Compilation_Unit 4327 then 4328 Inline_Now := True; 4329 end if; 4330 4331 -- If the current scope is itself an instance within a child 4332 -- unit, there will be duplications in the scope stack, and the 4333 -- unstacking mechanism in Inline_Instance_Body will fail. 4334 -- This loses some rare cases of optimization, and might be 4335 -- improved some day, if we can find a proper abstraction for 4336 -- "the complete compilation context" that can be saved and 4337 -- restored. ??? 4338 4339 if Is_Generic_Instance (Current_Scope) then 4340 declare 4341 Curr_Unit : constant Entity_Id := 4342 Cunit_Entity (Current_Sem_Unit); 4343 begin 4344 if Curr_Unit /= Current_Scope 4345 and then Is_Child_Unit (Curr_Unit) 4346 then 4347 Inline_Now := False; 4348 end if; 4349 end; 4350 end if; 4351 end if; 4352 4353 Needs_Body := 4354 (Unit_Requires_Body (Gen_Unit) 4355 or else Enclosing_Body_Present 4356 or else Present (Corresponding_Body (Gen_Decl))) 4357 and then (Is_In_Main_Unit (N) 4358 or else Might_Inline_Subp (Gen_Unit)) 4359 and then not Is_Actual_Pack 4360 and then not Inline_Now 4361 and then (Operating_Mode = Generate_Code 4362 4363 -- Need comment for this check ??? 4364 4365 or else (Operating_Mode = Check_Semantics 4366 and then (ASIS_Mode or GNATprove_Mode))); 4367 4368 -- If front-end inlining is enabled or there are any subprograms 4369 -- marked with Inline_Always, do not instantiate body when within 4370 -- a generic context. 4371 4372 if ((Front_End_Inlining or else Has_Inline_Always) 4373 and then not Expander_Active) 4374 or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) 4375 then 4376 Needs_Body := False; 4377 end if; 4378 4379 -- If the current context is generic, and the package being 4380 -- instantiated is declared within a formal package, there is no 4381 -- body to instantiate until the enclosing generic is instantiated 4382 -- and there is an actual for the formal package. If the formal 4383 -- package has parameters, we build a regular package instance for 4384 -- it, that precedes the original formal package declaration. 4385 4386 if In_Open_Scopes (Scope (Scope (Gen_Unit))) then 4387 declare 4388 Decl : constant Node_Id := 4389 Original_Node 4390 (Unit_Declaration_Node (Scope (Gen_Unit))); 4391 begin 4392 if Nkind (Decl) = N_Formal_Package_Declaration 4393 or else (Nkind (Decl) = N_Package_Declaration 4394 and then Is_List_Member (Decl) 4395 and then Present (Next (Decl)) 4396 and then 4397 Nkind (Next (Decl)) = 4398 N_Formal_Package_Declaration) 4399 then 4400 Needs_Body := False; 4401 end if; 4402 end; 4403 end if; 4404 end; 4405 4406 -- For RCI unit calling stubs, we omit the instance body if the 4407 -- instance is the RCI library unit itself. 4408 4409 -- However there is a special case for nested instances: in this case 4410 -- we do generate the instance body, as it might be required, e.g. 4411 -- because it provides stream attributes for some type used in the 4412 -- profile of a remote subprogram. This is consistent with 12.3(12), 4413 -- which indicates that the instance body occurs at the place of the 4414 -- instantiation, and thus is part of the RCI declaration, which is 4415 -- present on all client partitions (this is E.2.3(18)). 4416 4417 -- Note that AI12-0002 may make it illegal at some point to have 4418 -- stream attributes defined in an RCI unit, in which case this 4419 -- special case will become unnecessary. In the meantime, there 4420 -- is known application code in production that depends on this 4421 -- being possible, so we definitely cannot eliminate the body in 4422 -- the case of nested instances for the time being. 4423 4424 -- When we generate a nested instance body, calling stubs for any 4425 -- relevant subprogram will be be inserted immediately after the 4426 -- subprogram declarations, and will take precedence over the 4427 -- subsequent (original) body. (The stub and original body will be 4428 -- complete homographs, but this is permitted in an instance). 4429 -- (Could we do better and remove the original body???) 4430 4431 if Distribution_Stub_Mode = Generate_Caller_Stub_Body 4432 and then Comes_From_Source (N) 4433 and then Nkind (Parent (N)) = N_Compilation_Unit 4434 then 4435 Needs_Body := False; 4436 end if; 4437 4438 if Needs_Body then 4439 4440 -- Here is a defence against a ludicrous number of instantiations 4441 -- caused by a circular set of instantiation attempts. 4442 4443 if Pending_Instantiations.Last > Maximum_Instantiations then 4444 Error_Msg_Uint_1 := UI_From_Int (Maximum_Instantiations); 4445 Error_Msg_N ("too many instantiations, exceeds max of^", N); 4446 Error_Msg_N ("\limit can be changed using -gnateinn switch", N); 4447 raise Unrecoverable_Error; 4448 end if; 4449 4450 -- Indicate that the enclosing scopes contain an instantiation, 4451 -- and that cleanup actions should be delayed until after the 4452 -- instance body is expanded. 4453 4454 Check_Forward_Instantiation (Gen_Decl); 4455 if Nkind (N) = N_Package_Instantiation then 4456 declare 4457 Enclosing_Master : Entity_Id; 4458 4459 begin 4460 -- Loop to search enclosing masters 4461 4462 Enclosing_Master := Current_Scope; 4463 Scope_Loop : while Enclosing_Master /= Standard_Standard loop 4464 if Ekind (Enclosing_Master) = E_Package then 4465 if Is_Compilation_Unit (Enclosing_Master) then 4466 if In_Package_Body (Enclosing_Master) then 4467 Delay_Descriptors 4468 (Body_Entity (Enclosing_Master)); 4469 else 4470 Delay_Descriptors 4471 (Enclosing_Master); 4472 end if; 4473 4474 exit Scope_Loop; 4475 4476 else 4477 Enclosing_Master := Scope (Enclosing_Master); 4478 end if; 4479 4480 elsif Is_Generic_Unit (Enclosing_Master) 4481 or else Ekind (Enclosing_Master) = E_Void 4482 then 4483 -- Cleanup actions will eventually be performed on the 4484 -- enclosing subprogram or package instance, if any. 4485 -- Enclosing scope is void in the formal part of a 4486 -- generic subprogram. 4487 4488 exit Scope_Loop; 4489 4490 else 4491 if Ekind (Enclosing_Master) = E_Entry 4492 and then 4493 Ekind (Scope (Enclosing_Master)) = E_Protected_Type 4494 then 4495 if not Expander_Active then 4496 exit Scope_Loop; 4497 else 4498 Enclosing_Master := 4499 Protected_Body_Subprogram (Enclosing_Master); 4500 end if; 4501 end if; 4502 4503 Set_Delay_Cleanups (Enclosing_Master); 4504 4505 while Ekind (Enclosing_Master) = E_Block loop 4506 Enclosing_Master := Scope (Enclosing_Master); 4507 end loop; 4508 4509 if Is_Subprogram (Enclosing_Master) then 4510 Delay_Descriptors (Enclosing_Master); 4511 4512 elsif Is_Task_Type (Enclosing_Master) then 4513 declare 4514 TBP : constant Node_Id := 4515 Get_Task_Body_Procedure 4516 (Enclosing_Master); 4517 begin 4518 if Present (TBP) then 4519 Delay_Descriptors (TBP); 4520 Set_Delay_Cleanups (TBP); 4521 end if; 4522 end; 4523 end if; 4524 4525 exit Scope_Loop; 4526 end if; 4527 end loop Scope_Loop; 4528 end; 4529 4530 -- Make entry in table 4531 4532 Add_Pending_Instantiation (N, Act_Decl); 4533 end if; 4534 end if; 4535 4536 Set_Categorization_From_Pragmas (Act_Decl); 4537 4538 if Parent_Installed then 4539 Hide_Current_Scope; 4540 end if; 4541 4542 Set_Instance_Spec (N, Act_Decl); 4543 4544 -- If not a compilation unit, insert the package declaration before 4545 -- the original instantiation node. 4546 4547 if Nkind (Parent (N)) /= N_Compilation_Unit then 4548 Mark_Rewrite_Insertion (Act_Decl); 4549 Insert_Before (N, Act_Decl); 4550 4551 if Has_Aspects (N) then 4552 Analyze_Aspect_Specifications (N, Act_Decl_Id); 4553 4554 -- The pragma created for a Default_Storage_Pool aspect must 4555 -- appear ahead of the declarations in the instance spec. 4556 -- Analysis has placed it after the instance node, so remove 4557 -- it and reinsert it properly now. 4558 4559 declare 4560 ASN : constant Node_Id := First (Aspect_Specifications (N)); 4561 A_Name : constant Name_Id := Chars (Identifier (ASN)); 4562 Decl : Node_Id; 4563 4564 begin 4565 if A_Name = Name_Default_Storage_Pool then 4566 if No (Visible_Declarations (Act_Spec)) then 4567 Set_Visible_Declarations (Act_Spec, New_List); 4568 end if; 4569 4570 Decl := Next (N); 4571 while Present (Decl) loop 4572 if Nkind (Decl) = N_Pragma then 4573 Remove (Decl); 4574 Prepend (Decl, Visible_Declarations (Act_Spec)); 4575 exit; 4576 end if; 4577 4578 Next (Decl); 4579 end loop; 4580 end if; 4581 end; 4582 end if; 4583 4584 Analyze (Act_Decl); 4585 4586 -- For an instantiation that is a compilation unit, place 4587 -- declaration on current node so context is complete for analysis 4588 -- (including nested instantiations). If this is the main unit, 4589 -- the declaration eventually replaces the instantiation node. 4590 -- If the instance body is created later, it replaces the 4591 -- instance node, and the declaration is attached to it 4592 -- (see Build_Instance_Compilation_Unit_Nodes). 4593 4594 else 4595 if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then 4596 4597 -- The entity for the current unit is the newly created one, 4598 -- and all semantic information is attached to it. 4599 4600 Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id); 4601 4602 -- If this is the main unit, replace the main entity as well 4603 4604 if Current_Sem_Unit = Main_Unit then 4605 Main_Unit_Entity := Act_Decl_Id; 4606 end if; 4607 end if; 4608 4609 Set_Unit (Parent (N), Act_Decl); 4610 Set_Parent_Spec (Act_Decl, Parent_Spec (N)); 4611 Set_Package_Instantiation (Act_Decl_Id, N); 4612 4613 -- Process aspect specifications of the instance node, if any, to 4614 -- take into account categorization pragmas before analyzing the 4615 -- instance. 4616 4617 if Has_Aspects (N) then 4618 Analyze_Aspect_Specifications (N, Act_Decl_Id); 4619 end if; 4620 4621 Analyze (Act_Decl); 4622 Set_Unit (Parent (N), N); 4623 Set_Body_Required (Parent (N), False); 4624 4625 -- We never need elaboration checks on instantiations, since by 4626 -- definition, the body instantiation is elaborated at the same 4627 -- time as the spec instantiation. 4628 4629 if Legacy_Elaboration_Checks then 4630 Set_Kill_Elaboration_Checks (Act_Decl_Id); 4631 Set_Suppress_Elaboration_Warnings (Act_Decl_Id); 4632 end if; 4633 end if; 4634 4635 if Legacy_Elaboration_Checks then 4636 Check_Elab_Instantiation (N); 4637 end if; 4638 4639 -- Save the scenario for later examination by the ABE Processing 4640 -- phase. 4641 4642 Record_Elaboration_Scenario (N); 4643 4644 -- The instantiation results in a guaranteed ABE 4645 4646 if Is_Known_Guaranteed_ABE (N) and then Needs_Body then 4647 4648 -- Do not instantiate the corresponding body because gigi cannot 4649 -- handle certain types of premature instantiations. 4650 4651 Pending_Instantiations.Decrement_Last; 4652 4653 -- Create completing bodies for all subprogram declarations since 4654 -- their real bodies will not be instantiated. 4655 4656 Provide_Completing_Bodies (Instance_Spec (N)); 4657 end if; 4658 4659 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); 4660 4661 Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming), 4662 First_Private_Entity (Act_Decl_Id)); 4663 4664 -- If the instantiation will receive a body, the unit will be 4665 -- transformed into a package body, and receive its own elaboration 4666 -- entity. Otherwise, the nature of the unit is now a package 4667 -- declaration. 4668 4669 if Nkind (Parent (N)) = N_Compilation_Unit 4670 and then not Needs_Body 4671 then 4672 Rewrite (N, Act_Decl); 4673 end if; 4674 4675 if Present (Corresponding_Body (Gen_Decl)) 4676 or else Unit_Requires_Body (Gen_Unit) 4677 then 4678 Set_Has_Completion (Act_Decl_Id); 4679 end if; 4680 4681 Check_Formal_Packages (Act_Decl_Id); 4682 4683 Restore_Hidden_Primitives (Vis_Prims_List); 4684 Restore_Private_Views (Act_Decl_Id); 4685 4686 Inherit_Context (Gen_Decl, N); 4687 4688 if Parent_Installed then 4689 Remove_Parent; 4690 end if; 4691 4692 Restore_Env; 4693 Env_Installed := False; 4694 end if; 4695 4696 Validate_Categorization_Dependency (N, Act_Decl_Id); 4697 4698 -- There used to be a check here to prevent instantiations in local 4699 -- contexts if the No_Local_Allocators restriction was active. This 4700 -- check was removed by a binding interpretation in AI-95-00130/07, 4701 -- but we retain the code for documentation purposes. 4702 4703 -- if Ekind (Act_Decl_Id) /= E_Void 4704 -- and then not Is_Library_Level_Entity (Act_Decl_Id) 4705 -- then 4706 -- Check_Restriction (No_Local_Allocators, N); 4707 -- end if; 4708 4709 if Inline_Now then 4710 Inline_Instance_Body (N, Gen_Unit, Act_Decl); 4711 end if; 4712 4713 -- The following is a tree patch for ASIS: ASIS needs separate nodes to 4714 -- be used as defining identifiers for a formal package and for the 4715 -- corresponding expanded package. 4716 4717 if Nkind (N) = N_Formal_Package_Declaration then 4718 Act_Decl_Id := New_Copy (Defining_Entity (N)); 4719 Set_Comes_From_Source (Act_Decl_Id, True); 4720 Set_Is_Generic_Instance (Act_Decl_Id, False); 4721 Set_Defining_Identifier (N, Act_Decl_Id); 4722 end if; 4723 4724 -- Check that if N is an instantiation of System.Dim_Float_IO or 4725 -- System.Dim_Integer_IO, the formal type has a dimension system. 4726 4727 if Nkind (N) = N_Package_Instantiation 4728 and then Is_Dim_IO_Package_Instantiation (N) 4729 then 4730 declare 4731 Assoc : constant Node_Id := First (Generic_Associations (N)); 4732 begin 4733 if not Has_Dimension_System 4734 (Etype (Explicit_Generic_Actual_Parameter (Assoc))) 4735 then 4736 Error_Msg_N ("type with a dimension system expected", Assoc); 4737 end if; 4738 end; 4739 end if; 4740 4741 <<Leave>> 4742 if Has_Aspects (N) and then Nkind (Parent (N)) /= N_Compilation_Unit then 4743 Analyze_Aspect_Specifications (N, Act_Decl_Id); 4744 end if; 4745 4746 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 4747 Restore_Ghost_Region (Saved_GM, Saved_IGR); 4748 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 4749 Style_Check := Saved_Style_Check; 4750 4751 exception 4752 when Instantiation_Error => 4753 if Parent_Installed then 4754 Remove_Parent; 4755 end if; 4756 4757 if Env_Installed then 4758 Restore_Env; 4759 end if; 4760 4761 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 4762 Restore_Ghost_Region (Saved_GM, Saved_IGR); 4763 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 4764 Style_Check := Saved_Style_Check; 4765 end Analyze_Package_Instantiation; 4766 4767 -------------------------- 4768 -- Inline_Instance_Body -- 4769 -------------------------- 4770 4771 -- WARNING: This routine manages SPARK regions. Return statements must be 4772 -- replaced by gotos which jump to the end of the routine and restore the 4773 -- SPARK mode. 4774 4775 procedure Inline_Instance_Body 4776 (N : Node_Id; 4777 Gen_Unit : Entity_Id; 4778 Act_Decl : Node_Id) 4779 is 4780 Config_Attrs : constant Config_Switches_Type := Save_Config_Switches; 4781 4782 Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit); 4783 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 4784 Gen_Comp : constant Entity_Id := 4785 Cunit_Entity (Get_Source_Unit (Gen_Unit)); 4786 4787 Scope_Stack_Depth : constant Pos := 4788 Scope_Stack.Last - Scope_Stack.First + 1; 4789 4790 Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id; 4791 Instances : array (1 .. Scope_Stack_Depth) of Entity_Id; 4792 Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id; 4793 4794 Curr_Scope : Entity_Id := Empty; 4795 List : Elist_Id := No_Elist; -- init to avoid warning 4796 N_Instances : Nat := 0; 4797 Num_Inner : Nat := 0; 4798 Num_Scopes : Nat := 0; 4799 Removed : Boolean := False; 4800 S : Entity_Id; 4801 Vis : Boolean; 4802 4803 begin 4804 -- Case of generic unit defined in another unit. We must remove the 4805 -- complete context of the current unit to install that of the generic. 4806 4807 if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then 4808 4809 -- Add some comments for the following two loops ??? 4810 4811 S := Current_Scope; 4812 while Present (S) and then S /= Standard_Standard loop 4813 loop 4814 Num_Scopes := Num_Scopes + 1; 4815 4816 Use_Clauses (Num_Scopes) := 4817 (Scope_Stack.Table 4818 (Scope_Stack.Last - Num_Scopes + 1). 4819 First_Use_Clause); 4820 End_Use_Clauses (Use_Clauses (Num_Scopes)); 4821 4822 exit when Scope_Stack.Last - Num_Scopes + 1 = Scope_Stack.First 4823 or else Scope_Stack.Table 4824 (Scope_Stack.Last - Num_Scopes).Entity = Scope (S); 4825 end loop; 4826 4827 exit when Is_Generic_Instance (S) 4828 and then (In_Package_Body (S) 4829 or else Ekind (S) = E_Procedure 4830 or else Ekind (S) = E_Function); 4831 S := Scope (S); 4832 end loop; 4833 4834 Vis := Is_Immediately_Visible (Gen_Comp); 4835 4836 -- Find and save all enclosing instances 4837 4838 S := Current_Scope; 4839 4840 while Present (S) 4841 and then S /= Standard_Standard 4842 loop 4843 if Is_Generic_Instance (S) then 4844 N_Instances := N_Instances + 1; 4845 Instances (N_Instances) := S; 4846 4847 exit when In_Package_Body (S); 4848 end if; 4849 4850 S := Scope (S); 4851 end loop; 4852 4853 -- Remove context of current compilation unit, unless we are within a 4854 -- nested package instantiation, in which case the context has been 4855 -- removed previously. 4856 4857 -- If current scope is the body of a child unit, remove context of 4858 -- spec as well. If an enclosing scope is an instance body, the 4859 -- context has already been removed, but the entities in the body 4860 -- must be made invisible as well. 4861 4862 S := Current_Scope; 4863 while Present (S) and then S /= Standard_Standard loop 4864 if Is_Generic_Instance (S) 4865 and then (In_Package_Body (S) 4866 or else Ekind_In (S, E_Procedure, E_Function)) 4867 then 4868 -- We still have to remove the entities of the enclosing 4869 -- instance from direct visibility. 4870 4871 declare 4872 E : Entity_Id; 4873 begin 4874 E := First_Entity (S); 4875 while Present (E) loop 4876 Set_Is_Immediately_Visible (E, False); 4877 Next_Entity (E); 4878 end loop; 4879 end; 4880 4881 exit; 4882 end if; 4883 4884 if S = Curr_Unit 4885 or else (Ekind (Curr_Unit) = E_Package_Body 4886 and then S = Spec_Entity (Curr_Unit)) 4887 or else (Ekind (Curr_Unit) = E_Subprogram_Body 4888 and then S = Corresponding_Spec 4889 (Unit_Declaration_Node (Curr_Unit))) 4890 then 4891 Removed := True; 4892 4893 -- Remove entities in current scopes from visibility, so that 4894 -- instance body is compiled in a clean environment. 4895 4896 List := Save_Scope_Stack (Handle_Use => False); 4897 4898 if Is_Child_Unit (S) then 4899 4900 -- Remove child unit from stack, as well as inner scopes. 4901 -- Removing the context of a child unit removes parent units 4902 -- as well. 4903 4904 while Current_Scope /= S loop 4905 Num_Inner := Num_Inner + 1; 4906 Inner_Scopes (Num_Inner) := Current_Scope; 4907 Pop_Scope; 4908 end loop; 4909 4910 Pop_Scope; 4911 Remove_Context (Curr_Comp); 4912 Curr_Scope := S; 4913 4914 else 4915 Remove_Context (Curr_Comp); 4916 end if; 4917 4918 if Ekind (Curr_Unit) = E_Package_Body then 4919 Remove_Context (Library_Unit (Curr_Comp)); 4920 end if; 4921 end if; 4922 4923 S := Scope (S); 4924 end loop; 4925 4926 pragma Assert (Num_Inner < Num_Scopes); 4927 4928 Push_Scope (Standard_Standard); 4929 Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True; 4930 4931 -- The inlined package body is analyzed with the configuration state 4932 -- of the context prior to the scope manipulations performed above. 4933 4934 -- ??? shouldn't this also use the warning state of the context prior 4935 -- to the scope manipulations? 4936 4937 Instantiate_Package_Body 4938 (Body_Info => 4939 ((Act_Decl => Act_Decl, 4940 Config_Switches => Config_Attrs, 4941 Current_Sem_Unit => Current_Sem_Unit, 4942 Expander_Status => Expander_Active, 4943 Inst_Node => N, 4944 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 4945 Scope_Suppress => Scope_Suppress, 4946 Warnings => Save_Warnings)), 4947 Inlined_Body => True); 4948 4949 Pop_Scope; 4950 4951 -- Restore context 4952 4953 Set_Is_Immediately_Visible (Gen_Comp, Vis); 4954 4955 -- Reset Generic_Instance flag so that use clauses can be installed 4956 -- in the proper order. (See Use_One_Package for effect of enclosing 4957 -- instances on processing of use clauses). 4958 4959 for J in 1 .. N_Instances loop 4960 Set_Is_Generic_Instance (Instances (J), False); 4961 end loop; 4962 4963 if Removed then 4964 Install_Context (Curr_Comp, Chain => False); 4965 4966 if Present (Curr_Scope) 4967 and then Is_Child_Unit (Curr_Scope) 4968 then 4969 Push_Scope (Curr_Scope); 4970 Set_Is_Immediately_Visible (Curr_Scope); 4971 4972 -- Finally, restore inner scopes as well 4973 4974 for J in reverse 1 .. Num_Inner loop 4975 Push_Scope (Inner_Scopes (J)); 4976 end loop; 4977 end if; 4978 4979 Restore_Scope_Stack (List, Handle_Use => False); 4980 4981 if Present (Curr_Scope) 4982 and then 4983 (In_Private_Part (Curr_Scope) 4984 or else In_Package_Body (Curr_Scope)) 4985 then 4986 -- Install private declaration of ancestor units, which are 4987 -- currently available. Restore_Scope_Stack and Install_Context 4988 -- only install the visible part of parents. 4989 4990 declare 4991 Par : Entity_Id; 4992 begin 4993 Par := Scope (Curr_Scope); 4994 while (Present (Par)) and then Par /= Standard_Standard loop 4995 Install_Private_Declarations (Par); 4996 Par := Scope (Par); 4997 end loop; 4998 end; 4999 end if; 5000 end if; 5001 5002 -- Restore use clauses. For a child unit, use clauses in the parents 5003 -- are restored when installing the context, so only those in inner 5004 -- scopes (and those local to the child unit itself) need to be 5005 -- installed explicitly. 5006 5007 if Is_Child_Unit (Curr_Unit) and then Removed then 5008 for J in reverse 1 .. Num_Inner + 1 loop 5009 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := 5010 Use_Clauses (J); 5011 Install_Use_Clauses (Use_Clauses (J)); 5012 end loop; 5013 5014 else 5015 for J in reverse 1 .. Num_Scopes loop 5016 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := 5017 Use_Clauses (J); 5018 Install_Use_Clauses (Use_Clauses (J)); 5019 end loop; 5020 end if; 5021 5022 -- Restore status of instances. If one of them is a body, make its 5023 -- local entities visible again. 5024 5025 declare 5026 E : Entity_Id; 5027 Inst : Entity_Id; 5028 5029 begin 5030 for J in 1 .. N_Instances loop 5031 Inst := Instances (J); 5032 Set_Is_Generic_Instance (Inst, True); 5033 5034 if In_Package_Body (Inst) 5035 or else Ekind_In (S, E_Procedure, E_Function) 5036 then 5037 E := First_Entity (Instances (J)); 5038 while Present (E) loop 5039 Set_Is_Immediately_Visible (E); 5040 Next_Entity (E); 5041 end loop; 5042 end if; 5043 end loop; 5044 end; 5045 5046 -- If generic unit is in current unit, current context is correct. Note 5047 -- that the context is guaranteed to carry the correct SPARK_Mode as no 5048 -- enclosing scopes were removed. 5049 5050 else 5051 Instantiate_Package_Body 5052 (Body_Info => 5053 ((Act_Decl => Act_Decl, 5054 Config_Switches => Save_Config_Switches, 5055 Current_Sem_Unit => Current_Sem_Unit, 5056 Expander_Status => Expander_Active, 5057 Inst_Node => N, 5058 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 5059 Scope_Suppress => Scope_Suppress, 5060 Warnings => Save_Warnings)), 5061 Inlined_Body => True); 5062 end if; 5063 end Inline_Instance_Body; 5064 5065 ------------------------------------- 5066 -- Analyze_Procedure_Instantiation -- 5067 ------------------------------------- 5068 5069 procedure Analyze_Procedure_Instantiation (N : Node_Id) is 5070 begin 5071 Analyze_Subprogram_Instantiation (N, E_Procedure); 5072 end Analyze_Procedure_Instantiation; 5073 5074 ----------------------------------- 5075 -- Need_Subprogram_Instance_Body -- 5076 ----------------------------------- 5077 5078 function Need_Subprogram_Instance_Body 5079 (N : Node_Id; 5080 Subp : Entity_Id) return Boolean 5081 is 5082 function Is_Inlined_Or_Child_Of_Inlined (E : Entity_Id) return Boolean; 5083 -- Return True if E is an inlined subprogram, an inlined renaming or a 5084 -- subprogram nested in an inlined subprogram. The inlining machinery 5085 -- totally disregards nested subprograms since it considers that they 5086 -- will always be compiled if the parent is (see Inline.Is_Nested). 5087 5088 ------------------------------------ 5089 -- Is_Inlined_Or_Child_Of_Inlined -- 5090 ------------------------------------ 5091 5092 function Is_Inlined_Or_Child_Of_Inlined (E : Entity_Id) return Boolean is 5093 Scop : Entity_Id; 5094 5095 begin 5096 if Is_Inlined (E) or else Is_Inlined (Alias (E)) then 5097 return True; 5098 end if; 5099 5100 Scop := Scope (E); 5101 while Scop /= Standard_Standard loop 5102 if Ekind (Scop) in Subprogram_Kind and then Is_Inlined (Scop) then 5103 return True; 5104 end if; 5105 5106 Scop := Scope (Scop); 5107 end loop; 5108 5109 return False; 5110 end Is_Inlined_Or_Child_Of_Inlined; 5111 5112 begin 5113 -- Must be in the main unit or inlined (or child of inlined) 5114 5115 if (Is_In_Main_Unit (N) or else Is_Inlined_Or_Child_Of_Inlined (Subp)) 5116 5117 -- Must be generating code or analyzing code in ASIS/GNATprove mode 5118 5119 and then (Operating_Mode = Generate_Code 5120 or else (Operating_Mode = Check_Semantics 5121 and then (ASIS_Mode or GNATprove_Mode))) 5122 5123 -- The body is needed when generating code (full expansion), in ASIS 5124 -- mode for other tools, and in GNATprove mode (special expansion) for 5125 -- formal verification of the body itself. 5126 5127 and then (Expander_Active or ASIS_Mode or GNATprove_Mode) 5128 5129 -- No point in inlining if ABE is inevitable 5130 5131 and then not Is_Known_Guaranteed_ABE (N) 5132 5133 -- Or if subprogram is eliminated 5134 5135 and then not Is_Eliminated (Subp) 5136 then 5137 Add_Pending_Instantiation (N, Unit_Declaration_Node (Subp)); 5138 return True; 5139 5140 -- Here if not inlined, or we ignore the inlining 5141 5142 else 5143 return False; 5144 end if; 5145 end Need_Subprogram_Instance_Body; 5146 5147 -------------------------------------- 5148 -- Analyze_Subprogram_Instantiation -- 5149 -------------------------------------- 5150 5151 -- WARNING: This routine manages Ghost and SPARK regions. Return statements 5152 -- must be replaced by gotos which jump to the end of the routine in order 5153 -- to restore the Ghost and SPARK modes. 5154 5155 procedure Analyze_Subprogram_Instantiation 5156 (N : Node_Id; 5157 K : Entity_Kind) 5158 is 5159 Loc : constant Source_Ptr := Sloc (N); 5160 Gen_Id : constant Node_Id := Name (N); 5161 Errs : constant Nat := Serious_Errors_Detected; 5162 5163 Anon_Id : constant Entity_Id := 5164 Make_Defining_Identifier (Sloc (Defining_Entity (N)), 5165 Chars => New_External_Name 5166 (Chars (Defining_Entity (N)), 'R')); 5167 5168 Act_Decl_Id : Entity_Id := Empty; -- init to avoid warning 5169 Act_Decl : Node_Id; 5170 Act_Spec : Node_Id; 5171 Act_Tree : Node_Id; 5172 5173 Env_Installed : Boolean := False; 5174 Gen_Unit : Entity_Id; 5175 Gen_Decl : Node_Id; 5176 Pack_Id : Entity_Id; 5177 Parent_Installed : Boolean := False; 5178 5179 Renaming_List : List_Id; 5180 -- The list of declarations that link formals and actuals of the 5181 -- instance. These are subtype declarations for formal types, and 5182 -- renaming declarations for other formals. The subprogram declaration 5183 -- for the instance is then appended to the list, and the last item on 5184 -- the list is the renaming declaration for the instance. 5185 5186 procedure Analyze_Instance_And_Renamings; 5187 -- The instance must be analyzed in a context that includes the mappings 5188 -- of generic parameters into actuals. We create a package declaration 5189 -- for this purpose, and a subprogram with an internal name within the 5190 -- package. The subprogram instance is simply an alias for the internal 5191 -- subprogram, declared in the current scope. 5192 5193 procedure Build_Subprogram_Renaming; 5194 -- If the subprogram is recursive, there are occurrences of the name of 5195 -- the generic within the body, which must resolve to the current 5196 -- instance. We add a renaming declaration after the declaration, which 5197 -- is available in the instance body, as well as in the analysis of 5198 -- aspects that appear in the generic. This renaming declaration is 5199 -- inserted after the instance declaration which it renames. 5200 5201 ------------------------------------ 5202 -- Analyze_Instance_And_Renamings -- 5203 ------------------------------------ 5204 5205 procedure Analyze_Instance_And_Renamings is 5206 Def_Ent : constant Entity_Id := Defining_Entity (N); 5207 Pack_Decl : Node_Id; 5208 5209 begin 5210 if Nkind (Parent (N)) = N_Compilation_Unit then 5211 5212 -- For the case of a compilation unit, the container package has 5213 -- the same name as the instantiation, to insure that the binder 5214 -- calls the elaboration procedure with the right name. Copy the 5215 -- entity of the instance, which may have compilation level flags 5216 -- (e.g. Is_Child_Unit) set. 5217 5218 Pack_Id := New_Copy (Def_Ent); 5219 5220 else 5221 -- Otherwise we use the name of the instantiation concatenated 5222 -- with its source position to ensure uniqueness if there are 5223 -- several instantiations with the same name. 5224 5225 Pack_Id := 5226 Make_Defining_Identifier (Loc, 5227 Chars => New_External_Name 5228 (Related_Id => Chars (Def_Ent), 5229 Suffix => "GP", 5230 Suffix_Index => Source_Offset (Sloc (Def_Ent)))); 5231 end if; 5232 5233 Pack_Decl := 5234 Make_Package_Declaration (Loc, 5235 Specification => Make_Package_Specification (Loc, 5236 Defining_Unit_Name => Pack_Id, 5237 Visible_Declarations => Renaming_List, 5238 End_Label => Empty)); 5239 5240 Set_Instance_Spec (N, Pack_Decl); 5241 Set_Is_Generic_Instance (Pack_Id); 5242 Set_Debug_Info_Needed (Pack_Id); 5243 5244 -- Case of not a compilation unit 5245 5246 if Nkind (Parent (N)) /= N_Compilation_Unit then 5247 Mark_Rewrite_Insertion (Pack_Decl); 5248 Insert_Before (N, Pack_Decl); 5249 Set_Has_Completion (Pack_Id); 5250 5251 -- Case of an instantiation that is a compilation unit 5252 5253 -- Place declaration on current node so context is complete for 5254 -- analysis (including nested instantiations), and for use in a 5255 -- context_clause (see Analyze_With_Clause). 5256 5257 else 5258 Set_Unit (Parent (N), Pack_Decl); 5259 Set_Parent_Spec (Pack_Decl, Parent_Spec (N)); 5260 end if; 5261 5262 Analyze (Pack_Decl); 5263 Check_Formal_Packages (Pack_Id); 5264 Set_Is_Generic_Instance (Pack_Id, False); 5265 5266 -- Why do we clear Is_Generic_Instance??? We set it 20 lines 5267 -- above??? 5268 5269 -- Body of the enclosing package is supplied when instantiating the 5270 -- subprogram body, after semantic analysis is completed. 5271 5272 if Nkind (Parent (N)) = N_Compilation_Unit then 5273 5274 -- Remove package itself from visibility, so it does not 5275 -- conflict with subprogram. 5276 5277 Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id)); 5278 5279 -- Set name and scope of internal subprogram so that the proper 5280 -- external name will be generated. The proper scope is the scope 5281 -- of the wrapper package. We need to generate debugging info for 5282 -- the internal subprogram, so set flag accordingly. 5283 5284 Set_Chars (Anon_Id, Chars (Defining_Entity (N))); 5285 Set_Scope (Anon_Id, Scope (Pack_Id)); 5286 5287 -- Mark wrapper package as referenced, to avoid spurious warnings 5288 -- if the instantiation appears in various with_ clauses of 5289 -- subunits of the main unit. 5290 5291 Set_Referenced (Pack_Id); 5292 end if; 5293 5294 Set_Is_Generic_Instance (Anon_Id); 5295 Set_Debug_Info_Needed (Anon_Id); 5296 Act_Decl_Id := New_Copy (Anon_Id); 5297 5298 Set_Parent (Act_Decl_Id, Parent (Anon_Id)); 5299 Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N))); 5300 Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N))); 5301 5302 -- Subprogram instance comes from source only if generic does 5303 5304 Set_Comes_From_Source (Act_Decl_Id, Comes_From_Source (Gen_Unit)); 5305 5306 -- If the instance is a child unit, mark the Id accordingly. Mark 5307 -- the anonymous entity as well, which is the real subprogram and 5308 -- which is used when the instance appears in a context clause. 5309 -- Similarly, propagate the Is_Eliminated flag to handle properly 5310 -- nested eliminated subprograms. 5311 5312 Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N))); 5313 Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N))); 5314 New_Overloaded_Entity (Act_Decl_Id); 5315 Check_Eliminated (Act_Decl_Id); 5316 Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id)); 5317 5318 if Nkind (Parent (N)) = N_Compilation_Unit then 5319 5320 -- In compilation unit case, kill elaboration checks on the 5321 -- instantiation, since they are never needed - the body is 5322 -- instantiated at the same point as the spec. 5323 5324 if Legacy_Elaboration_Checks then 5325 Set_Kill_Elaboration_Checks (Act_Decl_Id); 5326 Set_Suppress_Elaboration_Warnings (Act_Decl_Id); 5327 end if; 5328 5329 Set_Is_Compilation_Unit (Anon_Id); 5330 Set_Cunit_Entity (Current_Sem_Unit, Pack_Id); 5331 end if; 5332 5333 -- The instance is not a freezing point for the new subprogram. 5334 -- The anonymous subprogram may have a freeze node, created for 5335 -- some delayed aspects. This freeze node must not be inherited 5336 -- by the visible subprogram entity. 5337 5338 Set_Is_Frozen (Act_Decl_Id, False); 5339 Set_Freeze_Node (Act_Decl_Id, Empty); 5340 5341 if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then 5342 Valid_Operator_Definition (Act_Decl_Id); 5343 end if; 5344 5345 Set_Alias (Act_Decl_Id, Anon_Id); 5346 Set_Has_Completion (Act_Decl_Id); 5347 Set_Related_Instance (Pack_Id, Act_Decl_Id); 5348 5349 if Nkind (Parent (N)) = N_Compilation_Unit then 5350 Set_Body_Required (Parent (N), False); 5351 end if; 5352 end Analyze_Instance_And_Renamings; 5353 5354 ------------------------------- 5355 -- Build_Subprogram_Renaming -- 5356 ------------------------------- 5357 5358 procedure Build_Subprogram_Renaming is 5359 Renaming_Decl : Node_Id; 5360 Unit_Renaming : Node_Id; 5361 5362 begin 5363 Unit_Renaming := 5364 Make_Subprogram_Renaming_Declaration (Loc, 5365 Specification => 5366 Copy_Generic_Node 5367 (Specification (Original_Node (Gen_Decl)), 5368 Empty, 5369 Instantiating => True), 5370 Name => New_Occurrence_Of (Anon_Id, Loc)); 5371 5372 -- The generic may be a a child unit. The renaming needs an 5373 -- identifier with the proper name. 5374 5375 Set_Defining_Unit_Name (Specification (Unit_Renaming), 5376 Make_Defining_Identifier (Loc, Chars (Gen_Unit))); 5377 5378 -- If there is a formal subprogram with the same name as the unit 5379 -- itself, do not add this renaming declaration, to prevent 5380 -- ambiguities when there is a call with that name in the body. 5381 -- This is a partial and ugly fix for one ACATS test. ??? 5382 5383 Renaming_Decl := First (Renaming_List); 5384 while Present (Renaming_Decl) loop 5385 if Nkind (Renaming_Decl) = N_Subprogram_Renaming_Declaration 5386 and then 5387 Chars (Defining_Entity (Renaming_Decl)) = Chars (Gen_Unit) 5388 then 5389 exit; 5390 end if; 5391 5392 Next (Renaming_Decl); 5393 end loop; 5394 5395 if No (Renaming_Decl) then 5396 Append (Unit_Renaming, Renaming_List); 5397 end if; 5398 end Build_Subprogram_Renaming; 5399 5400 -- Local variables 5401 5402 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 5403 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 5404 Saved_ISMP : constant Boolean := 5405 Ignore_SPARK_Mode_Pragmas_In_Instance; 5406 Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; 5407 Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; 5408 -- Save the Ghost and SPARK mode-related data to restore on exit 5409 5410 Vis_Prims_List : Elist_Id := No_Elist; 5411 -- List of primitives made temporarily visible in the instantiation 5412 -- to match the visibility of the formal type 5413 5414 -- Start of processing for Analyze_Subprogram_Instantiation 5415 5416 begin 5417 -- Preserve relevant elaboration-related attributes of the context which 5418 -- are no longer available or very expensive to recompute once analysis, 5419 -- resolution, and expansion are over. 5420 5421 Mark_Elaboration_Attributes 5422 (N_Id => N, 5423 Checks => True, 5424 Level => True, 5425 Modes => True, 5426 Warnings => True); 5427 5428 Check_SPARK_05_Restriction ("generic is not allowed", N); 5429 5430 -- Very first thing: check for special Text_IO unit in case we are 5431 -- instantiating one of the children of [[Wide_]Wide_]Text_IO. Of course 5432 -- such an instantiation is bogus (these are packages, not subprograms), 5433 -- but we get a better error message if we do this. 5434 5435 Check_Text_IO_Special_Unit (Gen_Id); 5436 5437 -- Make node global for error reporting 5438 5439 Instantiation_Node := N; 5440 5441 -- For package instantiations we turn off style checks, because they 5442 -- will have been emitted in the generic. For subprogram instantiations 5443 -- we want to apply at least the check on overriding indicators so we 5444 -- do not modify the style check status. 5445 5446 -- The renaming declarations for the actuals do not come from source and 5447 -- will not generate spurious warnings. 5448 5449 Preanalyze_Actuals (N); 5450 5451 Init_Env; 5452 Env_Installed := True; 5453 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 5454 Gen_Unit := Entity (Gen_Id); 5455 5456 -- A subprogram instantiation is Ghost when it is subject to pragma 5457 -- Ghost or the generic template is Ghost. Set the mode now to ensure 5458 -- that any nodes generated during analysis and expansion are marked as 5459 -- Ghost. 5460 5461 Mark_And_Set_Ghost_Instantiation (N, Gen_Unit); 5462 5463 Generate_Reference (Gen_Unit, Gen_Id); 5464 5465 if Nkind (Gen_Id) = N_Identifier 5466 and then Chars (Gen_Unit) = Chars (Defining_Entity (N)) 5467 then 5468 Error_Msg_NE 5469 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 5470 end if; 5471 5472 if Etype (Gen_Unit) = Any_Type then 5473 Restore_Env; 5474 goto Leave; 5475 end if; 5476 5477 -- Verify that it is a generic subprogram of the right kind, and that 5478 -- it does not lead to a circular instantiation. 5479 5480 if K = E_Procedure and then Ekind (Gen_Unit) /= E_Generic_Procedure then 5481 Error_Msg_NE 5482 ("& is not the name of a generic procedure", Gen_Id, Gen_Unit); 5483 5484 elsif K = E_Function and then Ekind (Gen_Unit) /= E_Generic_Function then 5485 Error_Msg_NE 5486 ("& is not the name of a generic function", Gen_Id, Gen_Unit); 5487 5488 elsif In_Open_Scopes (Gen_Unit) then 5489 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); 5490 5491 else 5492 Set_Entity (Gen_Id, Gen_Unit); 5493 Set_Is_Instantiated (Gen_Unit); 5494 5495 if In_Extended_Main_Source_Unit (N) then 5496 Generate_Reference (Gen_Unit, N); 5497 end if; 5498 5499 -- If renaming, get original unit 5500 5501 if Present (Renamed_Object (Gen_Unit)) 5502 and then Ekind_In (Renamed_Object (Gen_Unit), E_Generic_Procedure, 5503 E_Generic_Function) 5504 then 5505 Gen_Unit := Renamed_Object (Gen_Unit); 5506 Set_Is_Instantiated (Gen_Unit); 5507 Generate_Reference (Gen_Unit, N); 5508 end if; 5509 5510 if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then 5511 Error_Msg_Node_2 := Current_Scope; 5512 Error_Msg_NE 5513 ("circular Instantiation: & instantiated in &!", N, Gen_Unit); 5514 Circularity_Detected := True; 5515 Restore_Hidden_Primitives (Vis_Prims_List); 5516 goto Leave; 5517 end if; 5518 5519 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 5520 5521 -- Initialize renamings map, for error checking 5522 5523 Generic_Renamings.Set_Last (0); 5524 Generic_Renamings_HTable.Reset; 5525 5526 Create_Instantiation_Source (N, Gen_Unit, S_Adjustment); 5527 5528 -- Copy original generic tree, to produce text for instantiation 5529 5530 Act_Tree := 5531 Copy_Generic_Node 5532 (Original_Node (Gen_Decl), Empty, Instantiating => True); 5533 5534 -- Inherit overriding indicator from instance node 5535 5536 Act_Spec := Specification (Act_Tree); 5537 Set_Must_Override (Act_Spec, Must_Override (N)); 5538 Set_Must_Not_Override (Act_Spec, Must_Not_Override (N)); 5539 5540 Renaming_List := 5541 Analyze_Associations 5542 (I_Node => N, 5543 Formals => Generic_Formal_Declarations (Act_Tree), 5544 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 5545 5546 Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); 5547 5548 -- The subprogram itself cannot contain a nested instance, so the 5549 -- current parent is left empty. 5550 5551 Set_Instance_Env (Gen_Unit, Empty); 5552 5553 -- Build the subprogram declaration, which does not appear in the 5554 -- generic template, and give it a sloc consistent with that of the 5555 -- template. 5556 5557 Set_Defining_Unit_Name (Act_Spec, Anon_Id); 5558 Set_Generic_Parent (Act_Spec, Gen_Unit); 5559 Act_Decl := 5560 Make_Subprogram_Declaration (Sloc (Act_Spec), 5561 Specification => Act_Spec); 5562 5563 -- The aspects have been copied previously, but they have to be 5564 -- linked explicitly to the new subprogram declaration. Explicit 5565 -- pre/postconditions on the instance are analyzed below, in a 5566 -- separate step. 5567 5568 Move_Aspects (Act_Tree, To => Act_Decl); 5569 Set_Categorization_From_Pragmas (Act_Decl); 5570 5571 if Parent_Installed then 5572 Hide_Current_Scope; 5573 end if; 5574 5575 Append (Act_Decl, Renaming_List); 5576 5577 -- Contract-related source pragmas that follow a generic subprogram 5578 -- must be instantiated explicitly because they are not part of the 5579 -- subprogram template. 5580 5581 Instantiate_Subprogram_Contract 5582 (Original_Node (Gen_Decl), Renaming_List); 5583 5584 Build_Subprogram_Renaming; 5585 5586 -- If the context of the instance is subject to SPARK_Mode "off" or 5587 -- the annotation is altogether missing, set the global flag which 5588 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within 5589 -- the instance. This should be done prior to analyzing the instance. 5590 5591 if SPARK_Mode /= On then 5592 Ignore_SPARK_Mode_Pragmas_In_Instance := True; 5593 end if; 5594 5595 -- If the context of an instance is not subject to SPARK_Mode "off", 5596 -- and the generic spec is subject to an explicit SPARK_Mode pragma, 5597 -- the latter should be the one applicable to the instance. 5598 5599 if not Ignore_SPARK_Mode_Pragmas_In_Instance 5600 and then Saved_SM /= Off 5601 and then Present (SPARK_Pragma (Gen_Unit)) 5602 then 5603 Set_SPARK_Mode (Gen_Unit); 5604 end if; 5605 5606 Analyze_Instance_And_Renamings; 5607 5608 -- Restore SPARK_Mode from the context after analysis of the package 5609 -- declaration, so that the SPARK_Mode on the generic spec does not 5610 -- apply to the pending instance for the instance body. 5611 5612 if not Ignore_SPARK_Mode_Pragmas_In_Instance 5613 and then Saved_SM /= Off 5614 and then Present (SPARK_Pragma (Gen_Unit)) 5615 then 5616 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 5617 end if; 5618 5619 -- If the generic is marked Import (Intrinsic), then so is the 5620 -- instance. This indicates that there is no body to instantiate. If 5621 -- generic is marked inline, so it the instance, and the anonymous 5622 -- subprogram it renames. If inlined, or else if inlining is enabled 5623 -- for the compilation, we generate the instance body even if it is 5624 -- not within the main unit. 5625 5626 if Is_Intrinsic_Subprogram (Gen_Unit) then 5627 Set_Is_Intrinsic_Subprogram (Anon_Id); 5628 Set_Is_Intrinsic_Subprogram (Act_Decl_Id); 5629 5630 if Chars (Gen_Unit) = Name_Unchecked_Conversion then 5631 Validate_Unchecked_Conversion (N, Act_Decl_Id); 5632 end if; 5633 end if; 5634 5635 -- Inherit convention from generic unit. Intrinsic convention, as for 5636 -- an instance of unchecked conversion, is not inherited because an 5637 -- explicit Ada instance has been created. 5638 5639 if Has_Convention_Pragma (Gen_Unit) 5640 and then Convention (Gen_Unit) /= Convention_Intrinsic 5641 then 5642 Set_Convention (Act_Decl_Id, Convention (Gen_Unit)); 5643 Set_Is_Exported (Act_Decl_Id, Is_Exported (Gen_Unit)); 5644 end if; 5645 5646 Generate_Definition (Act_Decl_Id); 5647 5648 -- Inherit all inlining-related flags which apply to the generic in 5649 -- the subprogram and its declaration. 5650 5651 Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit)); 5652 Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit)); 5653 5654 Set_Has_Pragma_Inline (Act_Decl_Id, Has_Pragma_Inline (Gen_Unit)); 5655 Set_Has_Pragma_Inline (Anon_Id, Has_Pragma_Inline (Gen_Unit)); 5656 5657 -- Propagate No_Return if pragma applied to generic unit. This must 5658 -- be done explicitly because pragma does not appear in generic 5659 -- declaration (unlike the aspect case). 5660 5661 if No_Return (Gen_Unit) then 5662 Set_No_Return (Act_Decl_Id); 5663 Set_No_Return (Anon_Id); 5664 end if; 5665 5666 Set_Has_Pragma_Inline_Always 5667 (Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit)); 5668 Set_Has_Pragma_Inline_Always 5669 (Anon_Id, Has_Pragma_Inline_Always (Gen_Unit)); 5670 5671 -- Mark both the instance spec and the anonymous package in case the 5672 -- body is instantiated at a later pass. This preserves the original 5673 -- context in effect for the body. 5674 5675 if SPARK_Mode /= On then 5676 Set_Ignore_SPARK_Mode_Pragmas (Act_Decl_Id); 5677 Set_Ignore_SPARK_Mode_Pragmas (Anon_Id); 5678 end if; 5679 5680 if Legacy_Elaboration_Checks 5681 and then not Is_Intrinsic_Subprogram (Gen_Unit) 5682 then 5683 Check_Elab_Instantiation (N); 5684 end if; 5685 5686 -- Save the scenario for later examination by the ABE Processing 5687 -- phase. 5688 5689 Record_Elaboration_Scenario (N); 5690 5691 -- The instantiation results in a guaranteed ABE. Create a completing 5692 -- body for the subprogram declaration because the real body will not 5693 -- be instantiated. 5694 5695 if Is_Known_Guaranteed_ABE (N) then 5696 Provide_Completing_Bodies (Instance_Spec (N)); 5697 end if; 5698 5699 if Is_Dispatching_Operation (Act_Decl_Id) 5700 and then Ada_Version >= Ada_2005 5701 then 5702 declare 5703 Formal : Entity_Id; 5704 5705 begin 5706 Formal := First_Formal (Act_Decl_Id); 5707 while Present (Formal) loop 5708 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type 5709 and then Is_Controlling_Formal (Formal) 5710 and then not Can_Never_Be_Null (Formal) 5711 then 5712 Error_Msg_NE 5713 ("access parameter& is controlling,", N, Formal); 5714 Error_Msg_NE 5715 ("\corresponding parameter of & must be explicitly " 5716 & "null-excluding", N, Gen_Id); 5717 end if; 5718 5719 Next_Formal (Formal); 5720 end loop; 5721 end; 5722 end if; 5723 5724 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); 5725 5726 Validate_Categorization_Dependency (N, Act_Decl_Id); 5727 5728 if not Is_Intrinsic_Subprogram (Act_Decl_Id) then 5729 Inherit_Context (Gen_Decl, N); 5730 5731 Restore_Private_Views (Pack_Id, False); 5732 5733 -- If the context requires a full instantiation, mark node for 5734 -- subsequent construction of the body. 5735 5736 if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then 5737 Check_Forward_Instantiation (Gen_Decl); 5738 5739 -- The wrapper package is always delayed, because it does not 5740 -- constitute a freeze point, but to insure that the freeze node 5741 -- is placed properly, it is created directly when instantiating 5742 -- the body (otherwise the freeze node might appear to early for 5743 -- nested instantiations). For ASIS purposes, indicate that the 5744 -- wrapper package has replaced the instantiation node. 5745 5746 elsif Nkind (Parent (N)) = N_Compilation_Unit then 5747 Rewrite (N, Unit (Parent (N))); 5748 Set_Unit (Parent (N), N); 5749 end if; 5750 5751 -- Replace instance node for library-level instantiations of 5752 -- intrinsic subprograms, for ASIS use. 5753 5754 elsif Nkind (Parent (N)) = N_Compilation_Unit then 5755 Rewrite (N, Unit (Parent (N))); 5756 Set_Unit (Parent (N), N); 5757 end if; 5758 5759 if Parent_Installed then 5760 Remove_Parent; 5761 end if; 5762 5763 Restore_Hidden_Primitives (Vis_Prims_List); 5764 Restore_Env; 5765 Env_Installed := False; 5766 Generic_Renamings.Set_Last (0); 5767 Generic_Renamings_HTable.Reset; 5768 end if; 5769 5770 <<Leave>> 5771 -- Analyze aspects in declaration if no errors appear in the instance. 5772 5773 if Has_Aspects (N) and then Serious_Errors_Detected = Errs then 5774 Analyze_Aspect_Specifications (N, Act_Decl_Id); 5775 end if; 5776 5777 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 5778 Restore_Ghost_Region (Saved_GM, Saved_IGR); 5779 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 5780 5781 exception 5782 when Instantiation_Error => 5783 if Parent_Installed then 5784 Remove_Parent; 5785 end if; 5786 5787 if Env_Installed then 5788 Restore_Env; 5789 end if; 5790 5791 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 5792 Restore_Ghost_Region (Saved_GM, Saved_IGR); 5793 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 5794 end Analyze_Subprogram_Instantiation; 5795 5796 ------------------------- 5797 -- Get_Associated_Node -- 5798 ------------------------- 5799 5800 function Get_Associated_Node (N : Node_Id) return Node_Id is 5801 Assoc : Node_Id; 5802 5803 begin 5804 Assoc := Associated_Node (N); 5805 5806 if Nkind (Assoc) /= Nkind (N) then 5807 return Assoc; 5808 5809 elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then 5810 return Assoc; 5811 5812 else 5813 -- If the node is part of an inner generic, it may itself have been 5814 -- remapped into a further generic copy. Associated_Node is otherwise 5815 -- used for the entity of the node, and will be of a different node 5816 -- kind, or else N has been rewritten as a literal or function call. 5817 5818 while Present (Associated_Node (Assoc)) 5819 and then Nkind (Associated_Node (Assoc)) = Nkind (Assoc) 5820 loop 5821 Assoc := Associated_Node (Assoc); 5822 end loop; 5823 5824 -- Follow an additional link in case the final node was rewritten. 5825 -- This can only happen with nested generic units. 5826 5827 if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op) 5828 and then Present (Associated_Node (Assoc)) 5829 and then (Nkind_In (Associated_Node (Assoc), N_Function_Call, 5830 N_Explicit_Dereference, 5831 N_Integer_Literal, 5832 N_Real_Literal, 5833 N_String_Literal)) 5834 then 5835 Assoc := Associated_Node (Assoc); 5836 end if; 5837 5838 -- An additional special case: an unconstrained type in an object 5839 -- declaration may have been rewritten as a local subtype constrained 5840 -- by the expression in the declaration. We need to recover the 5841 -- original entity, which may be global. 5842 5843 if Present (Original_Node (Assoc)) 5844 and then Nkind (Parent (N)) = N_Object_Declaration 5845 then 5846 Assoc := Original_Node (Assoc); 5847 end if; 5848 5849 return Assoc; 5850 end if; 5851 end Get_Associated_Node; 5852 5853 ---------------------------- 5854 -- Build_Function_Wrapper -- 5855 ---------------------------- 5856 5857 function Build_Function_Wrapper 5858 (Formal_Subp : Entity_Id; 5859 Actual_Subp : Entity_Id) return Node_Id 5860 is 5861 Loc : constant Source_Ptr := Sloc (Current_Scope); 5862 Ret_Type : constant Entity_Id := Get_Instance_Of (Etype (Formal_Subp)); 5863 Actuals : List_Id; 5864 Decl : Node_Id; 5865 Func_Name : Node_Id; 5866 Func : Entity_Id; 5867 Parm_Type : Node_Id; 5868 Profile : List_Id := New_List; 5869 Spec : Node_Id; 5870 Act_F : Entity_Id; 5871 Form_F : Entity_Id; 5872 New_F : Entity_Id; 5873 5874 begin 5875 Func_Name := New_Occurrence_Of (Actual_Subp, Loc); 5876 5877 Func := Make_Defining_Identifier (Loc, Chars (Formal_Subp)); 5878 Set_Ekind (Func, E_Function); 5879 Set_Is_Generic_Actual_Subprogram (Func); 5880 5881 Actuals := New_List; 5882 Profile := New_List; 5883 5884 Act_F := First_Formal (Actual_Subp); 5885 Form_F := First_Formal (Formal_Subp); 5886 while Present (Form_F) loop 5887 5888 -- Create new formal for profile of wrapper, and add a reference 5889 -- to it in the list of actuals for the enclosing call. The name 5890 -- must be that of the formal in the formal subprogram, because 5891 -- calls to it in the generic body may use named associations. 5892 5893 New_F := Make_Defining_Identifier (Loc, Chars (Form_F)); 5894 5895 Parm_Type := 5896 New_Occurrence_Of (Get_Instance_Of (Etype (Form_F)), Loc); 5897 5898 Append_To (Profile, 5899 Make_Parameter_Specification (Loc, 5900 Defining_Identifier => New_F, 5901 Parameter_Type => Parm_Type)); 5902 5903 Append_To (Actuals, New_Occurrence_Of (New_F, Loc)); 5904 Next_Formal (Form_F); 5905 5906 if Present (Act_F) then 5907 Next_Formal (Act_F); 5908 end if; 5909 end loop; 5910 5911 Spec := 5912 Make_Function_Specification (Loc, 5913 Defining_Unit_Name => Func, 5914 Parameter_Specifications => Profile, 5915 Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); 5916 5917 Decl := 5918 Make_Expression_Function (Loc, 5919 Specification => Spec, 5920 Expression => 5921 Make_Function_Call (Loc, 5922 Name => Func_Name, 5923 Parameter_Associations => Actuals)); 5924 5925 return Decl; 5926 end Build_Function_Wrapper; 5927 5928 ---------------------------- 5929 -- Build_Operator_Wrapper -- 5930 ---------------------------- 5931 5932 function Build_Operator_Wrapper 5933 (Formal_Subp : Entity_Id; 5934 Actual_Subp : Entity_Id) return Node_Id 5935 is 5936 Loc : constant Source_Ptr := Sloc (Current_Scope); 5937 Ret_Type : constant Entity_Id := 5938 Get_Instance_Of (Etype (Formal_Subp)); 5939 Op_Type : constant Entity_Id := 5940 Get_Instance_Of (Etype (First_Formal (Formal_Subp))); 5941 Is_Binary : constant Boolean := 5942 Present (Next_Formal (First_Formal (Formal_Subp))); 5943 5944 Decl : Node_Id; 5945 Expr : Node_Id := Empty; 5946 F1, F2 : Entity_Id; 5947 Func : Entity_Id; 5948 Op_Name : Name_Id; 5949 Spec : Node_Id; 5950 L, R : Node_Id; 5951 5952 begin 5953 Op_Name := Chars (Actual_Subp); 5954 5955 -- Create entities for wrapper function and its formals 5956 5957 F1 := Make_Temporary (Loc, 'A'); 5958 F2 := Make_Temporary (Loc, 'B'); 5959 L := New_Occurrence_Of (F1, Loc); 5960 R := New_Occurrence_Of (F2, Loc); 5961 5962 Func := Make_Defining_Identifier (Loc, Chars (Formal_Subp)); 5963 Set_Ekind (Func, E_Function); 5964 Set_Is_Generic_Actual_Subprogram (Func); 5965 5966 Spec := 5967 Make_Function_Specification (Loc, 5968 Defining_Unit_Name => Func, 5969 Parameter_Specifications => New_List ( 5970 Make_Parameter_Specification (Loc, 5971 Defining_Identifier => F1, 5972 Parameter_Type => New_Occurrence_Of (Op_Type, Loc))), 5973 Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); 5974 5975 if Is_Binary then 5976 Append_To (Parameter_Specifications (Spec), 5977 Make_Parameter_Specification (Loc, 5978 Defining_Identifier => F2, 5979 Parameter_Type => New_Occurrence_Of (Op_Type, Loc))); 5980 end if; 5981 5982 -- Build expression as a function call, or as an operator node 5983 -- that corresponds to the name of the actual, starting with 5984 -- binary operators. 5985 5986 if Op_Name not in Any_Operator_Name then 5987 Expr := 5988 Make_Function_Call (Loc, 5989 Name => 5990 New_Occurrence_Of (Actual_Subp, Loc), 5991 Parameter_Associations => New_List (L)); 5992 5993 if Is_Binary then 5994 Append_To (Parameter_Associations (Expr), R); 5995 end if; 5996 5997 -- Binary operators 5998 5999 elsif Is_Binary then 6000 if Op_Name = Name_Op_And then 6001 Expr := Make_Op_And (Loc, Left_Opnd => L, Right_Opnd => R); 6002 elsif Op_Name = Name_Op_Or then 6003 Expr := Make_Op_Or (Loc, Left_Opnd => L, Right_Opnd => R); 6004 elsif Op_Name = Name_Op_Xor then 6005 Expr := Make_Op_Xor (Loc, Left_Opnd => L, Right_Opnd => R); 6006 elsif Op_Name = Name_Op_Eq then 6007 Expr := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R); 6008 elsif Op_Name = Name_Op_Ne then 6009 Expr := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R); 6010 elsif Op_Name = Name_Op_Le then 6011 Expr := Make_Op_Le (Loc, Left_Opnd => L, Right_Opnd => R); 6012 elsif Op_Name = Name_Op_Gt then 6013 Expr := Make_Op_Gt (Loc, Left_Opnd => L, Right_Opnd => R); 6014 elsif Op_Name = Name_Op_Ge then 6015 Expr := Make_Op_Ge (Loc, Left_Opnd => L, Right_Opnd => R); 6016 elsif Op_Name = Name_Op_Lt then 6017 Expr := Make_Op_Lt (Loc, Left_Opnd => L, Right_Opnd => R); 6018 elsif Op_Name = Name_Op_Add then 6019 Expr := Make_Op_Add (Loc, Left_Opnd => L, Right_Opnd => R); 6020 elsif Op_Name = Name_Op_Subtract then 6021 Expr := Make_Op_Subtract (Loc, Left_Opnd => L, Right_Opnd => R); 6022 elsif Op_Name = Name_Op_Concat then 6023 Expr := Make_Op_Concat (Loc, Left_Opnd => L, Right_Opnd => R); 6024 elsif Op_Name = Name_Op_Multiply then 6025 Expr := Make_Op_Multiply (Loc, Left_Opnd => L, Right_Opnd => R); 6026 elsif Op_Name = Name_Op_Divide then 6027 Expr := Make_Op_Divide (Loc, Left_Opnd => L, Right_Opnd => R); 6028 elsif Op_Name = Name_Op_Mod then 6029 Expr := Make_Op_Mod (Loc, Left_Opnd => L, Right_Opnd => R); 6030 elsif Op_Name = Name_Op_Rem then 6031 Expr := Make_Op_Rem (Loc, Left_Opnd => L, Right_Opnd => R); 6032 elsif Op_Name = Name_Op_Expon then 6033 Expr := Make_Op_Expon (Loc, Left_Opnd => L, Right_Opnd => R); 6034 end if; 6035 6036 -- Unary operators 6037 6038 else 6039 if Op_Name = Name_Op_Add then 6040 Expr := Make_Op_Plus (Loc, Right_Opnd => L); 6041 elsif Op_Name = Name_Op_Subtract then 6042 Expr := Make_Op_Minus (Loc, Right_Opnd => L); 6043 elsif Op_Name = Name_Op_Abs then 6044 Expr := Make_Op_Abs (Loc, Right_Opnd => L); 6045 elsif Op_Name = Name_Op_Not then 6046 Expr := Make_Op_Not (Loc, Right_Opnd => L); 6047 end if; 6048 end if; 6049 6050 Decl := 6051 Make_Expression_Function (Loc, 6052 Specification => Spec, 6053 Expression => Expr); 6054 6055 return Decl; 6056 end Build_Operator_Wrapper; 6057 6058 ------------------------------------------- 6059 -- Build_Instance_Compilation_Unit_Nodes -- 6060 ------------------------------------------- 6061 6062 procedure Build_Instance_Compilation_Unit_Nodes 6063 (N : Node_Id; 6064 Act_Body : Node_Id; 6065 Act_Decl : Node_Id) 6066 is 6067 Decl_Cunit : Node_Id; 6068 Body_Cunit : Node_Id; 6069 Citem : Node_Id; 6070 New_Main : constant Entity_Id := Defining_Entity (Act_Decl); 6071 Old_Main : constant Entity_Id := Cunit_Entity (Main_Unit); 6072 6073 begin 6074 -- A new compilation unit node is built for the instance declaration 6075 6076 Decl_Cunit := 6077 Make_Compilation_Unit (Sloc (N), 6078 Context_Items => Empty_List, 6079 Unit => Act_Decl, 6080 Aux_Decls_Node => Make_Compilation_Unit_Aux (Sloc (N))); 6081 6082 Set_Parent_Spec (Act_Decl, Parent_Spec (N)); 6083 6084 -- The new compilation unit is linked to its body, but both share the 6085 -- same file, so we do not set Body_Required on the new unit so as not 6086 -- to create a spurious dependency on a non-existent body in the ali. 6087 -- This simplifies CodePeer unit traversal. 6088 6089 -- We use the original instantiation compilation unit as the resulting 6090 -- compilation unit of the instance, since this is the main unit. 6091 6092 Rewrite (N, Act_Body); 6093 6094 -- Propagate the aspect specifications from the package body template to 6095 -- the instantiated version of the package body. 6096 6097 if Has_Aspects (Act_Body) then 6098 Set_Aspect_Specifications 6099 (N, New_Copy_List_Tree (Aspect_Specifications (Act_Body))); 6100 end if; 6101 6102 Body_Cunit := Parent (N); 6103 6104 -- The two compilation unit nodes are linked by the Library_Unit field 6105 6106 Set_Library_Unit (Decl_Cunit, Body_Cunit); 6107 Set_Library_Unit (Body_Cunit, Decl_Cunit); 6108 6109 -- Preserve the private nature of the package if needed 6110 6111 Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit)); 6112 6113 -- If the instance is not the main unit, its context, categorization 6114 -- and elaboration entity are not relevant to the compilation. 6115 6116 if Body_Cunit /= Cunit (Main_Unit) then 6117 Make_Instance_Unit (Body_Cunit, In_Main => False); 6118 return; 6119 end if; 6120 6121 -- The context clause items on the instantiation, which are now attached 6122 -- to the body compilation unit (since the body overwrote the original 6123 -- instantiation node), semantically belong on the spec, so copy them 6124 -- there. It's harmless to leave them on the body as well. In fact one 6125 -- could argue that they belong in both places. 6126 6127 Citem := First (Context_Items (Body_Cunit)); 6128 while Present (Citem) loop 6129 Append (New_Copy (Citem), Context_Items (Decl_Cunit)); 6130 Next (Citem); 6131 end loop; 6132 6133 -- Propagate categorization flags on packages, so that they appear in 6134 -- the ali file for the spec of the unit. 6135 6136 if Ekind (New_Main) = E_Package then 6137 Set_Is_Pure (Old_Main, Is_Pure (New_Main)); 6138 Set_Is_Preelaborated (Old_Main, Is_Preelaborated (New_Main)); 6139 Set_Is_Remote_Types (Old_Main, Is_Remote_Types (New_Main)); 6140 Set_Is_Shared_Passive (Old_Main, Is_Shared_Passive (New_Main)); 6141 Set_Is_Remote_Call_Interface 6142 (Old_Main, Is_Remote_Call_Interface (New_Main)); 6143 end if; 6144 6145 -- Make entry in Units table, so that binder can generate call to 6146 -- elaboration procedure for body, if any. 6147 6148 Make_Instance_Unit (Body_Cunit, In_Main => True); 6149 Main_Unit_Entity := New_Main; 6150 Set_Cunit_Entity (Main_Unit, Main_Unit_Entity); 6151 6152 -- Build elaboration entity, since the instance may certainly generate 6153 -- elaboration code requiring a flag for protection. 6154 6155 Build_Elaboration_Entity (Decl_Cunit, New_Main); 6156 end Build_Instance_Compilation_Unit_Nodes; 6157 6158 ----------------------------- 6159 -- Check_Access_Definition -- 6160 ----------------------------- 6161 6162 procedure Check_Access_Definition (N : Node_Id) is 6163 begin 6164 pragma Assert 6165 (Ada_Version >= Ada_2005 and then Present (Access_Definition (N))); 6166 null; 6167 end Check_Access_Definition; 6168 6169 ----------------------------------- 6170 -- Check_Formal_Package_Instance -- 6171 ----------------------------------- 6172 6173 -- If the formal has specific parameters, they must match those of the 6174 -- actual. Both of them are instances, and the renaming declarations for 6175 -- their formal parameters appear in the same order in both. The analyzed 6176 -- formal has been analyzed in the context of the current instance. 6177 6178 procedure Check_Formal_Package_Instance 6179 (Formal_Pack : Entity_Id; 6180 Actual_Pack : Entity_Id) 6181 is 6182 E1 : Entity_Id := First_Entity (Actual_Pack); 6183 E2 : Entity_Id := First_Entity (Formal_Pack); 6184 Prev_E1 : Entity_Id; 6185 6186 Expr1 : Node_Id; 6187 Expr2 : Node_Id; 6188 6189 procedure Check_Mismatch (B : Boolean); 6190 -- Common error routine for mismatch between the parameters of the 6191 -- actual instance and those of the formal package. 6192 6193 function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean; 6194 -- The formal may come from a nested formal package, and the actual may 6195 -- have been constant-folded. To determine whether the two denote the 6196 -- same entity we may have to traverse several definitions to recover 6197 -- the ultimate entity that they refer to. 6198 6199 function Same_Instantiated_Function (E1, E2 : Entity_Id) return Boolean; 6200 -- The formal and the actual must be identical, but if both are 6201 -- given by attributes they end up renaming different generated bodies, 6202 -- and we must verify that the attributes themselves match. 6203 6204 function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean; 6205 -- Similarly, if the formal comes from a nested formal package, the 6206 -- actual may designate the formal through multiple renamings, which 6207 -- have to be followed to determine the original variable in question. 6208 6209 -------------------- 6210 -- Check_Mismatch -- 6211 -------------------- 6212 6213 procedure Check_Mismatch (B : Boolean) is 6214 -- A Formal_Type_Declaration for a derived private type is rewritten 6215 -- as a private extension decl. (see Analyze_Formal_Derived_Type), 6216 -- which is why we examine the original node. 6217 6218 Kind : constant Node_Kind := Nkind (Original_Node (Parent (E2))); 6219 6220 begin 6221 if Kind = N_Formal_Type_Declaration then 6222 return; 6223 6224 elsif Nkind_In (Kind, N_Formal_Object_Declaration, 6225 N_Formal_Package_Declaration) 6226 or else Kind in N_Formal_Subprogram_Declaration 6227 then 6228 null; 6229 6230 -- Ada 2012: If both formal and actual are incomplete types they 6231 -- are conformant. 6232 6233 elsif Is_Incomplete_Type (E1) and then Is_Incomplete_Type (E2) then 6234 null; 6235 6236 elsif B then 6237 Error_Msg_NE 6238 ("actual for & in actual instance does not match formal", 6239 Parent (Actual_Pack), E1); 6240 end if; 6241 end Check_Mismatch; 6242 6243 -------------------------------- 6244 -- Same_Instantiated_Constant -- 6245 -------------------------------- 6246 6247 function Same_Instantiated_Constant 6248 (E1, E2 : Entity_Id) return Boolean 6249 is 6250 Ent : Entity_Id; 6251 6252 begin 6253 Ent := E2; 6254 while Present (Ent) loop 6255 if E1 = Ent then 6256 return True; 6257 6258 elsif Ekind (Ent) /= E_Constant then 6259 return False; 6260 6261 elsif Is_Entity_Name (Constant_Value (Ent)) then 6262 if Entity (Constant_Value (Ent)) = E1 then 6263 return True; 6264 else 6265 Ent := Entity (Constant_Value (Ent)); 6266 end if; 6267 6268 -- The actual may be a constant that has been folded. Recover 6269 -- original name. 6270 6271 elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then 6272 Ent := Entity (Original_Node (Constant_Value (Ent))); 6273 6274 else 6275 return False; 6276 end if; 6277 end loop; 6278 6279 return False; 6280 end Same_Instantiated_Constant; 6281 6282 -------------------------------- 6283 -- Same_Instantiated_Function -- 6284 -------------------------------- 6285 6286 function Same_Instantiated_Function 6287 (E1, E2 : Entity_Id) return Boolean 6288 is 6289 U1, U2 : Node_Id; 6290 begin 6291 if Alias (E1) = Alias (E2) then 6292 return True; 6293 6294 elsif Present (Alias (E2)) then 6295 U1 := Original_Node (Unit_Declaration_Node (E1)); 6296 U2 := Original_Node (Unit_Declaration_Node (Alias (E2))); 6297 6298 return Nkind (U1) = N_Subprogram_Renaming_Declaration 6299 and then Nkind (Name (U1)) = N_Attribute_Reference 6300 6301 and then Nkind (U2) = N_Subprogram_Renaming_Declaration 6302 and then Nkind (Name (U2)) = N_Attribute_Reference 6303 6304 and then 6305 Attribute_Name (Name (U1)) = Attribute_Name (Name (U2)); 6306 else 6307 return False; 6308 end if; 6309 end Same_Instantiated_Function; 6310 6311 -------------------------------- 6312 -- Same_Instantiated_Variable -- 6313 -------------------------------- 6314 6315 function Same_Instantiated_Variable 6316 (E1, E2 : Entity_Id) return Boolean 6317 is 6318 function Original_Entity (E : Entity_Id) return Entity_Id; 6319 -- Follow chain of renamings to the ultimate ancestor 6320 6321 --------------------- 6322 -- Original_Entity -- 6323 --------------------- 6324 6325 function Original_Entity (E : Entity_Id) return Entity_Id is 6326 Orig : Entity_Id; 6327 6328 begin 6329 Orig := E; 6330 while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration 6331 and then Present (Renamed_Object (Orig)) 6332 and then Is_Entity_Name (Renamed_Object (Orig)) 6333 loop 6334 Orig := Entity (Renamed_Object (Orig)); 6335 end loop; 6336 6337 return Orig; 6338 end Original_Entity; 6339 6340 -- Start of processing for Same_Instantiated_Variable 6341 6342 begin 6343 return Ekind (E1) = Ekind (E2) 6344 and then Original_Entity (E1) = Original_Entity (E2); 6345 end Same_Instantiated_Variable; 6346 6347 -- Start of processing for Check_Formal_Package_Instance 6348 6349 begin 6350 Prev_E1 := E1; 6351 while Present (E1) and then Present (E2) loop 6352 exit when Ekind (E1) = E_Package 6353 and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack); 6354 6355 -- If the formal is the renaming of the formal package, this 6356 -- is the end of its formal part, which may occur before the 6357 -- end of the formal part in the actual in the presence of 6358 -- defaulted parameters in the formal package. 6359 6360 exit when Nkind (Parent (E2)) = N_Package_Renaming_Declaration 6361 and then Renamed_Entity (E2) = Scope (E2); 6362 6363 -- The analysis of the actual may generate additional internal 6364 -- entities. If the formal is defaulted, there is no corresponding 6365 -- analysis and the internal entities must be skipped, until we 6366 -- find corresponding entities again. 6367 6368 if Comes_From_Source (E2) 6369 and then not Comes_From_Source (E1) 6370 and then Chars (E1) /= Chars (E2) 6371 then 6372 while Present (E1) and then Chars (E1) /= Chars (E2) loop 6373 Next_Entity (E1); 6374 end loop; 6375 end if; 6376 6377 if No (E1) then 6378 return; 6379 6380 -- Entities may be declared without full declaration, such as 6381 -- itypes and predefined operators (concatenation for arrays, eg). 6382 -- Skip it and keep the formal entity to find a later match for it. 6383 6384 elsif No (Parent (E2)) and then Ekind (E1) /= Ekind (E2) then 6385 E1 := Prev_E1; 6386 goto Next_E; 6387 6388 -- If the formal entity comes from a formal declaration, it was 6389 -- defaulted in the formal package, and no check is needed on it. 6390 6391 elsif Nkind_In (Original_Node (Parent (E2)), 6392 N_Formal_Object_Declaration, 6393 N_Formal_Type_Declaration) 6394 then 6395 -- If the formal is a tagged type the corresponding class-wide 6396 -- type has been generated as well, and it must be skipped. 6397 6398 if Is_Type (E2) and then Is_Tagged_Type (E2) then 6399 Next_Entity (E2); 6400 end if; 6401 6402 goto Next_E; 6403 6404 -- Ditto for defaulted formal subprograms. 6405 6406 elsif Is_Overloadable (E1) 6407 and then Nkind (Unit_Declaration_Node (E2)) in 6408 N_Formal_Subprogram_Declaration 6409 then 6410 goto Next_E; 6411 6412 elsif Is_Type (E1) then 6413 6414 -- Subtypes must statically match. E1, E2 are the local entities 6415 -- that are subtypes of the actuals. Itypes generated for other 6416 -- parameters need not be checked, the check will be performed 6417 -- on the parameters themselves. 6418 6419 -- If E2 is a formal type declaration, it is a defaulted parameter 6420 -- and needs no checking. 6421 6422 if not Is_Itype (E1) and then not Is_Itype (E2) then 6423 Check_Mismatch 6424 (not Is_Type (E2) 6425 or else Etype (E1) /= Etype (E2) 6426 or else not Subtypes_Statically_Match (E1, E2)); 6427 end if; 6428 6429 elsif Ekind (E1) = E_Constant then 6430 6431 -- IN parameters must denote the same static value, or the same 6432 -- constant, or the literal null. 6433 6434 Expr1 := Expression (Parent (E1)); 6435 6436 if Ekind (E2) /= E_Constant then 6437 Check_Mismatch (True); 6438 goto Next_E; 6439 else 6440 Expr2 := Expression (Parent (E2)); 6441 end if; 6442 6443 if Is_OK_Static_Expression (Expr1) then 6444 if not Is_OK_Static_Expression (Expr2) then 6445 Check_Mismatch (True); 6446 6447 elsif Is_Discrete_Type (Etype (E1)) then 6448 declare 6449 V1 : constant Uint := Expr_Value (Expr1); 6450 V2 : constant Uint := Expr_Value (Expr2); 6451 begin 6452 Check_Mismatch (V1 /= V2); 6453 end; 6454 6455 elsif Is_Real_Type (Etype (E1)) then 6456 declare 6457 V1 : constant Ureal := Expr_Value_R (Expr1); 6458 V2 : constant Ureal := Expr_Value_R (Expr2); 6459 begin 6460 Check_Mismatch (V1 /= V2); 6461 end; 6462 6463 elsif Is_String_Type (Etype (E1)) 6464 and then Nkind (Expr1) = N_String_Literal 6465 then 6466 if Nkind (Expr2) /= N_String_Literal then 6467 Check_Mismatch (True); 6468 else 6469 Check_Mismatch 6470 (not String_Equal (Strval (Expr1), Strval (Expr2))); 6471 end if; 6472 end if; 6473 6474 elsif Is_Entity_Name (Expr1) then 6475 if Is_Entity_Name (Expr2) then 6476 if Entity (Expr1) = Entity (Expr2) then 6477 null; 6478 else 6479 Check_Mismatch 6480 (not Same_Instantiated_Constant 6481 (Entity (Expr1), Entity (Expr2))); 6482 end if; 6483 6484 else 6485 Check_Mismatch (True); 6486 end if; 6487 6488 elsif Is_Entity_Name (Original_Node (Expr1)) 6489 and then Is_Entity_Name (Expr2) 6490 and then Same_Instantiated_Constant 6491 (Entity (Original_Node (Expr1)), Entity (Expr2)) 6492 then 6493 null; 6494 6495 elsif Nkind (Expr1) = N_Null then 6496 Check_Mismatch (Nkind (Expr1) /= N_Null); 6497 6498 else 6499 Check_Mismatch (True); 6500 end if; 6501 6502 elsif Ekind (E1) = E_Variable then 6503 Check_Mismatch (not Same_Instantiated_Variable (E1, E2)); 6504 6505 elsif Ekind (E1) = E_Package then 6506 Check_Mismatch 6507 (Ekind (E1) /= Ekind (E2) 6508 or else (Present (Renamed_Object (E2)) 6509 and then Renamed_Object (E1) /= 6510 Renamed_Object (E2))); 6511 6512 elsif Is_Overloadable (E1) then 6513 -- Verify that the actual subprograms match. Note that actuals 6514 -- that are attributes are rewritten as subprograms. If the 6515 -- subprogram in the formal package is defaulted, no check is 6516 -- needed. Note that this can only happen in Ada 2005 when the 6517 -- formal package can be partially parameterized. 6518 6519 if Nkind (Unit_Declaration_Node (E1)) = 6520 N_Subprogram_Renaming_Declaration 6521 and then From_Default (Unit_Declaration_Node (E1)) 6522 then 6523 null; 6524 6525 -- If the formal package has an "others" box association that 6526 -- covers this formal, there is no need for a check either. 6527 6528 elsif Nkind (Unit_Declaration_Node (E2)) in 6529 N_Formal_Subprogram_Declaration 6530 and then Box_Present (Unit_Declaration_Node (E2)) 6531 then 6532 null; 6533 6534 -- No check needed if subprogram is a defaulted null procedure 6535 6536 elsif No (Alias (E2)) 6537 and then Ekind (E2) = E_Procedure 6538 and then 6539 Null_Present (Specification (Unit_Declaration_Node (E2))) 6540 then 6541 null; 6542 6543 -- Otherwise the actual in the formal and the actual in the 6544 -- instantiation of the formal must match, up to renamings. 6545 6546 else 6547 Check_Mismatch 6548 (Ekind (E2) /= Ekind (E1) 6549 or else not Same_Instantiated_Function (E1, E2)); 6550 end if; 6551 6552 else 6553 raise Program_Error; 6554 end if; 6555 6556 <<Next_E>> 6557 Prev_E1 := E1; 6558 Next_Entity (E1); 6559 Next_Entity (E2); 6560 end loop; 6561 end Check_Formal_Package_Instance; 6562 6563 --------------------------- 6564 -- Check_Formal_Packages -- 6565 --------------------------- 6566 6567 procedure Check_Formal_Packages (P_Id : Entity_Id) is 6568 E : Entity_Id; 6569 Formal_P : Entity_Id; 6570 Formal_Decl : Node_Id; 6571 begin 6572 -- Iterate through the declarations in the instance, looking for package 6573 -- renaming declarations that denote instances of formal packages. Stop 6574 -- when we find the renaming of the current package itself. The 6575 -- declaration for a formal package without a box is followed by an 6576 -- internal entity that repeats the instantiation. 6577 6578 E := First_Entity (P_Id); 6579 while Present (E) loop 6580 if Ekind (E) = E_Package then 6581 if Renamed_Object (E) = P_Id then 6582 exit; 6583 6584 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 6585 null; 6586 6587 else 6588 Formal_Decl := Parent (Associated_Formal_Package (E)); 6589 6590 -- Nothing to check if the formal has a box or an others_clause 6591 -- (necessarily with a box). 6592 6593 if Box_Present (Formal_Decl) then 6594 null; 6595 6596 elsif Nkind (First (Generic_Associations (Formal_Decl))) = 6597 N_Others_Choice 6598 then 6599 -- The internal validating package was generated but formal 6600 -- and instance are known to be compatible. 6601 6602 Formal_P := Next_Entity (E); 6603 Remove (Unit_Declaration_Node (Formal_P)); 6604 6605 else 6606 Formal_P := Next_Entity (E); 6607 6608 -- If the instance is within an enclosing instance body 6609 -- there is no need to verify the legality of current formal 6610 -- packages because they were legal in the generic body. 6611 -- This optimization may be applicable elsewhere, and it 6612 -- also removes spurious errors that may arise with 6613 -- on-the-fly inlining and confusion between private and 6614 -- full views. 6615 6616 if not In_Instance_Body then 6617 Check_Formal_Package_Instance (Formal_P, E); 6618 end if; 6619 6620 -- Restore the visibility of formals of the formal instance 6621 -- that are not defaulted, and are hidden within the current 6622 -- generic. These formals may be visible within an enclosing 6623 -- generic. 6624 6625 declare 6626 Elmt : Elmt_Id; 6627 begin 6628 Elmt := First_Elmt (Hidden_In_Formal_Instance (Formal_P)); 6629 while Present (Elmt) loop 6630 Set_Is_Hidden (Node (Elmt), False); 6631 Next_Elmt (Elmt); 6632 end loop; 6633 end; 6634 6635 -- After checking, remove the internal validating package. 6636 -- It is only needed for semantic checks, and as it may 6637 -- contain generic formal declarations it should not reach 6638 -- gigi. 6639 6640 Remove (Unit_Declaration_Node (Formal_P)); 6641 end if; 6642 end if; 6643 end if; 6644 6645 Next_Entity (E); 6646 end loop; 6647 end Check_Formal_Packages; 6648 6649 --------------------------------- 6650 -- Check_Forward_Instantiation -- 6651 --------------------------------- 6652 6653 procedure Check_Forward_Instantiation (Decl : Node_Id) is 6654 S : Entity_Id; 6655 Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl)); 6656 6657 begin 6658 -- The instantiation appears before the generic body if we are in the 6659 -- scope of the unit containing the generic, either in its spec or in 6660 -- the package body, and before the generic body. 6661 6662 if Ekind (Gen_Comp) = E_Package_Body then 6663 Gen_Comp := Spec_Entity (Gen_Comp); 6664 end if; 6665 6666 if In_Open_Scopes (Gen_Comp) 6667 and then No (Corresponding_Body (Decl)) 6668 then 6669 S := Current_Scope; 6670 6671 while Present (S) 6672 and then not Is_Compilation_Unit (S) 6673 and then not Is_Child_Unit (S) 6674 loop 6675 if Ekind (S) = E_Package then 6676 Set_Has_Forward_Instantiation (S); 6677 end if; 6678 6679 S := Scope (S); 6680 end loop; 6681 end if; 6682 end Check_Forward_Instantiation; 6683 6684 --------------------------- 6685 -- Check_Generic_Actuals -- 6686 --------------------------- 6687 6688 -- The visibility of the actuals may be different between the point of 6689 -- generic instantiation and the instantiation of the body. 6690 6691 procedure Check_Generic_Actuals 6692 (Instance : Entity_Id; 6693 Is_Formal_Box : Boolean) 6694 is 6695 E : Entity_Id; 6696 Astype : Entity_Id; 6697 6698 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean; 6699 -- For a formal that is an array type, the component type is often a 6700 -- previous formal in the same unit. The privacy status of the component 6701 -- type will have been examined earlier in the traversal of the 6702 -- corresponding actuals, and this status should not be modified for 6703 -- the array (sub)type itself. However, if the base type of the array 6704 -- (sub)type is private, its full view must be restored in the body to 6705 -- be consistent with subsequent index subtypes, etc. 6706 -- 6707 -- To detect this case we have to rescan the list of formals, which is 6708 -- usually short enough to ignore the resulting inefficiency. 6709 6710 ----------------------------- 6711 -- Denotes_Previous_Actual -- 6712 ----------------------------- 6713 6714 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is 6715 Prev : Entity_Id; 6716 6717 begin 6718 Prev := First_Entity (Instance); 6719 while Present (Prev) loop 6720 if Is_Type (Prev) 6721 and then Nkind (Parent (Prev)) = N_Subtype_Declaration 6722 and then Is_Entity_Name (Subtype_Indication (Parent (Prev))) 6723 and then Entity (Subtype_Indication (Parent (Prev))) = Typ 6724 then 6725 return True; 6726 6727 elsif Prev = E then 6728 return False; 6729 6730 else 6731 Next_Entity (Prev); 6732 end if; 6733 end loop; 6734 6735 return False; 6736 end Denotes_Previous_Actual; 6737 6738 -- Start of processing for Check_Generic_Actuals 6739 6740 begin 6741 E := First_Entity (Instance); 6742 while Present (E) loop 6743 if Is_Type (E) 6744 and then Nkind (Parent (E)) = N_Subtype_Declaration 6745 and then Scope (Etype (E)) /= Instance 6746 and then Is_Entity_Name (Subtype_Indication (Parent (E))) 6747 then 6748 if Is_Array_Type (E) 6749 and then not Is_Private_Type (Etype (E)) 6750 and then Denotes_Previous_Actual (Component_Type (E)) 6751 then 6752 null; 6753 else 6754 Check_Private_View (Subtype_Indication (Parent (E))); 6755 end if; 6756 6757 Set_Is_Generic_Actual_Type (E, True); 6758 Set_Is_Hidden (E, False); 6759 Set_Is_Potentially_Use_Visible (E, In_Use (Instance)); 6760 6761 -- We constructed the generic actual type as a subtype of the 6762 -- supplied type. This means that it normally would not inherit 6763 -- subtype specific attributes of the actual, which is wrong for 6764 -- the generic case. 6765 6766 Astype := Ancestor_Subtype (E); 6767 6768 if No (Astype) then 6769 6770 -- This can happen when E is an itype that is the full view of 6771 -- a private type completed, e.g. with a constrained array. In 6772 -- that case, use the first subtype, which will carry size 6773 -- information. The base type itself is unconstrained and will 6774 -- not carry it. 6775 6776 Astype := First_Subtype (E); 6777 end if; 6778 6779 Set_Size_Info (E, (Astype)); 6780 Set_RM_Size (E, RM_Size (Astype)); 6781 Set_First_Rep_Item (E, First_Rep_Item (Astype)); 6782 6783 if Is_Discrete_Or_Fixed_Point_Type (E) then 6784 Set_RM_Size (E, RM_Size (Astype)); 6785 6786 -- In nested instances, the base type of an access actual may 6787 -- itself be private, and need to be exchanged. 6788 6789 elsif Is_Access_Type (E) 6790 and then Is_Private_Type (Etype (E)) 6791 then 6792 Check_Private_View 6793 (New_Occurrence_Of (Etype (E), Sloc (Instance))); 6794 end if; 6795 6796 elsif Ekind (E) = E_Package then 6797 6798 -- If this is the renaming for the current instance, we're done. 6799 -- Otherwise it is a formal package. If the corresponding formal 6800 -- was declared with a box, the (instantiations of the) generic 6801 -- formal part are also visible. Otherwise, ignore the entity 6802 -- created to validate the actuals. 6803 6804 if Renamed_Object (E) = Instance then 6805 exit; 6806 6807 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 6808 null; 6809 6810 -- The visibility of a formal of an enclosing generic is already 6811 -- correct. 6812 6813 elsif Denotes_Formal_Package (E) then 6814 null; 6815 6816 elsif Present (Associated_Formal_Package (E)) 6817 and then not Is_Generic_Formal (E) 6818 then 6819 if Box_Present (Parent (Associated_Formal_Package (E))) then 6820 Check_Generic_Actuals (Renamed_Object (E), True); 6821 6822 else 6823 Check_Generic_Actuals (Renamed_Object (E), False); 6824 end if; 6825 6826 Set_Is_Hidden (E, False); 6827 end if; 6828 6829 -- If this is a subprogram instance (in a wrapper package) the 6830 -- actual is fully visible. 6831 6832 elsif Is_Wrapper_Package (Instance) then 6833 Set_Is_Hidden (E, False); 6834 6835 -- If the formal package is declared with a box, or if the formal 6836 -- parameter is defaulted, it is visible in the body. 6837 6838 elsif Is_Formal_Box or else Is_Visible_Formal (E) then 6839 Set_Is_Hidden (E, False); 6840 end if; 6841 6842 if Ekind (E) = E_Constant then 6843 6844 -- If the type of the actual is a private type declared in the 6845 -- enclosing scope of the generic unit, the body of the generic 6846 -- sees the full view of the type (because it has to appear in 6847 -- the corresponding package body). If the type is private now, 6848 -- exchange views to restore the proper visiblity in the instance. 6849 6850 declare 6851 Typ : constant Entity_Id := Base_Type (Etype (E)); 6852 -- The type of the actual 6853 6854 Gen_Id : Entity_Id; 6855 -- The generic unit 6856 6857 Parent_Scope : Entity_Id; 6858 -- The enclosing scope of the generic unit 6859 6860 begin 6861 if Is_Wrapper_Package (Instance) then 6862 Gen_Id := 6863 Generic_Parent 6864 (Specification 6865 (Unit_Declaration_Node 6866 (Related_Instance (Instance)))); 6867 else 6868 Gen_Id := 6869 Generic_Parent (Package_Specification (Instance)); 6870 end if; 6871 6872 Parent_Scope := Scope (Gen_Id); 6873 6874 -- The exchange is only needed if the generic is defined 6875 -- within a package which is not a common ancestor of the 6876 -- scope of the instance, and is not already in scope. 6877 6878 if Is_Private_Type (Typ) 6879 and then Scope (Typ) = Parent_Scope 6880 and then Scope (Instance) /= Parent_Scope 6881 and then Ekind (Parent_Scope) = E_Package 6882 and then not Is_Child_Unit (Gen_Id) 6883 then 6884 Switch_View (Typ); 6885 6886 -- If the type of the entity is a subtype, it may also have 6887 -- to be made visible, together with the base type of its 6888 -- full view, after exchange. 6889 6890 if Is_Private_Type (Etype (E)) then 6891 Switch_View (Etype (E)); 6892 Switch_View (Base_Type (Etype (E))); 6893 end if; 6894 end if; 6895 end; 6896 end if; 6897 6898 Next_Entity (E); 6899 end loop; 6900 end Check_Generic_Actuals; 6901 6902 ------------------------------ 6903 -- Check_Generic_Child_Unit -- 6904 ------------------------------ 6905 6906 procedure Check_Generic_Child_Unit 6907 (Gen_Id : Node_Id; 6908 Parent_Installed : in out Boolean) 6909 is 6910 Loc : constant Source_Ptr := Sloc (Gen_Id); 6911 Gen_Par : Entity_Id := Empty; 6912 E : Entity_Id; 6913 Inst_Par : Entity_Id; 6914 S : Node_Id; 6915 6916 function Find_Generic_Child 6917 (Scop : Entity_Id; 6918 Id : Node_Id) return Entity_Id; 6919 -- Search generic parent for possible child unit with the given name 6920 6921 function In_Enclosing_Instance return Boolean; 6922 -- Within an instance of the parent, the child unit may be denoted by 6923 -- a simple name, or an abbreviated expanded name. Examine enclosing 6924 -- scopes to locate a possible parent instantiation. 6925 6926 ------------------------ 6927 -- Find_Generic_Child -- 6928 ------------------------ 6929 6930 function Find_Generic_Child 6931 (Scop : Entity_Id; 6932 Id : Node_Id) return Entity_Id 6933 is 6934 E : Entity_Id; 6935 6936 begin 6937 -- If entity of name is already set, instance has already been 6938 -- resolved, e.g. in an enclosing instantiation. 6939 6940 if Present (Entity (Id)) then 6941 if Scope (Entity (Id)) = Scop then 6942 return Entity (Id); 6943 else 6944 return Empty; 6945 end if; 6946 6947 else 6948 E := First_Entity (Scop); 6949 while Present (E) loop 6950 if Chars (E) = Chars (Id) 6951 and then Is_Child_Unit (E) 6952 then 6953 if Is_Child_Unit (E) 6954 and then not Is_Visible_Lib_Unit (E) 6955 then 6956 Error_Msg_NE 6957 ("generic child unit& is not visible", Gen_Id, E); 6958 end if; 6959 6960 Set_Entity (Id, E); 6961 return E; 6962 end if; 6963 6964 Next_Entity (E); 6965 end loop; 6966 6967 return Empty; 6968 end if; 6969 end Find_Generic_Child; 6970 6971 --------------------------- 6972 -- In_Enclosing_Instance -- 6973 --------------------------- 6974 6975 function In_Enclosing_Instance return Boolean is 6976 Enclosing_Instance : Node_Id; 6977 Instance_Decl : Node_Id; 6978 6979 begin 6980 -- We do not inline any call that contains instantiations, except 6981 -- for instantiations of Unchecked_Conversion, so if we are within 6982 -- an inlined body the current instance does not require parents. 6983 6984 if In_Inlined_Body then 6985 pragma Assert (Chars (Gen_Id) = Name_Unchecked_Conversion); 6986 return False; 6987 end if; 6988 6989 -- Loop to check enclosing scopes 6990 6991 Enclosing_Instance := Current_Scope; 6992 while Present (Enclosing_Instance) loop 6993 Instance_Decl := Unit_Declaration_Node (Enclosing_Instance); 6994 6995 if Ekind (Enclosing_Instance) = E_Package 6996 and then Is_Generic_Instance (Enclosing_Instance) 6997 and then Present 6998 (Generic_Parent (Specification (Instance_Decl))) 6999 then 7000 -- Check whether the generic we are looking for is a child of 7001 -- this instance. 7002 7003 E := Find_Generic_Child 7004 (Generic_Parent (Specification (Instance_Decl)), Gen_Id); 7005 exit when Present (E); 7006 7007 else 7008 E := Empty; 7009 end if; 7010 7011 Enclosing_Instance := Scope (Enclosing_Instance); 7012 end loop; 7013 7014 if No (E) then 7015 7016 -- Not a child unit 7017 7018 Analyze (Gen_Id); 7019 return False; 7020 7021 else 7022 Rewrite (Gen_Id, 7023 Make_Expanded_Name (Loc, 7024 Chars => Chars (E), 7025 Prefix => New_Occurrence_Of (Enclosing_Instance, Loc), 7026 Selector_Name => New_Occurrence_Of (E, Loc))); 7027 7028 Set_Entity (Gen_Id, E); 7029 Set_Etype (Gen_Id, Etype (E)); 7030 Parent_Installed := False; -- Already in scope. 7031 return True; 7032 end if; 7033 end In_Enclosing_Instance; 7034 7035 -- Start of processing for Check_Generic_Child_Unit 7036 7037 begin 7038 -- If the name of the generic is given by a selected component, it may 7039 -- be the name of a generic child unit, and the prefix is the name of an 7040 -- instance of the parent, in which case the child unit must be visible. 7041 -- If this instance is not in scope, it must be placed there and removed 7042 -- after instantiation, because what is being instantiated is not the 7043 -- original child, but the corresponding child present in the instance 7044 -- of the parent. 7045 7046 -- If the child is instantiated within the parent, it can be given by 7047 -- a simple name. In this case the instance is already in scope, but 7048 -- the child generic must be recovered from the generic parent as well. 7049 7050 if Nkind (Gen_Id) = N_Selected_Component then 7051 S := Selector_Name (Gen_Id); 7052 Analyze (Prefix (Gen_Id)); 7053 Inst_Par := Entity (Prefix (Gen_Id)); 7054 7055 if Ekind (Inst_Par) = E_Package 7056 and then Present (Renamed_Object (Inst_Par)) 7057 then 7058 Inst_Par := Renamed_Object (Inst_Par); 7059 end if; 7060 7061 if Ekind (Inst_Par) = E_Package then 7062 if Nkind (Parent (Inst_Par)) = N_Package_Specification then 7063 Gen_Par := Generic_Parent (Parent (Inst_Par)); 7064 7065 elsif Nkind (Parent (Inst_Par)) = N_Defining_Program_Unit_Name 7066 and then 7067 Nkind (Parent (Parent (Inst_Par))) = N_Package_Specification 7068 then 7069 Gen_Par := Generic_Parent (Parent (Parent (Inst_Par))); 7070 end if; 7071 7072 elsif Ekind (Inst_Par) = E_Generic_Package 7073 and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration 7074 then 7075 -- A formal package may be a real child package, and not the 7076 -- implicit instance within a parent. In this case the child is 7077 -- not visible and has to be retrieved explicitly as well. 7078 7079 Gen_Par := Inst_Par; 7080 end if; 7081 7082 if Present (Gen_Par) then 7083 7084 -- The prefix denotes an instantiation. The entity itself may be a 7085 -- nested generic, or a child unit. 7086 7087 E := Find_Generic_Child (Gen_Par, S); 7088 7089 if Present (E) then 7090 Change_Selected_Component_To_Expanded_Name (Gen_Id); 7091 Set_Entity (Gen_Id, E); 7092 Set_Etype (Gen_Id, Etype (E)); 7093 Set_Entity (S, E); 7094 Set_Etype (S, Etype (E)); 7095 7096 -- Indicate that this is a reference to the parent 7097 7098 if In_Extended_Main_Source_Unit (Gen_Id) then 7099 Set_Is_Instantiated (Inst_Par); 7100 end if; 7101 7102 -- A common mistake is to replicate the naming scheme of a 7103 -- hierarchy by instantiating a generic child directly, rather 7104 -- than the implicit child in a parent instance: 7105 7106 -- generic .. package Gpar is .. 7107 -- generic .. package Gpar.Child is .. 7108 -- package Par is new Gpar (); 7109 7110 -- with Gpar.Child; 7111 -- package Par.Child is new Gpar.Child (); 7112 -- rather than Par.Child 7113 7114 -- In this case the instantiation is within Par, which is an 7115 -- instance, but Gpar does not denote Par because we are not IN 7116 -- the instance of Gpar, so this is illegal. The test below 7117 -- recognizes this particular case. 7118 7119 if Is_Child_Unit (E) 7120 and then not Comes_From_Source (Entity (Prefix (Gen_Id))) 7121 and then (not In_Instance 7122 or else Nkind (Parent (Parent (Gen_Id))) = 7123 N_Compilation_Unit) 7124 then 7125 Error_Msg_N 7126 ("prefix of generic child unit must be instance of parent", 7127 Gen_Id); 7128 end if; 7129 7130 if not In_Open_Scopes (Inst_Par) 7131 and then Nkind (Parent (Gen_Id)) not in 7132 N_Generic_Renaming_Declaration 7133 then 7134 Install_Parent (Inst_Par); 7135 Parent_Installed := True; 7136 7137 elsif In_Open_Scopes (Inst_Par) then 7138 7139 -- If the parent is already installed, install the actuals 7140 -- for its formal packages. This is necessary when the child 7141 -- instance is a child of the parent instance: in this case, 7142 -- the parent is placed on the scope stack but the formal 7143 -- packages are not made visible. 7144 7145 Install_Formal_Packages (Inst_Par); 7146 end if; 7147 7148 else 7149 -- If the generic parent does not contain an entity that 7150 -- corresponds to the selector, the instance doesn't either. 7151 -- Analyzing the node will yield the appropriate error message. 7152 -- If the entity is not a child unit, then it is an inner 7153 -- generic in the parent. 7154 7155 Analyze (Gen_Id); 7156 end if; 7157 7158 else 7159 Analyze (Gen_Id); 7160 7161 if Is_Child_Unit (Entity (Gen_Id)) 7162 and then 7163 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration 7164 and then not In_Open_Scopes (Inst_Par) 7165 then 7166 Install_Parent (Inst_Par); 7167 Parent_Installed := True; 7168 7169 -- The generic unit may be the renaming of the implicit child 7170 -- present in an instance. In that case the parent instance is 7171 -- obtained from the name of the renamed entity. 7172 7173 elsif Ekind (Entity (Gen_Id)) = E_Generic_Package 7174 and then Present (Renamed_Entity (Entity (Gen_Id))) 7175 and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id))) 7176 then 7177 declare 7178 Renamed_Package : constant Node_Id := 7179 Name (Parent (Entity (Gen_Id))); 7180 begin 7181 if Nkind (Renamed_Package) = N_Expanded_Name then 7182 Inst_Par := Entity (Prefix (Renamed_Package)); 7183 Install_Parent (Inst_Par); 7184 Parent_Installed := True; 7185 end if; 7186 end; 7187 end if; 7188 end if; 7189 7190 elsif Nkind (Gen_Id) = N_Expanded_Name then 7191 7192 -- Entity already present, analyze prefix, whose meaning may be an 7193 -- instance in the current context. If it is an instance of a 7194 -- relative within another, the proper parent may still have to be 7195 -- installed, if they are not of the same generation. 7196 7197 Analyze (Prefix (Gen_Id)); 7198 7199 -- Prevent cascaded errors 7200 7201 if Etype (Prefix (Gen_Id)) = Any_Type then 7202 return; 7203 end if; 7204 7205 -- In the unlikely case that a local declaration hides the name of 7206 -- the parent package, locate it on the homonym chain. If the context 7207 -- is an instance of the parent, the renaming entity is flagged as 7208 -- such. 7209 7210 Inst_Par := Entity (Prefix (Gen_Id)); 7211 while Present (Inst_Par) 7212 and then not Is_Package_Or_Generic_Package (Inst_Par) 7213 loop 7214 Inst_Par := Homonym (Inst_Par); 7215 end loop; 7216 7217 pragma Assert (Present (Inst_Par)); 7218 Set_Entity (Prefix (Gen_Id), Inst_Par); 7219 7220 if In_Enclosing_Instance then 7221 null; 7222 7223 elsif Present (Entity (Gen_Id)) 7224 and then Is_Child_Unit (Entity (Gen_Id)) 7225 and then not In_Open_Scopes (Inst_Par) 7226 then 7227 Install_Parent (Inst_Par); 7228 Parent_Installed := True; 7229 end if; 7230 7231 elsif In_Enclosing_Instance then 7232 7233 -- The child unit is found in some enclosing scope 7234 7235 null; 7236 7237 else 7238 Analyze (Gen_Id); 7239 7240 -- If this is the renaming of the implicit child in a parent 7241 -- instance, recover the parent name and install it. 7242 7243 if Is_Entity_Name (Gen_Id) then 7244 E := Entity (Gen_Id); 7245 7246 if Is_Generic_Unit (E) 7247 and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration 7248 and then Is_Child_Unit (Renamed_Object (E)) 7249 and then Is_Generic_Unit (Scope (Renamed_Object (E))) 7250 and then Nkind (Name (Parent (E))) = N_Expanded_Name 7251 then 7252 Rewrite (Gen_Id, New_Copy_Tree (Name (Parent (E)))); 7253 Inst_Par := Entity (Prefix (Gen_Id)); 7254 7255 if not In_Open_Scopes (Inst_Par) then 7256 Install_Parent (Inst_Par); 7257 Parent_Installed := True; 7258 end if; 7259 7260 -- If it is a child unit of a non-generic parent, it may be 7261 -- use-visible and given by a direct name. Install parent as 7262 -- for other cases. 7263 7264 elsif Is_Generic_Unit (E) 7265 and then Is_Child_Unit (E) 7266 and then 7267 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration 7268 and then not Is_Generic_Unit (Scope (E)) 7269 then 7270 if not In_Open_Scopes (Scope (E)) then 7271 Install_Parent (Scope (E)); 7272 Parent_Installed := True; 7273 end if; 7274 end if; 7275 end if; 7276 end if; 7277 end Check_Generic_Child_Unit; 7278 7279 ----------------------------- 7280 -- Check_Hidden_Child_Unit -- 7281 ----------------------------- 7282 7283 procedure Check_Hidden_Child_Unit 7284 (N : Node_Id; 7285 Gen_Unit : Entity_Id; 7286 Act_Decl_Id : Entity_Id) 7287 is 7288 Gen_Id : constant Node_Id := Name (N); 7289 7290 begin 7291 if Is_Child_Unit (Gen_Unit) 7292 and then Is_Child_Unit (Act_Decl_Id) 7293 and then Nkind (Gen_Id) = N_Expanded_Name 7294 and then Entity (Prefix (Gen_Id)) = Scope (Act_Decl_Id) 7295 and then Chars (Gen_Unit) = Chars (Act_Decl_Id) 7296 then 7297 Error_Msg_Node_2 := Scope (Act_Decl_Id); 7298 Error_Msg_NE 7299 ("generic unit & is implicitly declared in &", 7300 Defining_Unit_Name (N), Gen_Unit); 7301 Error_Msg_N ("\instance must have different name", 7302 Defining_Unit_Name (N)); 7303 end if; 7304 end Check_Hidden_Child_Unit; 7305 7306 ------------------------ 7307 -- Check_Private_View -- 7308 ------------------------ 7309 7310 procedure Check_Private_View (N : Node_Id) is 7311 T : constant Entity_Id := Etype (N); 7312 BT : Entity_Id; 7313 7314 begin 7315 -- Exchange views if the type was not private in the generic but is 7316 -- private at the point of instantiation. Do not exchange views if 7317 -- the scope of the type is in scope. This can happen if both generic 7318 -- and instance are sibling units, or if type is defined in a parent. 7319 -- In this case the visibility of the type will be correct for all 7320 -- semantic checks. 7321 7322 if Present (T) then 7323 BT := Base_Type (T); 7324 7325 if Is_Private_Type (T) 7326 and then not Has_Private_View (N) 7327 and then Present (Full_View (T)) 7328 and then not In_Open_Scopes (Scope (T)) 7329 then 7330 -- In the generic, the full type was visible. Save the private 7331 -- entity, for subsequent exchange. 7332 7333 Switch_View (T); 7334 7335 elsif Has_Private_View (N) 7336 and then not Is_Private_Type (T) 7337 and then not Has_Been_Exchanged (T) 7338 and then Etype (Get_Associated_Node (N)) /= T 7339 then 7340 -- Only the private declaration was visible in the generic. If 7341 -- the type appears in a subtype declaration, the subtype in the 7342 -- instance must have a view compatible with that of its parent, 7343 -- which must be exchanged (see corresponding code in Restore_ 7344 -- Private_Views). Otherwise, if the type is defined in a parent 7345 -- unit, leave full visibility within instance, which is safe. 7346 7347 if In_Open_Scopes (Scope (Base_Type (T))) 7348 and then not Is_Private_Type (Base_Type (T)) 7349 and then Comes_From_Source (Base_Type (T)) 7350 then 7351 null; 7352 7353 elsif Nkind (Parent (N)) = N_Subtype_Declaration 7354 or else not In_Private_Part (Scope (Base_Type (T))) 7355 then 7356 Prepend_Elmt (T, Exchanged_Views); 7357 Exchange_Declarations (Etype (Get_Associated_Node (N))); 7358 end if; 7359 7360 -- For composite types with inconsistent representation exchange 7361 -- component types accordingly. 7362 7363 elsif Is_Access_Type (T) 7364 and then Is_Private_Type (Designated_Type (T)) 7365 and then not Has_Private_View (N) 7366 and then Present (Full_View (Designated_Type (T))) 7367 then 7368 Switch_View (Designated_Type (T)); 7369 7370 elsif Is_Array_Type (T) then 7371 if Is_Private_Type (Component_Type (T)) 7372 and then not Has_Private_View (N) 7373 and then Present (Full_View (Component_Type (T))) 7374 then 7375 Switch_View (Component_Type (T)); 7376 end if; 7377 7378 -- The normal exchange mechanism relies on the setting of a 7379 -- flag on the reference in the generic. However, an additional 7380 -- mechanism is needed for types that are not explicitly 7381 -- mentioned in the generic, but may be needed in expanded code 7382 -- in the instance. This includes component types of arrays and 7383 -- designated types of access types. This processing must also 7384 -- include the index types of arrays which we take care of here. 7385 7386 declare 7387 Indx : Node_Id; 7388 Typ : Entity_Id; 7389 7390 begin 7391 Indx := First_Index (T); 7392 while Present (Indx) loop 7393 Typ := Base_Type (Etype (Indx)); 7394 7395 if Is_Private_Type (Typ) 7396 and then Present (Full_View (Typ)) 7397 then 7398 Switch_View (Typ); 7399 end if; 7400 7401 Next_Index (Indx); 7402 end loop; 7403 end; 7404 7405 elsif Is_Private_Type (T) 7406 and then Present (Full_View (T)) 7407 and then Is_Array_Type (Full_View (T)) 7408 and then Is_Private_Type (Component_Type (Full_View (T))) 7409 then 7410 Switch_View (T); 7411 7412 -- Finally, a non-private subtype may have a private base type, which 7413 -- must be exchanged for consistency. This can happen when a package 7414 -- body is instantiated, when the scope stack is empty but in fact 7415 -- the subtype and the base type are declared in an enclosing scope. 7416 7417 -- Note that in this case we introduce an inconsistency in the view 7418 -- set, because we switch the base type BT, but there could be some 7419 -- private dependent subtypes of BT which remain unswitched. Such 7420 -- subtypes might need to be switched at a later point (see specific 7421 -- provision for that case in Switch_View). 7422 7423 elsif not Is_Private_Type (T) 7424 and then not Has_Private_View (N) 7425 and then Is_Private_Type (BT) 7426 and then Present (Full_View (BT)) 7427 and then not Is_Generic_Type (BT) 7428 and then not In_Open_Scopes (BT) 7429 then 7430 Prepend_Elmt (Full_View (BT), Exchanged_Views); 7431 Exchange_Declarations (BT); 7432 end if; 7433 end if; 7434 end Check_Private_View; 7435 7436 ----------------------------- 7437 -- Check_Hidden_Primitives -- 7438 ----------------------------- 7439 7440 function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id is 7441 Actual : Node_Id; 7442 Gen_T : Entity_Id; 7443 Result : Elist_Id := No_Elist; 7444 7445 begin 7446 if No (Assoc_List) then 7447 return No_Elist; 7448 end if; 7449 7450 -- Traverse the list of associations between formals and actuals 7451 -- searching for renamings of tagged types 7452 7453 Actual := First (Assoc_List); 7454 while Present (Actual) loop 7455 if Nkind (Actual) = N_Subtype_Declaration then 7456 Gen_T := Generic_Parent_Type (Actual); 7457 7458 if Present (Gen_T) and then Is_Tagged_Type (Gen_T) then 7459 7460 -- Traverse the list of primitives of the actual types 7461 -- searching for hidden primitives that are visible in the 7462 -- corresponding generic formal; leave them visible and 7463 -- append them to Result to restore their decoration later. 7464 7465 Install_Hidden_Primitives 7466 (Prims_List => Result, 7467 Gen_T => Gen_T, 7468 Act_T => Entity (Subtype_Indication (Actual))); 7469 end if; 7470 end if; 7471 7472 Next (Actual); 7473 end loop; 7474 7475 return Result; 7476 end Check_Hidden_Primitives; 7477 7478 -------------------------- 7479 -- Contains_Instance_Of -- 7480 -------------------------- 7481 7482 function Contains_Instance_Of 7483 (Inner : Entity_Id; 7484 Outer : Entity_Id; 7485 N : Node_Id) return Boolean 7486 is 7487 Elmt : Elmt_Id; 7488 Scop : Entity_Id; 7489 7490 begin 7491 Scop := Outer; 7492 7493 -- Verify that there are no circular instantiations. We check whether 7494 -- the unit contains an instance of the current scope or some enclosing 7495 -- scope (in case one of the instances appears in a subunit). Longer 7496 -- circularities involving subunits might seem too pathological to 7497 -- consider, but they were not too pathological for the authors of 7498 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all 7499 -- enclosing generic scopes as containing an instance. 7500 7501 loop 7502 -- Within a generic subprogram body, the scope is not generic, to 7503 -- allow for recursive subprograms. Use the declaration to determine 7504 -- whether this is a generic unit. 7505 7506 if Ekind (Scop) = E_Generic_Package 7507 or else (Is_Subprogram (Scop) 7508 and then Nkind (Unit_Declaration_Node (Scop)) = 7509 N_Generic_Subprogram_Declaration) 7510 then 7511 Elmt := First_Elmt (Inner_Instances (Inner)); 7512 7513 while Present (Elmt) loop 7514 if Node (Elmt) = Scop then 7515 Error_Msg_Node_2 := Inner; 7516 Error_Msg_NE 7517 ("circular Instantiation: & instantiated within &!", 7518 N, Scop); 7519 return True; 7520 7521 elsif Node (Elmt) = Inner then 7522 return True; 7523 7524 elsif Contains_Instance_Of (Node (Elmt), Scop, N) then 7525 Error_Msg_Node_2 := Inner; 7526 Error_Msg_NE 7527 ("circular Instantiation: & instantiated within &!", 7528 N, Node (Elmt)); 7529 return True; 7530 end if; 7531 7532 Next_Elmt (Elmt); 7533 end loop; 7534 7535 -- Indicate that Inner is being instantiated within Scop 7536 7537 Append_Elmt (Inner, Inner_Instances (Scop)); 7538 end if; 7539 7540 if Scop = Standard_Standard then 7541 exit; 7542 else 7543 Scop := Scope (Scop); 7544 end if; 7545 end loop; 7546 7547 return False; 7548 end Contains_Instance_Of; 7549 7550 ----------------------- 7551 -- Copy_Generic_Node -- 7552 ----------------------- 7553 7554 function Copy_Generic_Node 7555 (N : Node_Id; 7556 Parent_Id : Node_Id; 7557 Instantiating : Boolean) return Node_Id 7558 is 7559 Ent : Entity_Id; 7560 New_N : Node_Id; 7561 7562 function Copy_Generic_Descendant (D : Union_Id) return Union_Id; 7563 -- Check the given value of one of the Fields referenced by the current 7564 -- node to determine whether to copy it recursively. The field may hold 7565 -- a Node_Id, a List_Id, or an Elist_Id, or a plain value (Sloc, Uint, 7566 -- Char) in which case it need not be copied. 7567 7568 procedure Copy_Descendants; 7569 -- Common utility for various nodes 7570 7571 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id; 7572 -- Make copy of element list 7573 7574 function Copy_Generic_List 7575 (L : List_Id; 7576 Parent_Id : Node_Id) return List_Id; 7577 -- Apply Copy_Node recursively to the members of a node list 7578 7579 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean; 7580 -- True if an identifier is part of the defining program unit name of 7581 -- a child unit. The entity of such an identifier must be kept (for 7582 -- ASIS use) even though as the name of an enclosing generic it would 7583 -- otherwise not be preserved in the generic tree. 7584 7585 ---------------------- 7586 -- Copy_Descendants -- 7587 ---------------------- 7588 7589 procedure Copy_Descendants is 7590 use Atree.Unchecked_Access; 7591 -- This code section is part of the implementation of an untyped 7592 -- tree traversal, so it needs direct access to node fields. 7593 7594 begin 7595 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N))); 7596 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N))); 7597 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N))); 7598 Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N))); 7599 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N))); 7600 end Copy_Descendants; 7601 7602 ----------------------------- 7603 -- Copy_Generic_Descendant -- 7604 ----------------------------- 7605 7606 function Copy_Generic_Descendant (D : Union_Id) return Union_Id is 7607 begin 7608 if D = Union_Id (Empty) then 7609 return D; 7610 7611 elsif D in Node_Range then 7612 return Union_Id 7613 (Copy_Generic_Node (Node_Id (D), New_N, Instantiating)); 7614 7615 elsif D in List_Range then 7616 return Union_Id (Copy_Generic_List (List_Id (D), New_N)); 7617 7618 elsif D in Elist_Range then 7619 return Union_Id (Copy_Generic_Elist (Elist_Id (D))); 7620 7621 -- Nothing else is copyable (e.g. Uint values), return as is 7622 7623 else 7624 return D; 7625 end if; 7626 end Copy_Generic_Descendant; 7627 7628 ------------------------ 7629 -- Copy_Generic_Elist -- 7630 ------------------------ 7631 7632 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id is 7633 M : Elmt_Id; 7634 L : Elist_Id; 7635 7636 begin 7637 if Present (E) then 7638 L := New_Elmt_List; 7639 M := First_Elmt (E); 7640 while Present (M) loop 7641 Append_Elmt 7642 (Copy_Generic_Node (Node (M), Empty, Instantiating), L); 7643 Next_Elmt (M); 7644 end loop; 7645 7646 return L; 7647 7648 else 7649 return No_Elist; 7650 end if; 7651 end Copy_Generic_Elist; 7652 7653 ----------------------- 7654 -- Copy_Generic_List -- 7655 ----------------------- 7656 7657 function Copy_Generic_List 7658 (L : List_Id; 7659 Parent_Id : Node_Id) return List_Id 7660 is 7661 N : Node_Id; 7662 New_L : List_Id; 7663 7664 begin 7665 if Present (L) then 7666 New_L := New_List; 7667 Set_Parent (New_L, Parent_Id); 7668 7669 N := First (L); 7670 while Present (N) loop 7671 Append (Copy_Generic_Node (N, Empty, Instantiating), New_L); 7672 Next (N); 7673 end loop; 7674 7675 return New_L; 7676 7677 else 7678 return No_List; 7679 end if; 7680 end Copy_Generic_List; 7681 7682 --------------------------- 7683 -- In_Defining_Unit_Name -- 7684 --------------------------- 7685 7686 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean is 7687 begin 7688 return 7689 Present (Parent (Nam)) 7690 and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name 7691 or else 7692 (Nkind (Parent (Nam)) = N_Expanded_Name 7693 and then In_Defining_Unit_Name (Parent (Nam)))); 7694 end In_Defining_Unit_Name; 7695 7696 -- Start of processing for Copy_Generic_Node 7697 7698 begin 7699 if N = Empty then 7700 return N; 7701 end if; 7702 7703 New_N := New_Copy (N); 7704 7705 -- Copy aspects if present 7706 7707 if Has_Aspects (N) then 7708 Set_Has_Aspects (New_N, False); 7709 Set_Aspect_Specifications 7710 (New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id)); 7711 end if; 7712 7713 -- If we are instantiating, we want to adjust the sloc based on the 7714 -- current S_Adjustment. However, if this is the root node of a subunit, 7715 -- we need to defer that adjustment to below (see "elsif Instantiating 7716 -- and Was_Stub"), so it comes after Create_Instantiation_Source has 7717 -- computed the adjustment. 7718 7719 if Instantiating 7720 and then not (Nkind (N) in N_Proper_Body 7721 and then Was_Originally_Stub (N)) 7722 then 7723 Adjust_Instantiation_Sloc (New_N, S_Adjustment); 7724 end if; 7725 7726 if not Is_List_Member (N) then 7727 Set_Parent (New_N, Parent_Id); 7728 end if; 7729 7730 -- Special casing for identifiers and other entity names and operators 7731 7732 if Nkind_In (New_N, N_Character_Literal, 7733 N_Expanded_Name, 7734 N_Identifier, 7735 N_Operator_Symbol) 7736 or else Nkind (New_N) in N_Op 7737 then 7738 if not Instantiating then 7739 7740 -- Link both nodes in order to assign subsequently the entity of 7741 -- the copy to the original node, in case this is a global 7742 -- reference. 7743 7744 Set_Associated_Node (N, New_N); 7745 7746 -- If we are within an instantiation, this is a nested generic 7747 -- that has already been analyzed at the point of definition. 7748 -- We must preserve references that were global to the enclosing 7749 -- parent at that point. Other occurrences, whether global or 7750 -- local to the current generic, must be resolved anew, so we 7751 -- reset the entity in the generic copy. A global reference has a 7752 -- smaller depth than the parent, or else the same depth in case 7753 -- both are distinct compilation units. 7754 7755 -- A child unit is implicitly declared within the enclosing parent 7756 -- but is in fact global to it, and must be preserved. 7757 7758 -- It is also possible for Current_Instantiated_Parent to be 7759 -- defined, and for this not to be a nested generic, namely if 7760 -- the unit is loaded through Rtsfind. In that case, the entity of 7761 -- New_N is only a link to the associated node, and not a defining 7762 -- occurrence. 7763 7764 -- The entities for parent units in the defining_program_unit of a 7765 -- generic child unit are established when the context of the unit 7766 -- is first analyzed, before the generic copy is made. They are 7767 -- preserved in the copy for use in ASIS queries. 7768 7769 Ent := Entity (New_N); 7770 7771 if No (Current_Instantiated_Parent.Gen_Id) then 7772 if No (Ent) 7773 or else Nkind (Ent) /= N_Defining_Identifier 7774 or else not In_Defining_Unit_Name (N) 7775 then 7776 Set_Associated_Node (New_N, Empty); 7777 end if; 7778 7779 elsif No (Ent) 7780 or else 7781 not Nkind_In (Ent, N_Defining_Identifier, 7782 N_Defining_Character_Literal, 7783 N_Defining_Operator_Symbol) 7784 or else No (Scope (Ent)) 7785 or else 7786 (Scope (Ent) = Current_Instantiated_Parent.Gen_Id 7787 and then not Is_Child_Unit (Ent)) 7788 or else 7789 (Scope_Depth (Scope (Ent)) > 7790 Scope_Depth (Current_Instantiated_Parent.Gen_Id) 7791 and then 7792 Get_Source_Unit (Ent) = 7793 Get_Source_Unit (Current_Instantiated_Parent.Gen_Id)) 7794 then 7795 Set_Associated_Node (New_N, Empty); 7796 end if; 7797 7798 -- Case of instantiating identifier or some other name or operator 7799 7800 else 7801 -- If the associated node is still defined, the entity in it 7802 -- is global, and must be copied to the instance. If this copy 7803 -- is being made for a body to inline, it is applied to an 7804 -- instantiated tree, and the entity is already present and 7805 -- must be also preserved. 7806 7807 declare 7808 Assoc : constant Node_Id := Get_Associated_Node (N); 7809 7810 begin 7811 if Present (Assoc) then 7812 if Nkind (Assoc) = Nkind (N) then 7813 Set_Entity (New_N, Entity (Assoc)); 7814 Check_Private_View (N); 7815 7816 -- The node is a reference to a global type and acts as the 7817 -- subtype mark of a qualified expression created in order 7818 -- to aid resolution of accidental overloading in instances. 7819 -- Since N is a reference to a type, the Associated_Node of 7820 -- N denotes an entity rather than another identifier. See 7821 -- Qualify_Universal_Operands for details. 7822 7823 elsif Nkind (N) = N_Identifier 7824 and then Nkind (Parent (N)) = N_Qualified_Expression 7825 and then Subtype_Mark (Parent (N)) = N 7826 and then Is_Qualified_Universal_Literal (Parent (N)) 7827 then 7828 Set_Entity (New_N, Assoc); 7829 7830 -- The name in the call may be a selected component if the 7831 -- call has not been analyzed yet, as may be the case for 7832 -- pre/post conditions in a generic unit. 7833 7834 elsif Nkind (Assoc) = N_Function_Call 7835 and then Is_Entity_Name (Name (Assoc)) 7836 then 7837 Set_Entity (New_N, Entity (Name (Assoc))); 7838 7839 elsif Nkind_In (Assoc, N_Defining_Identifier, 7840 N_Defining_Character_Literal, 7841 N_Defining_Operator_Symbol) 7842 and then Expander_Active 7843 then 7844 -- Inlining case: we are copying a tree that contains 7845 -- global entities, which are preserved in the copy to be 7846 -- used for subsequent inlining. 7847 7848 null; 7849 7850 else 7851 Set_Entity (New_N, Empty); 7852 end if; 7853 end if; 7854 end; 7855 end if; 7856 7857 -- For expanded name, we must copy the Prefix and Selector_Name 7858 7859 if Nkind (N) = N_Expanded_Name then 7860 Set_Prefix 7861 (New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating)); 7862 7863 Set_Selector_Name (New_N, 7864 Copy_Generic_Node (Selector_Name (N), New_N, Instantiating)); 7865 7866 -- For operators, copy the operands 7867 7868 elsif Nkind (N) in N_Op then 7869 if Nkind (N) in N_Binary_Op then 7870 Set_Left_Opnd (New_N, 7871 Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating)); 7872 end if; 7873 7874 Set_Right_Opnd (New_N, 7875 Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating)); 7876 end if; 7877 7878 -- Establish a link between an entity from the generic template and the 7879 -- corresponding entity in the generic copy to be analyzed. 7880 7881 elsif Nkind (N) in N_Entity then 7882 if not Instantiating then 7883 Set_Associated_Entity (N, New_N); 7884 end if; 7885 7886 -- Clear any existing link the copy may inherit from the replicated 7887 -- generic template entity. 7888 7889 Set_Associated_Entity (New_N, Empty); 7890 7891 -- Special casing for stubs 7892 7893 elsif Nkind (N) in N_Body_Stub then 7894 7895 -- In any case, we must copy the specification or defining 7896 -- identifier as appropriate. 7897 7898 if Nkind (N) = N_Subprogram_Body_Stub then 7899 Set_Specification (New_N, 7900 Copy_Generic_Node (Specification (N), New_N, Instantiating)); 7901 7902 else 7903 Set_Defining_Identifier (New_N, 7904 Copy_Generic_Node 7905 (Defining_Identifier (N), New_N, Instantiating)); 7906 end if; 7907 7908 -- If we are not instantiating, then this is where we load and 7909 -- analyze subunits, i.e. at the point where the stub occurs. A 7910 -- more permissive system might defer this analysis to the point 7911 -- of instantiation, but this seems too complicated for now. 7912 7913 if not Instantiating then 7914 declare 7915 Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N); 7916 Subunit : Node_Id; 7917 Unum : Unit_Number_Type; 7918 New_Body : Node_Id; 7919 7920 begin 7921 -- Make sure that, if it is a subunit of the main unit that is 7922 -- preprocessed and if -gnateG is specified, the preprocessed 7923 -- file will be written. 7924 7925 Lib.Analysing_Subunit_Of_Main := 7926 Lib.In_Extended_Main_Source_Unit (N); 7927 Unum := 7928 Load_Unit 7929 (Load_Name => Subunit_Name, 7930 Required => False, 7931 Subunit => True, 7932 Error_Node => N); 7933 Lib.Analysing_Subunit_Of_Main := False; 7934 7935 -- If the proper body is not found, a warning message will be 7936 -- emitted when analyzing the stub, or later at the point of 7937 -- instantiation. Here we just leave the stub as is. 7938 7939 if Unum = No_Unit then 7940 Subunits_Missing := True; 7941 goto Subunit_Not_Found; 7942 end if; 7943 7944 Subunit := Cunit (Unum); 7945 7946 if Nkind (Unit (Subunit)) /= N_Subunit then 7947 Error_Msg_N 7948 ("found child unit instead of expected SEPARATE subunit", 7949 Subunit); 7950 Error_Msg_Sloc := Sloc (N); 7951 Error_Msg_N ("\to complete stub #", Subunit); 7952 goto Subunit_Not_Found; 7953 end if; 7954 7955 -- We must create a generic copy of the subunit, in order to 7956 -- perform semantic analysis on it, and we must replace the 7957 -- stub in the original generic unit with the subunit, in order 7958 -- to preserve non-local references within. 7959 7960 -- Only the proper body needs to be copied. Library_Unit and 7961 -- context clause are simply inherited by the generic copy. 7962 -- Note that the copy (which may be recursive if there are 7963 -- nested subunits) must be done first, before attaching it to 7964 -- the enclosing generic. 7965 7966 New_Body := 7967 Copy_Generic_Node 7968 (Proper_Body (Unit (Subunit)), 7969 Empty, Instantiating => False); 7970 7971 -- Now place the original proper body in the original generic 7972 -- unit. This is a body, not a compilation unit. 7973 7974 Rewrite (N, Proper_Body (Unit (Subunit))); 7975 Set_Is_Compilation_Unit (Defining_Entity (N), False); 7976 Set_Was_Originally_Stub (N); 7977 7978 -- Finally replace the body of the subunit with its copy, and 7979 -- make this new subunit into the library unit of the generic 7980 -- copy, which does not have stubs any longer. 7981 7982 Set_Proper_Body (Unit (Subunit), New_Body); 7983 Set_Library_Unit (New_N, Subunit); 7984 Inherit_Context (Unit (Subunit), N); 7985 end; 7986 7987 -- If we are instantiating, this must be an error case, since 7988 -- otherwise we would have replaced the stub node by the proper body 7989 -- that corresponds. So just ignore it in the copy (i.e. we have 7990 -- copied it, and that is good enough). 7991 7992 else 7993 null; 7994 end if; 7995 7996 <<Subunit_Not_Found>> null; 7997 7998 -- If the node is a compilation unit, it is the subunit of a stub, which 7999 -- has been loaded already (see code below). In this case, the library 8000 -- unit field of N points to the parent unit (which is a compilation 8001 -- unit) and need not (and cannot) be copied. 8002 8003 -- When the proper body of the stub is analyzed, the library_unit link 8004 -- is used to establish the proper context (see sem_ch10). 8005 8006 -- The other fields of a compilation unit are copied as usual 8007 8008 elsif Nkind (N) = N_Compilation_Unit then 8009 8010 -- This code can only be executed when not instantiating, because in 8011 -- the copy made for an instantiation, the compilation unit node has 8012 -- disappeared at the point that a stub is replaced by its proper 8013 -- body. 8014 8015 pragma Assert (not Instantiating); 8016 8017 Set_Context_Items (New_N, 8018 Copy_Generic_List (Context_Items (N), New_N)); 8019 8020 Set_Unit (New_N, 8021 Copy_Generic_Node (Unit (N), New_N, Instantiating => False)); 8022 8023 Set_First_Inlined_Subprogram (New_N, 8024 Copy_Generic_Node 8025 (First_Inlined_Subprogram (N), New_N, Instantiating => False)); 8026 8027 Set_Aux_Decls_Node 8028 (New_N, 8029 Copy_Generic_Node 8030 (Aux_Decls_Node (N), New_N, Instantiating => False)); 8031 8032 -- For an assignment node, the assignment is known to be semantically 8033 -- legal if we are instantiating the template. This avoids incorrect 8034 -- diagnostics in generated code. 8035 8036 elsif Nkind (N) = N_Assignment_Statement then 8037 8038 -- Copy name and expression fields in usual manner 8039 8040 Set_Name (New_N, 8041 Copy_Generic_Node (Name (N), New_N, Instantiating)); 8042 8043 Set_Expression (New_N, 8044 Copy_Generic_Node (Expression (N), New_N, Instantiating)); 8045 8046 if Instantiating then 8047 Set_Assignment_OK (Name (New_N), True); 8048 end if; 8049 8050 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 8051 if not Instantiating then 8052 Set_Associated_Node (N, New_N); 8053 8054 else 8055 if Present (Get_Associated_Node (N)) 8056 and then Nkind (Get_Associated_Node (N)) = Nkind (N) 8057 then 8058 -- In the generic the aggregate has some composite type. If at 8059 -- the point of instantiation the type has a private view, 8060 -- install the full view (and that of its ancestors, if any). 8061 8062 declare 8063 T : Entity_Id := (Etype (Get_Associated_Node (New_N))); 8064 Rt : Entity_Id; 8065 8066 begin 8067 if Present (T) and then Is_Private_Type (T) then 8068 Switch_View (T); 8069 end if; 8070 8071 if Present (T) 8072 and then Is_Tagged_Type (T) 8073 and then Is_Derived_Type (T) 8074 then 8075 Rt := Root_Type (T); 8076 8077 loop 8078 T := Etype (T); 8079 8080 if Is_Private_Type (T) then 8081 Switch_View (T); 8082 end if; 8083 8084 exit when T = Rt; 8085 end loop; 8086 end if; 8087 end; 8088 end if; 8089 end if; 8090 8091 -- Do not copy the associated node, which points to the generic copy 8092 -- of the aggregate. 8093 8094 declare 8095 use Atree.Unchecked_Access; 8096 -- This code section is part of the implementation of an untyped 8097 -- tree traversal, so it needs direct access to node fields. 8098 8099 begin 8100 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N))); 8101 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N))); 8102 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N))); 8103 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N))); 8104 end; 8105 8106 -- Allocators do not have an identifier denoting the access type, so we 8107 -- must locate it through the expression to check whether the views are 8108 -- consistent. 8109 8110 elsif Nkind (N) = N_Allocator 8111 and then Nkind (Expression (N)) = N_Qualified_Expression 8112 and then Is_Entity_Name (Subtype_Mark (Expression (N))) 8113 and then Instantiating 8114 then 8115 declare 8116 T : constant Node_Id := 8117 Get_Associated_Node (Subtype_Mark (Expression (N))); 8118 Acc_T : Entity_Id; 8119 8120 begin 8121 if Present (T) then 8122 8123 -- Retrieve the allocator node in the generic copy 8124 8125 Acc_T := Etype (Parent (Parent (T))); 8126 8127 if Present (Acc_T) and then Is_Private_Type (Acc_T) then 8128 Switch_View (Acc_T); 8129 end if; 8130 end if; 8131 8132 Copy_Descendants; 8133 end; 8134 8135 -- For a proper body, we must catch the case of a proper body that 8136 -- replaces a stub. This represents the point at which a separate 8137 -- compilation unit, and hence template file, may be referenced, so we 8138 -- must make a new source instantiation entry for the template of the 8139 -- subunit, and ensure that all nodes in the subunit are adjusted using 8140 -- this new source instantiation entry. 8141 8142 elsif Nkind (N) in N_Proper_Body then 8143 declare 8144 Save_Adjustment : constant Sloc_Adjustment := S_Adjustment; 8145 begin 8146 if Instantiating and then Was_Originally_Stub (N) then 8147 Create_Instantiation_Source 8148 (Instantiation_Node, 8149 Defining_Entity (N), 8150 S_Adjustment); 8151 8152 Adjust_Instantiation_Sloc (New_N, S_Adjustment); 8153 end if; 8154 8155 -- Now copy the fields of the proper body, using the new 8156 -- adjustment factor if one was needed as per test above. 8157 8158 Copy_Descendants; 8159 8160 -- Restore the original adjustment factor 8161 8162 S_Adjustment := Save_Adjustment; 8163 end; 8164 8165 elsif Nkind (N) = N_Pragma and then Instantiating then 8166 8167 -- Do not copy Comment or Ident pragmas their content is relevant to 8168 -- the generic unit, not to the instantiating unit. 8169 8170 if Nam_In (Pragma_Name_Unmapped (N), Name_Comment, Name_Ident) then 8171 New_N := Make_Null_Statement (Sloc (N)); 8172 8173 -- Do not copy pragmas generated from aspects because the pragmas do 8174 -- not carry any semantic information, plus they will be regenerated 8175 -- in the instance. 8176 8177 -- However, generating C we need to copy them since postconditions 8178 -- are inlined by the front end, and the front-end inlining machinery 8179 -- relies on this routine to perform inlining. 8180 8181 elsif From_Aspect_Specification (N) 8182 and then not Modify_Tree_For_C 8183 then 8184 New_N := Make_Null_Statement (Sloc (N)); 8185 8186 else 8187 Copy_Descendants; 8188 end if; 8189 8190 elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then 8191 8192 -- No descendant fields need traversing 8193 8194 null; 8195 8196 elsif Nkind (N) = N_String_Literal 8197 and then Present (Etype (N)) 8198 and then Instantiating 8199 then 8200 -- If the string is declared in an outer scope, the string_literal 8201 -- subtype created for it may have the wrong scope. Force reanalysis 8202 -- of the constant to generate a new itype in the proper context. 8203 8204 Set_Etype (New_N, Empty); 8205 Set_Analyzed (New_N, False); 8206 8207 -- For the remaining nodes, copy their descendants recursively 8208 8209 else 8210 Copy_Descendants; 8211 8212 if Instantiating and then Nkind (N) = N_Subprogram_Body then 8213 Set_Generic_Parent (Specification (New_N), N); 8214 8215 -- Should preserve Corresponding_Spec??? (12.3(14)) 8216 end if; 8217 end if; 8218 8219 -- Propagate dimensions if present, so that they are reflected in the 8220 -- instance. 8221 8222 if Nkind (N) in N_Has_Etype 8223 and then (Nkind (N) in N_Op or else Is_Entity_Name (N)) 8224 and then Present (Etype (N)) 8225 and then Is_Floating_Point_Type (Etype (N)) 8226 and then Has_Dimension_System (Etype (N)) 8227 then 8228 Copy_Dimensions (N, New_N); 8229 end if; 8230 8231 return New_N; 8232 end Copy_Generic_Node; 8233 8234 ---------------------------- 8235 -- Denotes_Formal_Package -- 8236 ---------------------------- 8237 8238 function Denotes_Formal_Package 8239 (Pack : Entity_Id; 8240 On_Exit : Boolean := False; 8241 Instance : Entity_Id := Empty) return Boolean 8242 is 8243 Par : Entity_Id; 8244 Scop : constant Entity_Id := Scope (Pack); 8245 E : Entity_Id; 8246 8247 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean; 8248 -- The package in question may be an actual for a previous formal 8249 -- package P of the current instance, so examine its actuals as well. 8250 -- This must be recursive over other formal packages. 8251 8252 ---------------------------------- 8253 -- Is_Actual_Of_Previous_Formal -- 8254 ---------------------------------- 8255 8256 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean is 8257 E1 : Entity_Id; 8258 8259 begin 8260 E1 := First_Entity (P); 8261 while Present (E1) and then E1 /= Instance loop 8262 if Ekind (E1) = E_Package 8263 and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration 8264 then 8265 if Renamed_Object (E1) = Pack then 8266 return True; 8267 8268 elsif E1 = P or else Renamed_Object (E1) = P then 8269 return False; 8270 8271 elsif Is_Actual_Of_Previous_Formal (E1) then 8272 return True; 8273 end if; 8274 end if; 8275 8276 Next_Entity (E1); 8277 end loop; 8278 8279 return False; 8280 end Is_Actual_Of_Previous_Formal; 8281 8282 -- Start of processing for Denotes_Formal_Package 8283 8284 begin 8285 if On_Exit then 8286 Par := 8287 Instance_Envs.Table 8288 (Instance_Envs.Last).Instantiated_Parent.Act_Id; 8289 else 8290 Par := Current_Instantiated_Parent.Act_Id; 8291 end if; 8292 8293 if Ekind (Scop) = E_Generic_Package 8294 or else Nkind (Unit_Declaration_Node (Scop)) = 8295 N_Generic_Subprogram_Declaration 8296 then 8297 return True; 8298 8299 elsif Nkind (Original_Node (Unit_Declaration_Node (Pack))) = 8300 N_Formal_Package_Declaration 8301 then 8302 return True; 8303 8304 elsif No (Par) then 8305 return False; 8306 8307 else 8308 -- Check whether this package is associated with a formal package of 8309 -- the enclosing instantiation. Iterate over the list of renamings. 8310 8311 E := First_Entity (Par); 8312 while Present (E) loop 8313 if Ekind (E) /= E_Package 8314 or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration 8315 then 8316 null; 8317 8318 elsif Renamed_Object (E) = Par then 8319 return False; 8320 8321 elsif Renamed_Object (E) = Pack then 8322 return True; 8323 8324 elsif Is_Actual_Of_Previous_Formal (E) then 8325 return True; 8326 8327 end if; 8328 8329 Next_Entity (E); 8330 end loop; 8331 8332 return False; 8333 end if; 8334 end Denotes_Formal_Package; 8335 8336 ----------------- 8337 -- End_Generic -- 8338 ----------------- 8339 8340 procedure End_Generic is 8341 begin 8342 -- ??? More things could be factored out in this routine. Should 8343 -- probably be done at a later stage. 8344 8345 Inside_A_Generic := Generic_Flags.Table (Generic_Flags.Last); 8346 Generic_Flags.Decrement_Last; 8347 8348 Expander_Mode_Restore; 8349 end End_Generic; 8350 8351 ------------- 8352 -- Earlier -- 8353 ------------- 8354 8355 function Earlier (N1, N2 : Node_Id) return Boolean is 8356 procedure Find_Depth (P : in out Node_Id; D : in out Integer); 8357 -- Find distance from given node to enclosing compilation unit 8358 8359 ---------------- 8360 -- Find_Depth -- 8361 ---------------- 8362 8363 procedure Find_Depth (P : in out Node_Id; D : in out Integer) is 8364 begin 8365 while Present (P) 8366 and then Nkind (P) /= N_Compilation_Unit 8367 loop 8368 P := True_Parent (P); 8369 D := D + 1; 8370 end loop; 8371 end Find_Depth; 8372 8373 -- Local declarations 8374 8375 D1 : Integer := 0; 8376 D2 : Integer := 0; 8377 P1 : Node_Id := N1; 8378 P2 : Node_Id := N2; 8379 T1 : Source_Ptr; 8380 T2 : Source_Ptr; 8381 8382 -- Start of processing for Earlier 8383 8384 begin 8385 Find_Depth (P1, D1); 8386 Find_Depth (P2, D2); 8387 8388 if P1 /= P2 then 8389 return False; 8390 else 8391 P1 := N1; 8392 P2 := N2; 8393 end if; 8394 8395 while D1 > D2 loop 8396 P1 := True_Parent (P1); 8397 D1 := D1 - 1; 8398 end loop; 8399 8400 while D2 > D1 loop 8401 P2 := True_Parent (P2); 8402 D2 := D2 - 1; 8403 end loop; 8404 8405 -- At this point P1 and P2 are at the same distance from the root. 8406 -- We examine their parents until we find a common declarative list. 8407 -- If we reach the root, N1 and N2 do not descend from the same 8408 -- declarative list (e.g. one is nested in the declarative part and 8409 -- the other is in a block in the statement part) and the earlier 8410 -- one is already frozen. 8411 8412 while not Is_List_Member (P1) 8413 or else not Is_List_Member (P2) 8414 or else List_Containing (P1) /= List_Containing (P2) 8415 loop 8416 P1 := True_Parent (P1); 8417 P2 := True_Parent (P2); 8418 8419 if Nkind (Parent (P1)) = N_Subunit then 8420 P1 := Corresponding_Stub (Parent (P1)); 8421 end if; 8422 8423 if Nkind (Parent (P2)) = N_Subunit then 8424 P2 := Corresponding_Stub (Parent (P2)); 8425 end if; 8426 8427 if P1 = P2 then 8428 return False; 8429 end if; 8430 end loop; 8431 8432 -- Expanded code usually shares the source location of the original 8433 -- construct it was generated for. This however may not necessarily 8434 -- reflect the true location of the code within the tree. 8435 8436 -- Before comparing the slocs of the two nodes, make sure that we are 8437 -- working with correct source locations. Assume that P1 is to the left 8438 -- of P2. If either one does not come from source, traverse the common 8439 -- list heading towards the other node and locate the first source 8440 -- statement. 8441 8442 -- P1 P2 8443 -- ----+===+===+--------------+===+===+---- 8444 -- expanded code expanded code 8445 8446 if not Comes_From_Source (P1) then 8447 while Present (P1) loop 8448 8449 -- Neither P2 nor a source statement were located during the 8450 -- search. If we reach the end of the list, then P1 does not 8451 -- occur earlier than P2. 8452 8453 -- ----> 8454 -- start --- P2 ----- P1 --- end 8455 8456 if No (Next (P1)) then 8457 return False; 8458 8459 -- We encounter P2 while going to the right of the list. This 8460 -- means that P1 does indeed appear earlier. 8461 8462 -- ----> 8463 -- start --- P1 ===== P2 --- end 8464 -- expanded code in between 8465 8466 elsif P1 = P2 then 8467 return True; 8468 8469 -- No need to look any further since we have located a source 8470 -- statement. 8471 8472 elsif Comes_From_Source (P1) then 8473 exit; 8474 end if; 8475 8476 -- Keep going right 8477 8478 Next (P1); 8479 end loop; 8480 end if; 8481 8482 if not Comes_From_Source (P2) then 8483 while Present (P2) loop 8484 8485 -- Neither P1 nor a source statement were located during the 8486 -- search. If we reach the start of the list, then P1 does not 8487 -- occur earlier than P2. 8488 8489 -- <---- 8490 -- start --- P2 --- P1 --- end 8491 8492 if No (Prev (P2)) then 8493 return False; 8494 8495 -- We encounter P1 while going to the left of the list. This 8496 -- means that P1 does indeed appear earlier. 8497 8498 -- <---- 8499 -- start --- P1 ===== P2 --- end 8500 -- expanded code in between 8501 8502 elsif P2 = P1 then 8503 return True; 8504 8505 -- No need to look any further since we have located a source 8506 -- statement. 8507 8508 elsif Comes_From_Source (P2) then 8509 exit; 8510 end if; 8511 8512 -- Keep going left 8513 8514 Prev (P2); 8515 end loop; 8516 end if; 8517 8518 -- At this point either both nodes came from source or we approximated 8519 -- their source locations through neighboring source statements. 8520 8521 T1 := Top_Level_Location (Sloc (P1)); 8522 T2 := Top_Level_Location (Sloc (P2)); 8523 8524 -- When two nodes come from the same instance, they have identical top 8525 -- level locations. To determine proper relation within the tree, check 8526 -- their locations within the template. 8527 8528 if T1 = T2 then 8529 return Sloc (P1) < Sloc (P2); 8530 8531 -- The two nodes either come from unrelated instances or do not come 8532 -- from instantiated code at all. 8533 8534 else 8535 return T1 < T2; 8536 end if; 8537 end Earlier; 8538 8539 ---------------------- 8540 -- Find_Actual_Type -- 8541 ---------------------- 8542 8543 function Find_Actual_Type 8544 (Typ : Entity_Id; 8545 Gen_Type : Entity_Id) return Entity_Id 8546 is 8547 Gen_Scope : constant Entity_Id := Scope (Gen_Type); 8548 T : Entity_Id; 8549 8550 begin 8551 -- Special processing only applies to child units 8552 8553 if not Is_Child_Unit (Gen_Scope) then 8554 return Get_Instance_Of (Typ); 8555 8556 -- If designated or component type is itself a formal of the child unit, 8557 -- its instance is available. 8558 8559 elsif Scope (Typ) = Gen_Scope then 8560 return Get_Instance_Of (Typ); 8561 8562 -- If the array or access type is not declared in the parent unit, 8563 -- no special processing needed. 8564 8565 elsif not Is_Generic_Type (Typ) 8566 and then Scope (Gen_Scope) /= Scope (Typ) 8567 then 8568 return Get_Instance_Of (Typ); 8569 8570 -- Otherwise, retrieve designated or component type by visibility 8571 8572 else 8573 T := Current_Entity (Typ); 8574 while Present (T) loop 8575 if In_Open_Scopes (Scope (T)) then 8576 return T; 8577 elsif Is_Generic_Actual_Type (T) then 8578 return T; 8579 end if; 8580 8581 T := Homonym (T); 8582 end loop; 8583 8584 return Typ; 8585 end if; 8586 end Find_Actual_Type; 8587 8588 ---------------------------- 8589 -- Freeze_Subprogram_Body -- 8590 ---------------------------- 8591 8592 procedure Freeze_Subprogram_Body 8593 (Inst_Node : Node_Id; 8594 Gen_Body : Node_Id; 8595 Pack_Id : Entity_Id) 8596 is 8597 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 8598 Par : constant Entity_Id := Scope (Gen_Unit); 8599 E_G_Id : Entity_Id; 8600 Enc_G : Entity_Id; 8601 Enc_I : Node_Id; 8602 F_Node : Node_Id; 8603 8604 function Enclosing_Package_Body (N : Node_Id) return Node_Id; 8605 -- Find innermost package body that encloses the given node, and which 8606 -- is not a compilation unit. Freeze nodes for the instance, or for its 8607 -- enclosing body, may be inserted after the enclosing_body of the 8608 -- generic unit. Used to determine proper placement of freeze node for 8609 -- both package and subprogram instances. 8610 8611 function Package_Freeze_Node (B : Node_Id) return Node_Id; 8612 -- Find entity for given package body, and locate or create a freeze 8613 -- node for it. 8614 8615 ---------------------------- 8616 -- Enclosing_Package_Body -- 8617 ---------------------------- 8618 8619 function Enclosing_Package_Body (N : Node_Id) return Node_Id is 8620 P : Node_Id; 8621 8622 begin 8623 P := Parent (N); 8624 while Present (P) 8625 and then Nkind (Parent (P)) /= N_Compilation_Unit 8626 loop 8627 if Nkind (P) = N_Package_Body then 8628 if Nkind (Parent (P)) = N_Subunit then 8629 return Corresponding_Stub (Parent (P)); 8630 else 8631 return P; 8632 end if; 8633 end if; 8634 8635 P := True_Parent (P); 8636 end loop; 8637 8638 return Empty; 8639 end Enclosing_Package_Body; 8640 8641 ------------------------- 8642 -- Package_Freeze_Node -- 8643 ------------------------- 8644 8645 function Package_Freeze_Node (B : Node_Id) return Node_Id is 8646 Id : Entity_Id; 8647 8648 begin 8649 if Nkind (B) = N_Package_Body then 8650 Id := Corresponding_Spec (B); 8651 else pragma Assert (Nkind (B) = N_Package_Body_Stub); 8652 Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B)))); 8653 end if; 8654 8655 Ensure_Freeze_Node (Id); 8656 return Freeze_Node (Id); 8657 end Package_Freeze_Node; 8658 8659 -- Start of processing for Freeze_Subprogram_Body 8660 8661 begin 8662 -- If the instance and the generic body appear within the same unit, and 8663 -- the instance precedes the generic, the freeze node for the instance 8664 -- must appear after that of the generic. If the generic is nested 8665 -- within another instance I2, then current instance must be frozen 8666 -- after I2. In both cases, the freeze nodes are those of enclosing 8667 -- packages. Otherwise, the freeze node is placed at the end of the 8668 -- current declarative part. 8669 8670 Enc_G := Enclosing_Package_Body (Gen_Body); 8671 Enc_I := Enclosing_Package_Body (Inst_Node); 8672 Ensure_Freeze_Node (Pack_Id); 8673 F_Node := Freeze_Node (Pack_Id); 8674 8675 if Is_Generic_Instance (Par) 8676 and then Present (Freeze_Node (Par)) 8677 and then In_Same_Declarative_Part 8678 (Parent (Freeze_Node (Par)), Inst_Node) 8679 then 8680 -- The parent was a premature instantiation. Insert freeze node at 8681 -- the end the current declarative part. 8682 8683 if Is_Known_Guaranteed_ABE (Get_Unit_Instantiation_Node (Par)) then 8684 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8685 8686 -- Handle the following case: 8687 -- 8688 -- package Parent_Inst is new ... 8689 -- Parent_Inst [] 8690 -- 8691 -- procedure P ... -- this body freezes Parent_Inst 8692 -- 8693 -- package Inst is new ... 8694 -- 8695 -- In this particular scenario, the freeze node for Inst must be 8696 -- inserted in the same manner as that of Parent_Inst - before the 8697 -- next source body or at the end of the declarative list (body not 8698 -- available). If body P did not exist and Parent_Inst was frozen 8699 -- after Inst, either by a body following Inst or at the end of the 8700 -- declarative region, the freeze node for Inst must be inserted 8701 -- after that of Parent_Inst. This relation is established by 8702 -- comparing the Slocs of Parent_Inst freeze node and Inst. 8703 8704 elsif List_Containing (Get_Unit_Instantiation_Node (Par)) = 8705 List_Containing (Inst_Node) 8706 and then Sloc (Freeze_Node (Par)) < Sloc (Inst_Node) 8707 then 8708 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8709 8710 else 8711 Insert_After (Freeze_Node (Par), F_Node); 8712 end if; 8713 8714 -- The body enclosing the instance should be frozen after the body that 8715 -- includes the generic, because the body of the instance may make 8716 -- references to entities therein. If the two are not in the same 8717 -- declarative part, or if the one enclosing the instance is frozen 8718 -- already, freeze the instance at the end of the current declarative 8719 -- part. 8720 8721 elsif Is_Generic_Instance (Par) 8722 and then Present (Freeze_Node (Par)) 8723 and then Present (Enc_I) 8724 then 8725 if In_Same_Declarative_Part (Parent (Freeze_Node (Par)), Enc_I) 8726 or else 8727 (Nkind (Enc_I) = N_Package_Body 8728 and then In_Same_Declarative_Part 8729 (Parent (Freeze_Node (Par)), Parent (Enc_I))) 8730 then 8731 -- The enclosing package may contain several instances. Rather 8732 -- than computing the earliest point at which to insert its freeze 8733 -- node, we place it at the end of the declarative part of the 8734 -- parent of the generic. 8735 8736 Insert_Freeze_Node_For_Instance 8737 (Freeze_Node (Par), Package_Freeze_Node (Enc_I)); 8738 end if; 8739 8740 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8741 8742 elsif Present (Enc_G) 8743 and then Present (Enc_I) 8744 and then Enc_G /= Enc_I 8745 and then Earlier (Inst_Node, Gen_Body) 8746 then 8747 if Nkind (Enc_G) = N_Package_Body then 8748 E_G_Id := 8749 Corresponding_Spec (Enc_G); 8750 else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub); 8751 E_G_Id := 8752 Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G)))); 8753 end if; 8754 8755 -- Freeze package that encloses instance, and place node after the 8756 -- package that encloses generic. If enclosing package is already 8757 -- frozen we have to assume it is at the proper place. This may be a 8758 -- potential ABE that requires dynamic checking. Do not add a freeze 8759 -- node if the package that encloses the generic is inside the body 8760 -- that encloses the instance, because the freeze node would be in 8761 -- the wrong scope. Additional contortions needed if the bodies are 8762 -- within a subunit. 8763 8764 declare 8765 Enclosing_Body : Node_Id; 8766 8767 begin 8768 if Nkind (Enc_I) = N_Package_Body_Stub then 8769 Enclosing_Body := Proper_Body (Unit (Library_Unit (Enc_I))); 8770 else 8771 Enclosing_Body := Enc_I; 8772 end if; 8773 8774 if Parent (List_Containing (Enc_G)) /= Enclosing_Body then 8775 Insert_Freeze_Node_For_Instance 8776 (Enc_G, Package_Freeze_Node (Enc_I)); 8777 end if; 8778 end; 8779 8780 -- Freeze enclosing subunit before instance 8781 8782 Ensure_Freeze_Node (E_G_Id); 8783 8784 if not Is_List_Member (Freeze_Node (E_G_Id)) then 8785 Insert_After (Enc_G, Freeze_Node (E_G_Id)); 8786 end if; 8787 8788 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8789 8790 else 8791 -- If none of the above, insert freeze node at the end of the current 8792 -- declarative part. 8793 8794 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8795 end if; 8796 end Freeze_Subprogram_Body; 8797 8798 ---------------- 8799 -- Get_Gen_Id -- 8800 ---------------- 8801 8802 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id is 8803 begin 8804 return Generic_Renamings.Table (E).Gen_Id; 8805 end Get_Gen_Id; 8806 8807 --------------------- 8808 -- Get_Instance_Of -- 8809 --------------------- 8810 8811 function Get_Instance_Of (A : Entity_Id) return Entity_Id is 8812 Res : constant Assoc_Ptr := Generic_Renamings_HTable.Get (A); 8813 8814 begin 8815 if Res /= Assoc_Null then 8816 return Generic_Renamings.Table (Res).Act_Id; 8817 8818 else 8819 -- On exit, entity is not instantiated: not a generic parameter, or 8820 -- else parameter of an inner generic unit. 8821 8822 return A; 8823 end if; 8824 end Get_Instance_Of; 8825 8826 --------------------------------- 8827 -- Get_Unit_Instantiation_Node -- 8828 --------------------------------- 8829 8830 function Get_Unit_Instantiation_Node (A : Entity_Id) return Node_Id is 8831 Decl : Node_Id := Unit_Declaration_Node (A); 8832 Inst : Node_Id; 8833 8834 begin 8835 -- If the Package_Instantiation attribute has been set on the package 8836 -- entity, then use it directly when it (or its Original_Node) refers 8837 -- to an N_Package_Instantiation node. In principle it should be 8838 -- possible to have this field set in all cases, which should be 8839 -- investigated, and would allow this function to be significantly 8840 -- simplified. ??? 8841 8842 Inst := Package_Instantiation (A); 8843 8844 if Present (Inst) then 8845 if Nkind (Inst) = N_Package_Instantiation then 8846 return Inst; 8847 8848 elsif Nkind (Original_Node (Inst)) = N_Package_Instantiation then 8849 return Original_Node (Inst); 8850 end if; 8851 end if; 8852 8853 -- If the instantiation is a compilation unit that does not need body 8854 -- then the instantiation node has been rewritten as a package 8855 -- declaration for the instance, and we return the original node. 8856 8857 -- If it is a compilation unit and the instance node has not been 8858 -- rewritten, then it is still the unit of the compilation. Finally, if 8859 -- a body is present, this is a parent of the main unit whose body has 8860 -- been compiled for inlining purposes, and the instantiation node has 8861 -- been rewritten with the instance body. 8862 8863 -- Otherwise the instantiation node appears after the declaration. If 8864 -- the entity is a formal package, the declaration may have been 8865 -- rewritten as a generic declaration (in the case of a formal with box) 8866 -- or left as a formal package declaration if it has actuals, and is 8867 -- found with a forward search. 8868 8869 if Nkind (Parent (Decl)) = N_Compilation_Unit then 8870 if Nkind (Decl) = N_Package_Declaration 8871 and then Present (Corresponding_Body (Decl)) 8872 then 8873 Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); 8874 end if; 8875 8876 if Nkind_In (Original_Node (Decl), N_Function_Instantiation, 8877 N_Package_Instantiation, 8878 N_Procedure_Instantiation) 8879 then 8880 return Original_Node (Decl); 8881 else 8882 return Unit (Parent (Decl)); 8883 end if; 8884 8885 elsif Nkind (Decl) = N_Package_Declaration 8886 and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration 8887 then 8888 return Original_Node (Decl); 8889 8890 else 8891 Inst := Next (Decl); 8892 while not Nkind_In (Inst, N_Formal_Package_Declaration, 8893 N_Function_Instantiation, 8894 N_Package_Instantiation, 8895 N_Procedure_Instantiation) 8896 loop 8897 Next (Inst); 8898 end loop; 8899 8900 return Inst; 8901 end if; 8902 end Get_Unit_Instantiation_Node; 8903 8904 ------------------------ 8905 -- Has_Been_Exchanged -- 8906 ------------------------ 8907 8908 function Has_Been_Exchanged (E : Entity_Id) return Boolean is 8909 Next : Elmt_Id; 8910 8911 begin 8912 Next := First_Elmt (Exchanged_Views); 8913 while Present (Next) loop 8914 if Full_View (Node (Next)) = E then 8915 return True; 8916 end if; 8917 8918 Next_Elmt (Next); 8919 end loop; 8920 8921 return False; 8922 end Has_Been_Exchanged; 8923 8924 ---------- 8925 -- Hash -- 8926 ---------- 8927 8928 function Hash (F : Entity_Id) return HTable_Range is 8929 begin 8930 return HTable_Range (F mod HTable_Size); 8931 end Hash; 8932 8933 ------------------------ 8934 -- Hide_Current_Scope -- 8935 ------------------------ 8936 8937 procedure Hide_Current_Scope is 8938 C : constant Entity_Id := Current_Scope; 8939 E : Entity_Id; 8940 8941 begin 8942 Set_Is_Hidden_Open_Scope (C); 8943 8944 E := First_Entity (C); 8945 while Present (E) loop 8946 if Is_Immediately_Visible (E) then 8947 Set_Is_Immediately_Visible (E, False); 8948 Append_Elmt (E, Hidden_Entities); 8949 end if; 8950 8951 Next_Entity (E); 8952 end loop; 8953 8954 -- Make the scope name invisible as well. This is necessary, but might 8955 -- conflict with calls to Rtsfind later on, in case the scope is a 8956 -- predefined one. There is no clean solution to this problem, so for 8957 -- now we depend on the user not redefining Standard itself in one of 8958 -- the parent units. 8959 8960 if Is_Immediately_Visible (C) and then C /= Standard_Standard then 8961 Set_Is_Immediately_Visible (C, False); 8962 Append_Elmt (C, Hidden_Entities); 8963 end if; 8964 8965 end Hide_Current_Scope; 8966 8967 -------------- 8968 -- Init_Env -- 8969 -------------- 8970 8971 procedure Init_Env is 8972 Saved : Instance_Env; 8973 8974 begin 8975 Saved.Instantiated_Parent := Current_Instantiated_Parent; 8976 Saved.Exchanged_Views := Exchanged_Views; 8977 Saved.Hidden_Entities := Hidden_Entities; 8978 Saved.Current_Sem_Unit := Current_Sem_Unit; 8979 Saved.Parent_Unit_Visible := Parent_Unit_Visible; 8980 Saved.Instance_Parent_Unit := Instance_Parent_Unit; 8981 8982 -- Save configuration switches. These may be reset if the unit is a 8983 -- predefined unit, and the current mode is not Ada 2005. 8984 8985 Saved.Switches := Save_Config_Switches; 8986 8987 Instance_Envs.Append (Saved); 8988 8989 Exchanged_Views := New_Elmt_List; 8990 Hidden_Entities := New_Elmt_List; 8991 8992 -- Make dummy entry for Instantiated parent. If generic unit is legal, 8993 -- this is set properly in Set_Instance_Env. 8994 8995 Current_Instantiated_Parent := 8996 (Current_Scope, Current_Scope, Assoc_Null); 8997 end Init_Env; 8998 8999 --------------------- 9000 -- In_Main_Context -- 9001 --------------------- 9002 9003 function In_Main_Context (E : Entity_Id) return Boolean is 9004 Context : List_Id; 9005 Clause : Node_Id; 9006 Nam : Node_Id; 9007 9008 begin 9009 if not Is_Compilation_Unit (E) 9010 or else Ekind (E) /= E_Package 9011 or else In_Private_Part (E) 9012 then 9013 return False; 9014 end if; 9015 9016 Context := Context_Items (Cunit (Main_Unit)); 9017 9018 Clause := First (Context); 9019 while Present (Clause) loop 9020 if Nkind (Clause) = N_With_Clause then 9021 Nam := Name (Clause); 9022 9023 -- If the current scope is part of the context of the main unit, 9024 -- analysis of the corresponding with_clause is not complete, and 9025 -- the entity is not set. We use the Chars field directly, which 9026 -- might produce false positives in rare cases, but guarantees 9027 -- that we produce all the instance bodies we will need. 9028 9029 if (Is_Entity_Name (Nam) and then Chars (Nam) = Chars (E)) 9030 or else (Nkind (Nam) = N_Selected_Component 9031 and then Chars (Selector_Name (Nam)) = Chars (E)) 9032 then 9033 return True; 9034 end if; 9035 end if; 9036 9037 Next (Clause); 9038 end loop; 9039 9040 return False; 9041 end In_Main_Context; 9042 9043 --------------------- 9044 -- Inherit_Context -- 9045 --------------------- 9046 9047 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id) is 9048 Current_Context : List_Id; 9049 Current_Unit : Node_Id; 9050 Item : Node_Id; 9051 New_I : Node_Id; 9052 9053 Clause : Node_Id; 9054 OK : Boolean; 9055 Lib_Unit : Node_Id; 9056 9057 begin 9058 if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then 9059 9060 -- The inherited context is attached to the enclosing compilation 9061 -- unit. This is either the main unit, or the declaration for the 9062 -- main unit (in case the instantiation appears within the package 9063 -- declaration and the main unit is its body). 9064 9065 Current_Unit := Parent (Inst); 9066 while Present (Current_Unit) 9067 and then Nkind (Current_Unit) /= N_Compilation_Unit 9068 loop 9069 Current_Unit := Parent (Current_Unit); 9070 end loop; 9071 9072 Current_Context := Context_Items (Current_Unit); 9073 9074 Item := First (Context_Items (Parent (Gen_Decl))); 9075 while Present (Item) loop 9076 if Nkind (Item) = N_With_Clause then 9077 Lib_Unit := Library_Unit (Item); 9078 9079 -- Take care to prevent direct cyclic with's 9080 9081 if Lib_Unit /= Current_Unit then 9082 9083 -- Do not add a unit if it is already in the context 9084 9085 Clause := First (Current_Context); 9086 OK := True; 9087 while Present (Clause) loop 9088 if Nkind (Clause) = N_With_Clause 9089 and then Library_Unit (Clause) = Lib_Unit 9090 then 9091 OK := False; 9092 exit; 9093 end if; 9094 9095 Next (Clause); 9096 end loop; 9097 9098 if OK then 9099 New_I := New_Copy (Item); 9100 Set_Implicit_With (New_I); 9101 9102 Append (New_I, Current_Context); 9103 end if; 9104 end if; 9105 end if; 9106 9107 Next (Item); 9108 end loop; 9109 end if; 9110 end Inherit_Context; 9111 9112 ---------------- 9113 -- Initialize -- 9114 ---------------- 9115 9116 procedure Initialize is 9117 begin 9118 Generic_Renamings.Init; 9119 Instance_Envs.Init; 9120 Generic_Flags.Init; 9121 Generic_Renamings_HTable.Reset; 9122 Circularity_Detected := False; 9123 Exchanged_Views := No_Elist; 9124 Hidden_Entities := No_Elist; 9125 end Initialize; 9126 9127 ------------------------------------- 9128 -- Insert_Freeze_Node_For_Instance -- 9129 ------------------------------------- 9130 9131 procedure Insert_Freeze_Node_For_Instance 9132 (N : Node_Id; 9133 F_Node : Node_Id) 9134 is 9135 Decl : Node_Id; 9136 Decls : List_Id; 9137 Inst : Entity_Id; 9138 Par_N : Node_Id; 9139 9140 function Enclosing_Body (N : Node_Id) return Node_Id; 9141 -- Find enclosing package or subprogram body, if any. Freeze node may 9142 -- be placed at end of current declarative list if previous instance 9143 -- and current one have different enclosing bodies. 9144 9145 function Previous_Instance (Gen : Entity_Id) return Entity_Id; 9146 -- Find the local instance, if any, that declares the generic that is 9147 -- being instantiated. If present, the freeze node for this instance 9148 -- must follow the freeze node for the previous instance. 9149 9150 -------------------- 9151 -- Enclosing_Body -- 9152 -------------------- 9153 9154 function Enclosing_Body (N : Node_Id) return Node_Id is 9155 P : Node_Id; 9156 9157 begin 9158 P := Parent (N); 9159 while Present (P) 9160 and then Nkind (Parent (P)) /= N_Compilation_Unit 9161 loop 9162 if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then 9163 if Nkind (Parent (P)) = N_Subunit then 9164 return Corresponding_Stub (Parent (P)); 9165 else 9166 return P; 9167 end if; 9168 end if; 9169 9170 P := True_Parent (P); 9171 end loop; 9172 9173 return Empty; 9174 end Enclosing_Body; 9175 9176 ----------------------- 9177 -- Previous_Instance -- 9178 ----------------------- 9179 9180 function Previous_Instance (Gen : Entity_Id) return Entity_Id is 9181 S : Entity_Id; 9182 9183 begin 9184 S := Scope (Gen); 9185 while Present (S) and then S /= Standard_Standard loop 9186 if Is_Generic_Instance (S) 9187 and then In_Same_Source_Unit (S, N) 9188 then 9189 return S; 9190 end if; 9191 9192 S := Scope (S); 9193 end loop; 9194 9195 return Empty; 9196 end Previous_Instance; 9197 9198 -- Start of processing for Insert_Freeze_Node_For_Instance 9199 9200 begin 9201 if not Is_List_Member (F_Node) then 9202 Decl := N; 9203 Decls := List_Containing (N); 9204 Inst := Entity (F_Node); 9205 Par_N := Parent (Decls); 9206 9207 -- When processing a subprogram instantiation, utilize the actual 9208 -- subprogram instantiation rather than its package wrapper as it 9209 -- carries all the context information. 9210 9211 if Is_Wrapper_Package (Inst) then 9212 Inst := Related_Instance (Inst); 9213 end if; 9214 9215 -- If this is a package instance, check whether the generic is 9216 -- declared in a previous instance and the current instance is 9217 -- not within the previous one. 9218 9219 if Present (Generic_Parent (Parent (Inst))) 9220 and then Is_In_Main_Unit (N) 9221 then 9222 declare 9223 Enclosing_N : constant Node_Id := Enclosing_Body (N); 9224 Par_I : constant Entity_Id := 9225 Previous_Instance 9226 (Generic_Parent (Parent (Inst))); 9227 Scop : Entity_Id; 9228 9229 begin 9230 if Present (Par_I) 9231 and then Earlier (N, Freeze_Node (Par_I)) 9232 then 9233 Scop := Scope (Inst); 9234 9235 -- If the current instance is within the one that contains 9236 -- the generic, the freeze node for the current one must 9237 -- appear in the current declarative part. Ditto, if the 9238 -- current instance is within another package instance or 9239 -- within a body that does not enclose the current instance. 9240 -- In these three cases the freeze node of the previous 9241 -- instance is not relevant. 9242 9243 while Present (Scop) and then Scop /= Standard_Standard loop 9244 exit when Scop = Par_I 9245 or else 9246 (Is_Generic_Instance (Scop) 9247 and then Scope_Depth (Scop) > Scope_Depth (Par_I)); 9248 Scop := Scope (Scop); 9249 end loop; 9250 9251 -- Previous instance encloses current instance 9252 9253 if Scop = Par_I then 9254 null; 9255 9256 -- If the next node is a source body we must freeze in 9257 -- the current scope as well. 9258 9259 elsif Present (Next (N)) 9260 and then Nkind_In (Next (N), N_Subprogram_Body, 9261 N_Package_Body) 9262 and then Comes_From_Source (Next (N)) 9263 then 9264 null; 9265 9266 -- Current instance is within an unrelated instance 9267 9268 elsif Is_Generic_Instance (Scop) then 9269 null; 9270 9271 -- Current instance is within an unrelated body 9272 9273 elsif Present (Enclosing_N) 9274 and then Enclosing_N /= Enclosing_Body (Par_I) 9275 then 9276 null; 9277 9278 else 9279 Insert_After (Freeze_Node (Par_I), F_Node); 9280 return; 9281 end if; 9282 end if; 9283 end; 9284 end if; 9285 9286 -- When the instantiation occurs in a package declaration, append the 9287 -- freeze node to the private declarations (if any). 9288 9289 if Nkind (Par_N) = N_Package_Specification 9290 and then Decls = Visible_Declarations (Par_N) 9291 and then Present (Private_Declarations (Par_N)) 9292 and then not Is_Empty_List (Private_Declarations (Par_N)) 9293 then 9294 Decls := Private_Declarations (Par_N); 9295 Decl := First (Decls); 9296 end if; 9297 9298 -- Determine the proper freeze point of a package instantiation. We 9299 -- adhere to the general rule of a package or subprogram body causing 9300 -- freezing of anything before it in the same declarative region. In 9301 -- this case, the proper freeze point of a package instantiation is 9302 -- before the first source body which follows, or before a stub. This 9303 -- ensures that entities coming from the instance are already frozen 9304 -- and usable in source bodies. 9305 9306 if Nkind (Par_N) /= N_Package_Declaration 9307 and then Ekind (Inst) = E_Package 9308 and then Is_Generic_Instance (Inst) 9309 and then 9310 not In_Same_Source_Unit (Generic_Parent (Parent (Inst)), Inst) 9311 then 9312 while Present (Decl) loop 9313 if (Nkind (Decl) in N_Unit_Body 9314 or else 9315 Nkind (Decl) in N_Body_Stub) 9316 and then Comes_From_Source (Decl) 9317 then 9318 Insert_Before (Decl, F_Node); 9319 return; 9320 end if; 9321 9322 Next (Decl); 9323 end loop; 9324 end if; 9325 9326 -- In a package declaration, or if no previous body, insert at end 9327 -- of list. 9328 9329 Set_Sloc (F_Node, Sloc (Last (Decls))); 9330 Insert_After (Last (Decls), F_Node); 9331 end if; 9332 end Insert_Freeze_Node_For_Instance; 9333 9334 ------------------ 9335 -- Install_Body -- 9336 ------------------ 9337 9338 procedure Install_Body 9339 (Act_Body : Node_Id; 9340 N : Node_Id; 9341 Gen_Body : Node_Id; 9342 Gen_Decl : Node_Id) 9343 is 9344 function In_Same_Scope (Gen_Id, Act_Id : Node_Id) return Boolean; 9345 -- Check if the generic definition and the instantiation come from 9346 -- a common scope, in which case the instance must be frozen after 9347 -- the generic body. 9348 9349 function True_Sloc (N, Act_Unit : Node_Id) return Source_Ptr; 9350 -- If the instance is nested inside a generic unit, the Sloc of the 9351 -- instance indicates the place of the original definition, not the 9352 -- point of the current enclosing instance. Pending a better usage of 9353 -- Slocs to indicate instantiation places, we determine the place of 9354 -- origin of a node by finding the maximum sloc of any ancestor node. 9355 -- Why is this not equivalent to Top_Level_Location ??? 9356 9357 ------------------- 9358 -- In_Same_Scope -- 9359 ------------------- 9360 9361 function In_Same_Scope (Gen_Id, Act_Id : Node_Id) return Boolean is 9362 Act_Scop : Entity_Id := Scope (Act_Id); 9363 Gen_Scop : Entity_Id := Scope (Gen_Id); 9364 9365 begin 9366 while Act_Scop /= Standard_Standard 9367 and then Gen_Scop /= Standard_Standard 9368 loop 9369 if Act_Scop = Gen_Scop then 9370 return True; 9371 end if; 9372 9373 Act_Scop := Scope (Act_Scop); 9374 Gen_Scop := Scope (Gen_Scop); 9375 end loop; 9376 9377 return False; 9378 end In_Same_Scope; 9379 9380 --------------- 9381 -- True_Sloc -- 9382 --------------- 9383 9384 function True_Sloc (N, Act_Unit : Node_Id) return Source_Ptr is 9385 N1 : Node_Id; 9386 Res : Source_Ptr; 9387 9388 begin 9389 Res := Sloc (N); 9390 N1 := N; 9391 while Present (N1) and then N1 /= Act_Unit loop 9392 if Sloc (N1) > Res then 9393 Res := Sloc (N1); 9394 end if; 9395 9396 N1 := Parent (N1); 9397 end loop; 9398 9399 return Res; 9400 end True_Sloc; 9401 9402 Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body); 9403 Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N))); 9404 Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body); 9405 Par : constant Entity_Id := Scope (Gen_Id); 9406 Gen_Unit : constant Node_Id := 9407 Unit (Cunit (Get_Source_Unit (Gen_Decl))); 9408 9409 Body_Unit : Node_Id; 9410 F_Node : Node_Id; 9411 Must_Delay : Boolean; 9412 Orig_Body : Node_Id := Gen_Body; 9413 9414 -- Start of processing for Install_Body 9415 9416 begin 9417 -- Handle first the case of an instance with incomplete actual types. 9418 -- The instance body cannot be placed after the declaration because 9419 -- full views have not been seen yet. Any use of the non-limited views 9420 -- in the instance body requires the presence of a regular with_clause 9421 -- in the enclosing unit, and will fail if this with_clause is missing. 9422 -- We place the instance body at the beginning of the enclosing body, 9423 -- which is the unit being compiled. The freeze node for the instance 9424 -- is then placed after the instance body. 9425 9426 if not Is_Empty_Elmt_List (Incomplete_Actuals (Act_Id)) 9427 and then Expander_Active 9428 and then Ekind (Scope (Act_Id)) = E_Package 9429 then 9430 declare 9431 Scop : constant Entity_Id := Scope (Act_Id); 9432 Body_Id : constant Node_Id := 9433 Corresponding_Body (Unit_Declaration_Node (Scop)); 9434 9435 begin 9436 Ensure_Freeze_Node (Act_Id); 9437 F_Node := Freeze_Node (Act_Id); 9438 if Present (Body_Id) then 9439 Set_Is_Frozen (Act_Id, False); 9440 Prepend (Act_Body, Declarations (Parent (Body_Id))); 9441 if Is_List_Member (F_Node) then 9442 Remove (F_Node); 9443 end if; 9444 9445 Insert_After (Act_Body, F_Node); 9446 end if; 9447 end; 9448 return; 9449 end if; 9450 9451 -- If the body is a subunit, the freeze point is the corresponding stub 9452 -- in the current compilation, not the subunit itself. 9453 9454 if Nkind (Parent (Gen_Body)) = N_Subunit then 9455 Orig_Body := Corresponding_Stub (Parent (Gen_Body)); 9456 else 9457 Orig_Body := Gen_Body; 9458 end if; 9459 9460 Body_Unit := Unit (Cunit (Get_Source_Unit (Orig_Body))); 9461 9462 -- If the instantiation and the generic definition appear in the same 9463 -- package declaration, this is an early instantiation. If they appear 9464 -- in the same declarative part, it is an early instantiation only if 9465 -- the generic body appears textually later, and the generic body is 9466 -- also in the main unit. 9467 9468 -- If instance is nested within a subprogram, and the generic body 9469 -- is not, the instance is delayed because the enclosing body is. If 9470 -- instance and body are within the same scope, or the same subprogram 9471 -- body, indicate explicitly that the instance is delayed. 9472 9473 Must_Delay := 9474 (Gen_Unit = Act_Unit 9475 and then (Nkind_In (Gen_Unit, N_Generic_Package_Declaration, 9476 N_Package_Declaration) 9477 or else (Gen_Unit = Body_Unit 9478 and then True_Sloc (N, Act_Unit) < 9479 Sloc (Orig_Body))) 9480 and then Is_In_Main_Unit (Original_Node (Gen_Unit)) 9481 and then In_Same_Scope (Gen_Id, Act_Id)); 9482 9483 -- If this is an early instantiation, the freeze node is placed after 9484 -- the generic body. Otherwise, if the generic appears in an instance, 9485 -- we cannot freeze the current instance until the outer one is frozen. 9486 -- This is only relevant if the current instance is nested within some 9487 -- inner scope not itself within the outer instance. If this scope is 9488 -- a package body in the same declarative part as the outer instance, 9489 -- then that body needs to be frozen after the outer instance. Finally, 9490 -- if no delay is needed, we place the freeze node at the end of the 9491 -- current declarative part. 9492 9493 if Expander_Active 9494 and then (No (Freeze_Node (Act_Id)) 9495 or else not Is_List_Member (Freeze_Node (Act_Id))) 9496 then 9497 Ensure_Freeze_Node (Act_Id); 9498 F_Node := Freeze_Node (Act_Id); 9499 9500 if Must_Delay then 9501 Insert_After (Orig_Body, F_Node); 9502 9503 elsif Is_Generic_Instance (Par) 9504 and then Present (Freeze_Node (Par)) 9505 and then Scope (Act_Id) /= Par 9506 then 9507 -- Freeze instance of inner generic after instance of enclosing 9508 -- generic. 9509 9510 if In_Same_Declarative_Part (Parent (Freeze_Node (Par)), N) then 9511 9512 -- Handle the following case: 9513 9514 -- package Parent_Inst is new ... 9515 -- Parent_Inst [] 9516 9517 -- procedure P ... -- this body freezes Parent_Inst 9518 9519 -- package Inst is new ... 9520 9521 -- In this particular scenario, the freeze node for Inst must 9522 -- be inserted in the same manner as that of Parent_Inst, 9523 -- before the next source body or at the end of the declarative 9524 -- list (body not available). If body P did not exist and 9525 -- Parent_Inst was frozen after Inst, either by a body 9526 -- following Inst or at the end of the declarative region, 9527 -- the freeze node for Inst must be inserted after that of 9528 -- Parent_Inst. This relation is established by comparing 9529 -- the Slocs of Parent_Inst freeze node and Inst. 9530 -- We examine the parents of the enclosing lists to handle 9531 -- the case where the parent instance is in the visible part 9532 -- of a package declaration, and the inner instance is in 9533 -- the corresponding private part. 9534 9535 if Parent (List_Containing (Get_Unit_Instantiation_Node (Par))) 9536 = Parent (List_Containing (N)) 9537 and then Sloc (Freeze_Node (Par)) < Sloc (N) 9538 then 9539 Insert_Freeze_Node_For_Instance (N, F_Node); 9540 else 9541 Insert_After (Freeze_Node (Par), F_Node); 9542 end if; 9543 9544 -- Freeze package enclosing instance of inner generic after 9545 -- instance of enclosing generic. 9546 9547 elsif Nkind_In (Parent (N), N_Package_Body, N_Subprogram_Body) 9548 and then In_Same_Declarative_Part 9549 (Parent (Freeze_Node (Par)), Parent (N)) 9550 then 9551 declare 9552 Enclosing : Entity_Id; 9553 9554 begin 9555 Enclosing := Corresponding_Spec (Parent (N)); 9556 9557 if No (Enclosing) then 9558 Enclosing := Defining_Entity (Parent (N)); 9559 end if; 9560 9561 Insert_Freeze_Node_For_Instance (N, F_Node); 9562 Ensure_Freeze_Node (Enclosing); 9563 9564 if not Is_List_Member (Freeze_Node (Enclosing)) then 9565 9566 -- The enclosing context is a subunit, insert the freeze 9567 -- node after the stub. 9568 9569 if Nkind (Parent (Parent (N))) = N_Subunit then 9570 Insert_Freeze_Node_For_Instance 9571 (Corresponding_Stub (Parent (Parent (N))), 9572 Freeze_Node (Enclosing)); 9573 9574 -- The enclosing context is a package with a stub body 9575 -- which has already been replaced by the real body. 9576 -- Insert the freeze node after the actual body. 9577 9578 elsif Ekind (Enclosing) = E_Package 9579 and then Present (Body_Entity (Enclosing)) 9580 and then Was_Originally_Stub 9581 (Parent (Body_Entity (Enclosing))) 9582 then 9583 Insert_Freeze_Node_For_Instance 9584 (Parent (Body_Entity (Enclosing)), 9585 Freeze_Node (Enclosing)); 9586 9587 -- The parent instance has been frozen before the body of 9588 -- the enclosing package, insert the freeze node after 9589 -- the body. 9590 9591 elsif List_Containing (Freeze_Node (Par)) = 9592 List_Containing (Parent (N)) 9593 and then Sloc (Freeze_Node (Par)) < Sloc (Parent (N)) 9594 then 9595 Insert_Freeze_Node_For_Instance 9596 (Parent (N), Freeze_Node (Enclosing)); 9597 9598 else 9599 Insert_After 9600 (Freeze_Node (Par), Freeze_Node (Enclosing)); 9601 end if; 9602 end if; 9603 end; 9604 9605 else 9606 Insert_Freeze_Node_For_Instance (N, F_Node); 9607 end if; 9608 9609 else 9610 Insert_Freeze_Node_For_Instance (N, F_Node); 9611 end if; 9612 end if; 9613 9614 Set_Is_Frozen (Act_Id); 9615 Insert_Before (N, Act_Body); 9616 Mark_Rewrite_Insertion (Act_Body); 9617 end Install_Body; 9618 9619 ----------------------------- 9620 -- Install_Formal_Packages -- 9621 ----------------------------- 9622 9623 procedure Install_Formal_Packages (Par : Entity_Id) is 9624 E : Entity_Id; 9625 Gen : Entity_Id; 9626 Gen_E : Entity_Id := Empty; 9627 9628 begin 9629 E := First_Entity (Par); 9630 9631 -- If we are installing an instance parent, locate the formal packages 9632 -- of its generic parent. 9633 9634 if Is_Generic_Instance (Par) then 9635 Gen := Generic_Parent (Package_Specification (Par)); 9636 Gen_E := First_Entity (Gen); 9637 end if; 9638 9639 while Present (E) loop 9640 if Ekind (E) = E_Package 9641 and then Nkind (Parent (E)) = N_Package_Renaming_Declaration 9642 then 9643 -- If this is the renaming for the parent instance, done 9644 9645 if Renamed_Object (E) = Par then 9646 exit; 9647 9648 -- The visibility of a formal of an enclosing generic is already 9649 -- correct. 9650 9651 elsif Denotes_Formal_Package (E) then 9652 null; 9653 9654 elsif Present (Associated_Formal_Package (E)) then 9655 Check_Generic_Actuals (Renamed_Object (E), True); 9656 Set_Is_Hidden (E, False); 9657 9658 -- Find formal package in generic unit that corresponds to 9659 -- (instance of) formal package in instance. 9660 9661 while Present (Gen_E) and then Chars (Gen_E) /= Chars (E) loop 9662 Next_Entity (Gen_E); 9663 end loop; 9664 9665 if Present (Gen_E) then 9666 Map_Formal_Package_Entities (Gen_E, E); 9667 end if; 9668 end if; 9669 end if; 9670 9671 Next_Entity (E); 9672 9673 if Present (Gen_E) then 9674 Next_Entity (Gen_E); 9675 end if; 9676 end loop; 9677 end Install_Formal_Packages; 9678 9679 -------------------- 9680 -- Install_Parent -- 9681 -------------------- 9682 9683 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is 9684 Ancestors : constant Elist_Id := New_Elmt_List; 9685 S : constant Entity_Id := Current_Scope; 9686 Inst_Par : Entity_Id; 9687 First_Par : Entity_Id; 9688 Inst_Node : Node_Id; 9689 Gen_Par : Entity_Id; 9690 First_Gen : Entity_Id; 9691 Elmt : Elmt_Id; 9692 9693 procedure Install_Noninstance_Specs (Par : Entity_Id); 9694 -- Install the scopes of noninstance parent units ending with Par 9695 9696 procedure Install_Spec (Par : Entity_Id); 9697 -- The child unit is within the declarative part of the parent, so the 9698 -- declarations within the parent are immediately visible. 9699 9700 ------------------------------- 9701 -- Install_Noninstance_Specs -- 9702 ------------------------------- 9703 9704 procedure Install_Noninstance_Specs (Par : Entity_Id) is 9705 begin 9706 if Present (Par) 9707 and then Par /= Standard_Standard 9708 and then not In_Open_Scopes (Par) 9709 then 9710 Install_Noninstance_Specs (Scope (Par)); 9711 Install_Spec (Par); 9712 end if; 9713 end Install_Noninstance_Specs; 9714 9715 ------------------ 9716 -- Install_Spec -- 9717 ------------------ 9718 9719 procedure Install_Spec (Par : Entity_Id) is 9720 Spec : constant Node_Id := Package_Specification (Par); 9721 9722 begin 9723 -- If this parent of the child instance is a top-level unit, 9724 -- then record the unit and its visibility for later resetting in 9725 -- Remove_Parent. We exclude units that are generic instances, as we 9726 -- only want to record this information for the ultimate top-level 9727 -- noninstance parent (is that always correct???). 9728 9729 if Scope (Par) = Standard_Standard 9730 and then not Is_Generic_Instance (Par) 9731 then 9732 Parent_Unit_Visible := Is_Immediately_Visible (Par); 9733 Instance_Parent_Unit := Par; 9734 end if; 9735 9736 -- Open the parent scope and make it and its declarations visible. 9737 -- If this point is not within a body, then only the visible 9738 -- declarations should be made visible, and installation of the 9739 -- private declarations is deferred until the appropriate point 9740 -- within analysis of the spec being instantiated (see the handling 9741 -- of parent visibility in Analyze_Package_Specification). This is 9742 -- relaxed in the case where the parent unit is Ada.Tags, to avoid 9743 -- private view problems that occur when compiling instantiations of 9744 -- a generic child of that package (Generic_Dispatching_Constructor). 9745 -- If the instance freezes a tagged type, inlinings of operations 9746 -- from Ada.Tags may need the full view of type Tag. If inlining took 9747 -- proper account of establishing visibility of inlined subprograms' 9748 -- parents then it should be possible to remove this 9749 -- special check. ??? 9750 9751 Push_Scope (Par); 9752 Set_Is_Immediately_Visible (Par); 9753 Install_Visible_Declarations (Par); 9754 Set_Use (Visible_Declarations (Spec)); 9755 9756 if In_Body or else Is_RTU (Par, Ada_Tags) then 9757 Install_Private_Declarations (Par); 9758 Set_Use (Private_Declarations (Spec)); 9759 end if; 9760 end Install_Spec; 9761 9762 -- Start of processing for Install_Parent 9763 9764 begin 9765 -- We need to install the parent instance to compile the instantiation 9766 -- of the child, but the child instance must appear in the current 9767 -- scope. Given that we cannot place the parent above the current scope 9768 -- in the scope stack, we duplicate the current scope and unstack both 9769 -- after the instantiation is complete. 9770 9771 -- If the parent is itself the instantiation of a child unit, we must 9772 -- also stack the instantiation of its parent, and so on. Each such 9773 -- ancestor is the prefix of the name in a prior instantiation. 9774 9775 -- If this is a nested instance, the parent unit itself resolves to 9776 -- a renaming of the parent instance, whose declaration we need. 9777 9778 -- Finally, the parent may be a generic (not an instance) when the 9779 -- child unit appears as a formal package. 9780 9781 Inst_Par := P; 9782 9783 if Present (Renamed_Entity (Inst_Par)) then 9784 Inst_Par := Renamed_Entity (Inst_Par); 9785 end if; 9786 9787 First_Par := Inst_Par; 9788 9789 Gen_Par := Generic_Parent (Package_Specification (Inst_Par)); 9790 9791 First_Gen := Gen_Par; 9792 9793 while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop 9794 9795 -- Load grandparent instance as well 9796 9797 Inst_Node := Get_Unit_Instantiation_Node (Inst_Par); 9798 9799 if Nkind (Name (Inst_Node)) = N_Expanded_Name then 9800 Inst_Par := Entity (Prefix (Name (Inst_Node))); 9801 9802 if Present (Renamed_Entity (Inst_Par)) then 9803 Inst_Par := Renamed_Entity (Inst_Par); 9804 end if; 9805 9806 Gen_Par := Generic_Parent (Package_Specification (Inst_Par)); 9807 9808 if Present (Gen_Par) then 9809 Prepend_Elmt (Inst_Par, Ancestors); 9810 9811 else 9812 -- Parent is not the name of an instantiation 9813 9814 Install_Noninstance_Specs (Inst_Par); 9815 exit; 9816 end if; 9817 9818 else 9819 -- Previous error 9820 9821 exit; 9822 end if; 9823 end loop; 9824 9825 if Present (First_Gen) then 9826 Append_Elmt (First_Par, Ancestors); 9827 else 9828 Install_Noninstance_Specs (First_Par); 9829 end if; 9830 9831 if not Is_Empty_Elmt_List (Ancestors) then 9832 Elmt := First_Elmt (Ancestors); 9833 while Present (Elmt) loop 9834 Install_Spec (Node (Elmt)); 9835 Install_Formal_Packages (Node (Elmt)); 9836 Next_Elmt (Elmt); 9837 end loop; 9838 end if; 9839 9840 if not In_Body then 9841 Push_Scope (S); 9842 end if; 9843 end Install_Parent; 9844 9845 ------------------------------- 9846 -- Install_Hidden_Primitives -- 9847 ------------------------------- 9848 9849 procedure Install_Hidden_Primitives 9850 (Prims_List : in out Elist_Id; 9851 Gen_T : Entity_Id; 9852 Act_T : Entity_Id) 9853 is 9854 Elmt : Elmt_Id; 9855 List : Elist_Id := No_Elist; 9856 Prim_G_Elmt : Elmt_Id; 9857 Prim_A_Elmt : Elmt_Id; 9858 Prim_G : Node_Id; 9859 Prim_A : Node_Id; 9860 9861 begin 9862 -- No action needed in case of serious errors because we cannot trust 9863 -- in the order of primitives 9864 9865 if Serious_Errors_Detected > 0 then 9866 return; 9867 9868 -- No action possible if we don't have available the list of primitive 9869 -- operations 9870 9871 elsif No (Gen_T) 9872 or else not Is_Record_Type (Gen_T) 9873 or else not Is_Tagged_Type (Gen_T) 9874 or else not Is_Record_Type (Act_T) 9875 or else not Is_Tagged_Type (Act_T) 9876 then 9877 return; 9878 9879 -- There is no need to handle interface types since their primitives 9880 -- cannot be hidden 9881 9882 elsif Is_Interface (Gen_T) then 9883 return; 9884 end if; 9885 9886 Prim_G_Elmt := First_Elmt (Primitive_Operations (Gen_T)); 9887 9888 if not Is_Class_Wide_Type (Act_T) then 9889 Prim_A_Elmt := First_Elmt (Primitive_Operations (Act_T)); 9890 else 9891 Prim_A_Elmt := First_Elmt (Primitive_Operations (Root_Type (Act_T))); 9892 end if; 9893 9894 loop 9895 -- Skip predefined primitives in the generic formal 9896 9897 while Present (Prim_G_Elmt) 9898 and then Is_Predefined_Dispatching_Operation (Node (Prim_G_Elmt)) 9899 loop 9900 Next_Elmt (Prim_G_Elmt); 9901 end loop; 9902 9903 -- Skip predefined primitives in the generic actual 9904 9905 while Present (Prim_A_Elmt) 9906 and then Is_Predefined_Dispatching_Operation (Node (Prim_A_Elmt)) 9907 loop 9908 Next_Elmt (Prim_A_Elmt); 9909 end loop; 9910 9911 exit when No (Prim_G_Elmt) or else No (Prim_A_Elmt); 9912 9913 Prim_G := Node (Prim_G_Elmt); 9914 Prim_A := Node (Prim_A_Elmt); 9915 9916 -- There is no need to handle interface primitives because their 9917 -- primitives are not hidden 9918 9919 exit when Present (Interface_Alias (Prim_G)); 9920 9921 -- Here we install one hidden primitive 9922 9923 if Chars (Prim_G) /= Chars (Prim_A) 9924 and then Has_Suffix (Prim_A, 'P') 9925 and then Remove_Suffix (Prim_A, 'P') = Chars (Prim_G) 9926 then 9927 Set_Chars (Prim_A, Chars (Prim_G)); 9928 Append_New_Elmt (Prim_A, To => List); 9929 end if; 9930 9931 Next_Elmt (Prim_A_Elmt); 9932 Next_Elmt (Prim_G_Elmt); 9933 end loop; 9934 9935 -- Append the elements to the list of temporarily visible primitives 9936 -- avoiding duplicates. 9937 9938 if Present (List) then 9939 if No (Prims_List) then 9940 Prims_List := New_Elmt_List; 9941 end if; 9942 9943 Elmt := First_Elmt (List); 9944 while Present (Elmt) loop 9945 Append_Unique_Elmt (Node (Elmt), Prims_List); 9946 Next_Elmt (Elmt); 9947 end loop; 9948 end if; 9949 end Install_Hidden_Primitives; 9950 9951 ------------------------------- 9952 -- Restore_Hidden_Primitives -- 9953 ------------------------------- 9954 9955 procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id) is 9956 Prim_Elmt : Elmt_Id; 9957 Prim : Node_Id; 9958 9959 begin 9960 if Prims_List /= No_Elist then 9961 Prim_Elmt := First_Elmt (Prims_List); 9962 while Present (Prim_Elmt) loop 9963 Prim := Node (Prim_Elmt); 9964 Set_Chars (Prim, Add_Suffix (Prim, 'P')); 9965 Next_Elmt (Prim_Elmt); 9966 end loop; 9967 9968 Prims_List := No_Elist; 9969 end if; 9970 end Restore_Hidden_Primitives; 9971 9972 -------------------------------- 9973 -- Instantiate_Formal_Package -- 9974 -------------------------------- 9975 9976 function Instantiate_Formal_Package 9977 (Formal : Node_Id; 9978 Actual : Node_Id; 9979 Analyzed_Formal : Node_Id) return List_Id 9980 is 9981 Loc : constant Source_Ptr := Sloc (Actual); 9982 Hidden_Formals : constant Elist_Id := New_Elmt_List; 9983 Actual_Pack : Entity_Id; 9984 Formal_Pack : Entity_Id; 9985 Gen_Parent : Entity_Id; 9986 Decls : List_Id; 9987 Nod : Node_Id; 9988 Parent_Spec : Node_Id; 9989 9990 procedure Find_Matching_Actual 9991 (F : Node_Id; 9992 Act : in out Entity_Id); 9993 -- We need to associate each formal entity in the formal package with 9994 -- the corresponding entity in the actual package. The actual package 9995 -- has been analyzed and possibly expanded, and as a result there is 9996 -- no one-to-one correspondence between the two lists (for example, 9997 -- the actual may include subtypes, itypes, and inherited primitive 9998 -- operations, interspersed among the renaming declarations for the 9999 -- actuals). We retrieve the corresponding actual by name because each 10000 -- actual has the same name as the formal, and they do appear in the 10001 -- same order. 10002 10003 function Get_Formal_Entity (N : Node_Id) return Entity_Id; 10004 -- Retrieve entity of defining entity of generic formal parameter. 10005 -- Only the declarations of formals need to be considered when 10006 -- linking them to actuals, but the declarative list may include 10007 -- internal entities generated during analysis, and those are ignored. 10008 10009 procedure Match_Formal_Entity 10010 (Formal_Node : Node_Id; 10011 Formal_Ent : Entity_Id; 10012 Actual_Ent : Entity_Id); 10013 -- Associates the formal entity with the actual. In the case where 10014 -- Formal_Ent is a formal package, this procedure iterates through all 10015 -- of its formals and enters associations between the actuals occurring 10016 -- in the formal package's corresponding actual package (given by 10017 -- Actual_Ent) and the formal package's formal parameters. This 10018 -- procedure recurses if any of the parameters is itself a package. 10019 10020 function Is_Instance_Of 10021 (Act_Spec : Entity_Id; 10022 Gen_Anc : Entity_Id) return Boolean; 10023 -- The actual can be an instantiation of a generic within another 10024 -- instance, in which case there is no direct link from it to the 10025 -- original generic ancestor. In that case, we recognize that the 10026 -- ultimate ancestor is the same by examining names and scopes. 10027 10028 procedure Process_Nested_Formal (Formal : Entity_Id); 10029 -- If the current formal is declared with a box, its own formals are 10030 -- visible in the instance, as they were in the generic, and their 10031 -- Hidden flag must be reset. If some of these formals are themselves 10032 -- packages declared with a box, the processing must be recursive. 10033 10034 -------------------------- 10035 -- Find_Matching_Actual -- 10036 -------------------------- 10037 10038 procedure Find_Matching_Actual 10039 (F : Node_Id; 10040 Act : in out Entity_Id) 10041 is 10042 Formal_Ent : Entity_Id; 10043 10044 begin 10045 case Nkind (Original_Node (F)) is 10046 when N_Formal_Object_Declaration 10047 | N_Formal_Type_Declaration 10048 => 10049 Formal_Ent := Defining_Identifier (F); 10050 10051 while Chars (Act) /= Chars (Formal_Ent) loop 10052 Next_Entity (Act); 10053 end loop; 10054 10055 when N_Formal_Package_Declaration 10056 | N_Formal_Subprogram_Declaration 10057 | N_Generic_Package_Declaration 10058 | N_Package_Declaration 10059 => 10060 Formal_Ent := Defining_Entity (F); 10061 10062 while Chars (Act) /= Chars (Formal_Ent) loop 10063 Next_Entity (Act); 10064 end loop; 10065 10066 when others => 10067 raise Program_Error; 10068 end case; 10069 end Find_Matching_Actual; 10070 10071 ------------------------- 10072 -- Match_Formal_Entity -- 10073 ------------------------- 10074 10075 procedure Match_Formal_Entity 10076 (Formal_Node : Node_Id; 10077 Formal_Ent : Entity_Id; 10078 Actual_Ent : Entity_Id) 10079 is 10080 Act_Pkg : Entity_Id; 10081 10082 begin 10083 Set_Instance_Of (Formal_Ent, Actual_Ent); 10084 10085 if Ekind (Actual_Ent) = E_Package then 10086 10087 -- Record associations for each parameter 10088 10089 Act_Pkg := Actual_Ent; 10090 10091 declare 10092 A_Ent : Entity_Id := First_Entity (Act_Pkg); 10093 F_Ent : Entity_Id; 10094 F_Node : Node_Id; 10095 10096 Gen_Decl : Node_Id; 10097 Formals : List_Id; 10098 Actual : Entity_Id; 10099 10100 begin 10101 -- Retrieve the actual given in the formal package declaration 10102 10103 Actual := Entity (Name (Original_Node (Formal_Node))); 10104 10105 -- The actual in the formal package declaration may be a 10106 -- renamed generic package, in which case we want to retrieve 10107 -- the original generic in order to traverse its formal part. 10108 10109 if Present (Renamed_Entity (Actual)) then 10110 Gen_Decl := Unit_Declaration_Node (Renamed_Entity (Actual)); 10111 else 10112 Gen_Decl := Unit_Declaration_Node (Actual); 10113 end if; 10114 10115 Formals := Generic_Formal_Declarations (Gen_Decl); 10116 10117 if Present (Formals) then 10118 F_Node := First_Non_Pragma (Formals); 10119 else 10120 F_Node := Empty; 10121 end if; 10122 10123 while Present (A_Ent) 10124 and then Present (F_Node) 10125 and then A_Ent /= First_Private_Entity (Act_Pkg) 10126 loop 10127 F_Ent := Get_Formal_Entity (F_Node); 10128 10129 if Present (F_Ent) then 10130 10131 -- This is a formal of the original package. Record 10132 -- association and recurse. 10133 10134 Find_Matching_Actual (F_Node, A_Ent); 10135 Match_Formal_Entity (F_Node, F_Ent, A_Ent); 10136 Next_Entity (A_Ent); 10137 end if; 10138 10139 Next_Non_Pragma (F_Node); 10140 end loop; 10141 end; 10142 end if; 10143 end Match_Formal_Entity; 10144 10145 ----------------------- 10146 -- Get_Formal_Entity -- 10147 ----------------------- 10148 10149 function Get_Formal_Entity (N : Node_Id) return Entity_Id is 10150 Kind : constant Node_Kind := Nkind (Original_Node (N)); 10151 begin 10152 case Kind is 10153 when N_Formal_Object_Declaration => 10154 return Defining_Identifier (N); 10155 10156 when N_Formal_Type_Declaration => 10157 return Defining_Identifier (N); 10158 10159 when N_Formal_Subprogram_Declaration => 10160 return Defining_Unit_Name (Specification (N)); 10161 10162 when N_Formal_Package_Declaration => 10163 return Defining_Identifier (Original_Node (N)); 10164 10165 when N_Generic_Package_Declaration => 10166 return Defining_Identifier (Original_Node (N)); 10167 10168 -- All other declarations are introduced by semantic analysis and 10169 -- have no match in the actual. 10170 10171 when others => 10172 return Empty; 10173 end case; 10174 end Get_Formal_Entity; 10175 10176 -------------------- 10177 -- Is_Instance_Of -- 10178 -------------------- 10179 10180 function Is_Instance_Of 10181 (Act_Spec : Entity_Id; 10182 Gen_Anc : Entity_Id) return Boolean 10183 is 10184 Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec); 10185 10186 begin 10187 if No (Gen_Par) then 10188 return False; 10189 10190 -- Simplest case: the generic parent of the actual is the formal 10191 10192 elsif Gen_Par = Gen_Anc then 10193 return True; 10194 10195 elsif Chars (Gen_Par) /= Chars (Gen_Anc) then 10196 return False; 10197 10198 -- The actual may be obtained through several instantiations. Its 10199 -- scope must itself be an instance of a generic declared in the 10200 -- same scope as the formal. Any other case is detected above. 10201 10202 elsif not Is_Generic_Instance (Scope (Gen_Par)) then 10203 return False; 10204 10205 else 10206 return Generic_Parent (Parent (Scope (Gen_Par))) = Scope (Gen_Anc); 10207 end if; 10208 end Is_Instance_Of; 10209 10210 --------------------------- 10211 -- Process_Nested_Formal -- 10212 --------------------------- 10213 10214 procedure Process_Nested_Formal (Formal : Entity_Id) is 10215 Ent : Entity_Id; 10216 10217 begin 10218 if Present (Associated_Formal_Package (Formal)) 10219 and then Box_Present (Parent (Associated_Formal_Package (Formal))) 10220 then 10221 Ent := First_Entity (Formal); 10222 while Present (Ent) loop 10223 Set_Is_Hidden (Ent, False); 10224 Set_Is_Visible_Formal (Ent); 10225 Set_Is_Potentially_Use_Visible 10226 (Ent, Is_Potentially_Use_Visible (Formal)); 10227 10228 if Ekind (Ent) = E_Package then 10229 exit when Renamed_Entity (Ent) = Renamed_Entity (Formal); 10230 Process_Nested_Formal (Ent); 10231 end if; 10232 10233 Next_Entity (Ent); 10234 end loop; 10235 end if; 10236 end Process_Nested_Formal; 10237 10238 -- Start of processing for Instantiate_Formal_Package 10239 10240 begin 10241 Analyze (Actual); 10242 10243 if not Is_Entity_Name (Actual) 10244 or else Ekind (Entity (Actual)) /= E_Package 10245 then 10246 Error_Msg_N 10247 ("expect package instance to instantiate formal", Actual); 10248 Abandon_Instantiation (Actual); 10249 raise Program_Error; 10250 10251 else 10252 Actual_Pack := Entity (Actual); 10253 Set_Is_Instantiated (Actual_Pack); 10254 10255 -- The actual may be a renamed package, or an outer generic formal 10256 -- package whose instantiation is converted into a renaming. 10257 10258 if Present (Renamed_Object (Actual_Pack)) then 10259 Actual_Pack := Renamed_Object (Actual_Pack); 10260 end if; 10261 10262 if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then 10263 Gen_Parent := Get_Instance_Of (Entity (Name (Analyzed_Formal))); 10264 Formal_Pack := Defining_Identifier (Analyzed_Formal); 10265 else 10266 Gen_Parent := 10267 Generic_Parent (Specification (Analyzed_Formal)); 10268 Formal_Pack := 10269 Defining_Unit_Name (Specification (Analyzed_Formal)); 10270 end if; 10271 10272 if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then 10273 Parent_Spec := Package_Specification (Actual_Pack); 10274 else 10275 Parent_Spec := Parent (Actual_Pack); 10276 end if; 10277 10278 if Gen_Parent = Any_Id then 10279 Error_Msg_N 10280 ("previous error in declaration of formal package", Actual); 10281 Abandon_Instantiation (Actual); 10282 10283 elsif 10284 Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent)) 10285 then 10286 null; 10287 10288 else 10289 Error_Msg_NE 10290 ("actual parameter must be instance of&", Actual, Gen_Parent); 10291 Abandon_Instantiation (Actual); 10292 end if; 10293 10294 Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack); 10295 Map_Formal_Package_Entities (Formal_Pack, Actual_Pack); 10296 10297 Nod := 10298 Make_Package_Renaming_Declaration (Loc, 10299 Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)), 10300 Name => New_Occurrence_Of (Actual_Pack, Loc)); 10301 10302 Set_Associated_Formal_Package 10303 (Defining_Unit_Name (Nod), Defining_Identifier (Formal)); 10304 Decls := New_List (Nod); 10305 10306 -- If the formal F has a box, then the generic declarations are 10307 -- visible in the generic G. In an instance of G, the corresponding 10308 -- entities in the actual for F (which are the actuals for the 10309 -- instantiation of the generic that F denotes) must also be made 10310 -- visible for analysis of the current instance. On exit from the 10311 -- current instance, those entities are made private again. If the 10312 -- actual is currently in use, these entities are also use-visible. 10313 10314 -- The loop through the actual entities also steps through the formal 10315 -- entities and enters associations from formals to actuals into the 10316 -- renaming map. This is necessary to properly handle checking of 10317 -- actual parameter associations for later formals that depend on 10318 -- actuals declared in the formal package. 10319 10320 -- In Ada 2005, partial parameterization requires that we make 10321 -- visible the actuals corresponding to formals that were defaulted 10322 -- in the formal package. There formals are identified because they 10323 -- remain formal generics within the formal package, rather than 10324 -- being renamings of the actuals supplied. 10325 10326 declare 10327 Gen_Decl : constant Node_Id := 10328 Unit_Declaration_Node (Gen_Parent); 10329 Formals : constant List_Id := 10330 Generic_Formal_Declarations (Gen_Decl); 10331 10332 Actual_Ent : Entity_Id; 10333 Actual_Of_Formal : Node_Id; 10334 Formal_Node : Node_Id; 10335 Formal_Ent : Entity_Id; 10336 10337 begin 10338 if Present (Formals) then 10339 Formal_Node := First_Non_Pragma (Formals); 10340 else 10341 Formal_Node := Empty; 10342 end if; 10343 10344 Actual_Ent := First_Entity (Actual_Pack); 10345 Actual_Of_Formal := 10346 First (Visible_Declarations (Specification (Analyzed_Formal))); 10347 while Present (Actual_Ent) 10348 and then Actual_Ent /= First_Private_Entity (Actual_Pack) 10349 loop 10350 if Present (Formal_Node) then 10351 Formal_Ent := Get_Formal_Entity (Formal_Node); 10352 10353 if Present (Formal_Ent) then 10354 Find_Matching_Actual (Formal_Node, Actual_Ent); 10355 Match_Formal_Entity (Formal_Node, Formal_Ent, Actual_Ent); 10356 10357 -- We iterate at the same time over the actuals of the 10358 -- local package created for the formal, to determine 10359 -- which one of the formals of the original generic were 10360 -- defaulted in the formal. The corresponding actual 10361 -- entities are visible in the enclosing instance. 10362 10363 if Box_Present (Formal) 10364 or else 10365 (Present (Actual_Of_Formal) 10366 and then 10367 Is_Generic_Formal 10368 (Get_Formal_Entity (Actual_Of_Formal))) 10369 then 10370 Set_Is_Hidden (Actual_Ent, False); 10371 Set_Is_Visible_Formal (Actual_Ent); 10372 Set_Is_Potentially_Use_Visible 10373 (Actual_Ent, In_Use (Actual_Pack)); 10374 10375 if Ekind (Actual_Ent) = E_Package then 10376 Process_Nested_Formal (Actual_Ent); 10377 end if; 10378 10379 else 10380 if not Is_Hidden (Actual_Ent) then 10381 Append_Elmt (Actual_Ent, Hidden_Formals); 10382 end if; 10383 10384 Set_Is_Hidden (Actual_Ent); 10385 Set_Is_Potentially_Use_Visible (Actual_Ent, False); 10386 end if; 10387 end if; 10388 10389 Next_Non_Pragma (Formal_Node); 10390 Next (Actual_Of_Formal); 10391 10392 else 10393 -- No further formals to match, but the generic part may 10394 -- contain inherited operation that are not hidden in the 10395 -- enclosing instance. 10396 10397 Next_Entity (Actual_Ent); 10398 end if; 10399 end loop; 10400 10401 -- Inherited subprograms generated by formal derived types are 10402 -- also visible if the types are. 10403 10404 Actual_Ent := First_Entity (Actual_Pack); 10405 while Present (Actual_Ent) 10406 and then Actual_Ent /= First_Private_Entity (Actual_Pack) 10407 loop 10408 if Is_Overloadable (Actual_Ent) 10409 and then 10410 Nkind (Parent (Actual_Ent)) = N_Subtype_Declaration 10411 and then 10412 not Is_Hidden (Defining_Identifier (Parent (Actual_Ent))) 10413 then 10414 Set_Is_Hidden (Actual_Ent, False); 10415 Set_Is_Potentially_Use_Visible 10416 (Actual_Ent, In_Use (Actual_Pack)); 10417 end if; 10418 10419 Next_Entity (Actual_Ent); 10420 end loop; 10421 end; 10422 10423 -- If the formal is not declared with a box, reanalyze it as an 10424 -- abbreviated instantiation, to verify the matching rules of 12.7. 10425 -- The actual checks are performed after the generic associations 10426 -- have been analyzed, to guarantee the same visibility for this 10427 -- instantiation and for the actuals. 10428 10429 -- In Ada 2005, the generic associations for the formal can include 10430 -- defaulted parameters. These are ignored during check. This 10431 -- internal instantiation is removed from the tree after conformance 10432 -- checking, because it contains formal declarations for those 10433 -- defaulted parameters, and those should not reach the back-end. 10434 10435 if not Box_Present (Formal) then 10436 declare 10437 I_Pack : constant Entity_Id := 10438 Make_Temporary (Sloc (Actual), 'P'); 10439 10440 begin 10441 Set_Is_Internal (I_Pack); 10442 Set_Ekind (I_Pack, E_Package); 10443 Set_Hidden_In_Formal_Instance (I_Pack, Hidden_Formals); 10444 10445 Append_To (Decls, 10446 Make_Package_Instantiation (Sloc (Actual), 10447 Defining_Unit_Name => I_Pack, 10448 Name => 10449 New_Occurrence_Of 10450 (Get_Instance_Of (Gen_Parent), Sloc (Actual)), 10451 Generic_Associations => Generic_Associations (Formal))); 10452 end; 10453 end if; 10454 10455 return Decls; 10456 end if; 10457 end Instantiate_Formal_Package; 10458 10459 ----------------------------------- 10460 -- Instantiate_Formal_Subprogram -- 10461 ----------------------------------- 10462 10463 function Instantiate_Formal_Subprogram 10464 (Formal : Node_Id; 10465 Actual : Node_Id; 10466 Analyzed_Formal : Node_Id) return Node_Id 10467 is 10468 Analyzed_S : constant Entity_Id := 10469 Defining_Unit_Name (Specification (Analyzed_Formal)); 10470 Formal_Sub : constant Entity_Id := 10471 Defining_Unit_Name (Specification (Formal)); 10472 10473 function From_Parent_Scope (Subp : Entity_Id) return Boolean; 10474 -- If the generic is a child unit, the parent has been installed on the 10475 -- scope stack, but a default subprogram cannot resolve to something 10476 -- on the parent because that parent is not really part of the visible 10477 -- context (it is there to resolve explicit local entities). If the 10478 -- default has resolved in this way, we remove the entity from immediate 10479 -- visibility and analyze the node again to emit an error message or 10480 -- find another visible candidate. 10481 10482 procedure Valid_Actual_Subprogram (Act : Node_Id); 10483 -- Perform legality check and raise exception on failure 10484 10485 ----------------------- 10486 -- From_Parent_Scope -- 10487 ----------------------- 10488 10489 function From_Parent_Scope (Subp : Entity_Id) return Boolean is 10490 Gen_Scope : Node_Id; 10491 10492 begin 10493 Gen_Scope := Scope (Analyzed_S); 10494 while Present (Gen_Scope) and then Is_Child_Unit (Gen_Scope) loop 10495 if Scope (Subp) = Scope (Gen_Scope) then 10496 return True; 10497 end if; 10498 10499 Gen_Scope := Scope (Gen_Scope); 10500 end loop; 10501 10502 return False; 10503 end From_Parent_Scope; 10504 10505 ----------------------------- 10506 -- Valid_Actual_Subprogram -- 10507 ----------------------------- 10508 10509 procedure Valid_Actual_Subprogram (Act : Node_Id) is 10510 Act_E : Entity_Id; 10511 10512 begin 10513 if Is_Entity_Name (Act) then 10514 Act_E := Entity (Act); 10515 10516 elsif Nkind (Act) = N_Selected_Component 10517 and then Is_Entity_Name (Selector_Name (Act)) 10518 then 10519 Act_E := Entity (Selector_Name (Act)); 10520 10521 else 10522 Act_E := Empty; 10523 end if; 10524 10525 if (Present (Act_E) and then Is_Overloadable (Act_E)) 10526 or else Nkind_In (Act, N_Attribute_Reference, 10527 N_Indexed_Component, 10528 N_Character_Literal, 10529 N_Explicit_Dereference) 10530 then 10531 return; 10532 end if; 10533 10534 Error_Msg_NE 10535 ("expect subprogram or entry name in instantiation of &", 10536 Instantiation_Node, Formal_Sub); 10537 Abandon_Instantiation (Instantiation_Node); 10538 end Valid_Actual_Subprogram; 10539 10540 -- Local variables 10541 10542 Decl_Node : Node_Id; 10543 Loc : Source_Ptr; 10544 Nam : Node_Id; 10545 New_Spec : Node_Id; 10546 New_Subp : Entity_Id; 10547 10548 -- Start of processing for Instantiate_Formal_Subprogram 10549 10550 begin 10551 New_Spec := New_Copy_Tree (Specification (Formal)); 10552 10553 -- The tree copy has created the proper instantiation sloc for the 10554 -- new specification. Use this location for all other constructed 10555 -- declarations. 10556 10557 Loc := Sloc (Defining_Unit_Name (New_Spec)); 10558 10559 -- Create new entity for the actual (New_Copy_Tree does not), and 10560 -- indicate that it is an actual. 10561 10562 New_Subp := Make_Defining_Identifier (Loc, Chars (Formal_Sub)); 10563 Set_Ekind (New_Subp, Ekind (Analyzed_S)); 10564 Set_Is_Generic_Actual_Subprogram (New_Subp); 10565 Set_Defining_Unit_Name (New_Spec, New_Subp); 10566 10567 -- Create new entities for the each of the formals in the specification 10568 -- of the renaming declaration built for the actual. 10569 10570 if Present (Parameter_Specifications (New_Spec)) then 10571 declare 10572 F : Node_Id; 10573 F_Id : Entity_Id; 10574 10575 begin 10576 F := First (Parameter_Specifications (New_Spec)); 10577 while Present (F) loop 10578 F_Id := Defining_Identifier (F); 10579 10580 Set_Defining_Identifier (F, 10581 Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id))); 10582 Next (F); 10583 end loop; 10584 end; 10585 end if; 10586 10587 -- Find entity of actual. If the actual is an attribute reference, it 10588 -- cannot be resolved here (its formal is missing) but is handled 10589 -- instead in Attribute_Renaming. If the actual is overloaded, it is 10590 -- fully resolved subsequently, when the renaming declaration for the 10591 -- formal is analyzed. If it is an explicit dereference, resolve the 10592 -- prefix but not the actual itself, to prevent interpretation as call. 10593 10594 if Present (Actual) then 10595 Loc := Sloc (Actual); 10596 Set_Sloc (New_Spec, Loc); 10597 10598 if Nkind (Actual) = N_Operator_Symbol then 10599 Find_Direct_Name (Actual); 10600 10601 elsif Nkind (Actual) = N_Explicit_Dereference then 10602 Analyze (Prefix (Actual)); 10603 10604 elsif Nkind (Actual) /= N_Attribute_Reference then 10605 Analyze (Actual); 10606 end if; 10607 10608 Valid_Actual_Subprogram (Actual); 10609 Nam := Actual; 10610 10611 elsif Present (Default_Name (Formal)) then 10612 if not Nkind_In (Default_Name (Formal), N_Attribute_Reference, 10613 N_Selected_Component, 10614 N_Indexed_Component, 10615 N_Character_Literal) 10616 and then Present (Entity (Default_Name (Formal))) 10617 then 10618 Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc); 10619 else 10620 Nam := New_Copy (Default_Name (Formal)); 10621 Set_Sloc (Nam, Loc); 10622 end if; 10623 10624 elsif Box_Present (Formal) then 10625 10626 -- Actual is resolved at the point of instantiation. Create an 10627 -- identifier or operator with the same name as the formal. 10628 10629 if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then 10630 Nam := 10631 Make_Operator_Symbol (Loc, 10632 Chars => Chars (Formal_Sub), 10633 Strval => No_String); 10634 else 10635 Nam := Make_Identifier (Loc, Chars (Formal_Sub)); 10636 end if; 10637 10638 elsif Nkind (Specification (Formal)) = N_Procedure_Specification 10639 and then Null_Present (Specification (Formal)) 10640 then 10641 -- Generate null body for procedure, for use in the instance 10642 10643 Decl_Node := 10644 Make_Subprogram_Body (Loc, 10645 Specification => New_Spec, 10646 Declarations => New_List, 10647 Handled_Statement_Sequence => 10648 Make_Handled_Sequence_Of_Statements (Loc, 10649 Statements => New_List (Make_Null_Statement (Loc)))); 10650 10651 Set_Is_Intrinsic_Subprogram (Defining_Unit_Name (New_Spec)); 10652 return Decl_Node; 10653 10654 else 10655 Error_Msg_Sloc := Sloc (Scope (Analyzed_S)); 10656 Error_Msg_NE 10657 ("missing actual&", Instantiation_Node, Formal_Sub); 10658 Error_Msg_NE 10659 ("\in instantiation of & declared#", 10660 Instantiation_Node, Scope (Analyzed_S)); 10661 Abandon_Instantiation (Instantiation_Node); 10662 end if; 10663 10664 Decl_Node := 10665 Make_Subprogram_Renaming_Declaration (Loc, 10666 Specification => New_Spec, 10667 Name => Nam); 10668 10669 -- If we do not have an actual and the formal specified <> then set to 10670 -- get proper default. 10671 10672 if No (Actual) and then Box_Present (Formal) then 10673 Set_From_Default (Decl_Node); 10674 end if; 10675 10676 -- Gather possible interpretations for the actual before analyzing the 10677 -- instance. If overloaded, it will be resolved when analyzing the 10678 -- renaming declaration. 10679 10680 if Box_Present (Formal) and then No (Actual) then 10681 Analyze (Nam); 10682 10683 if Is_Child_Unit (Scope (Analyzed_S)) 10684 and then Present (Entity (Nam)) 10685 then 10686 if not Is_Overloaded (Nam) then 10687 if From_Parent_Scope (Entity (Nam)) then 10688 Set_Is_Immediately_Visible (Entity (Nam), False); 10689 Set_Entity (Nam, Empty); 10690 Set_Etype (Nam, Empty); 10691 10692 Analyze (Nam); 10693 Set_Is_Immediately_Visible (Entity (Nam)); 10694 end if; 10695 10696 else 10697 declare 10698 I : Interp_Index; 10699 It : Interp; 10700 10701 begin 10702 Get_First_Interp (Nam, I, It); 10703 while Present (It.Nam) loop 10704 if From_Parent_Scope (It.Nam) then 10705 Remove_Interp (I); 10706 end if; 10707 10708 Get_Next_Interp (I, It); 10709 end loop; 10710 end; 10711 end if; 10712 end if; 10713 end if; 10714 10715 -- The generic instantiation freezes the actual. This can only be done 10716 -- once the actual is resolved, in the analysis of the renaming 10717 -- declaration. To make the formal subprogram entity available, we set 10718 -- Corresponding_Formal_Spec to point to the formal subprogram entity. 10719 -- This is also needed in Analyze_Subprogram_Renaming for the processing 10720 -- of formal abstract subprograms. 10721 10722 Set_Corresponding_Formal_Spec (Decl_Node, Analyzed_S); 10723 10724 -- We cannot analyze the renaming declaration, and thus find the actual, 10725 -- until all the actuals are assembled in the instance. For subsequent 10726 -- checks of other actuals, indicate the node that will hold the 10727 -- instance of this formal. 10728 10729 Set_Instance_Of (Analyzed_S, Nam); 10730 10731 if Nkind (Actual) = N_Selected_Component 10732 and then Is_Task_Type (Etype (Prefix (Actual))) 10733 and then not Is_Frozen (Etype (Prefix (Actual))) 10734 then 10735 -- The renaming declaration will create a body, which must appear 10736 -- outside of the instantiation, We move the renaming declaration 10737 -- out of the instance, and create an additional renaming inside, 10738 -- to prevent freezing anomalies. 10739 10740 declare 10741 Anon_Id : constant Entity_Id := Make_Temporary (Loc, 'E'); 10742 10743 begin 10744 Set_Defining_Unit_Name (New_Spec, Anon_Id); 10745 Insert_Before (Instantiation_Node, Decl_Node); 10746 Analyze (Decl_Node); 10747 10748 -- Now create renaming within the instance 10749 10750 Decl_Node := 10751 Make_Subprogram_Renaming_Declaration (Loc, 10752 Specification => New_Copy_Tree (New_Spec), 10753 Name => New_Occurrence_Of (Anon_Id, Loc)); 10754 10755 Set_Defining_Unit_Name (Specification (Decl_Node), 10756 Make_Defining_Identifier (Loc, Chars (Formal_Sub))); 10757 end; 10758 end if; 10759 10760 return Decl_Node; 10761 end Instantiate_Formal_Subprogram; 10762 10763 ------------------------ 10764 -- Instantiate_Object -- 10765 ------------------------ 10766 10767 function Instantiate_Object 10768 (Formal : Node_Id; 10769 Actual : Node_Id; 10770 Analyzed_Formal : Node_Id) return List_Id 10771 is 10772 Gen_Obj : constant Entity_Id := Defining_Identifier (Formal); 10773 A_Gen_Obj : constant Entity_Id := 10774 Defining_Identifier (Analyzed_Formal); 10775 Acc_Def : Node_Id := Empty; 10776 Act_Assoc : constant Node_Id := Parent (Actual); 10777 Actual_Decl : Node_Id := Empty; 10778 Decl_Node : Node_Id; 10779 Def : Node_Id; 10780 Ftyp : Entity_Id; 10781 List : constant List_Id := New_List; 10782 Loc : constant Source_Ptr := Sloc (Actual); 10783 Orig_Ftyp : constant Entity_Id := Etype (A_Gen_Obj); 10784 Subt_Decl : Node_Id := Empty; 10785 Subt_Mark : Node_Id := Empty; 10786 10787 function Copy_Access_Def return Node_Id; 10788 -- If formal is an anonymous access, copy access definition of formal 10789 -- for generated object declaration. 10790 10791 --------------------- 10792 -- Copy_Access_Def -- 10793 --------------------- 10794 10795 function Copy_Access_Def return Node_Id is 10796 begin 10797 Def := New_Copy_Tree (Acc_Def); 10798 10799 -- In addition, if formal is an access to subprogram we need to 10800 -- generate new formals for the signature of the default, so that 10801 -- the tree is properly formatted for ASIS use. 10802 10803 if Present (Access_To_Subprogram_Definition (Acc_Def)) then 10804 declare 10805 Par_Spec : Node_Id; 10806 begin 10807 Par_Spec := 10808 First (Parameter_Specifications 10809 (Access_To_Subprogram_Definition (Def))); 10810 while Present (Par_Spec) loop 10811 Set_Defining_Identifier (Par_Spec, 10812 Make_Defining_Identifier (Sloc (Acc_Def), 10813 Chars => Chars (Defining_Identifier (Par_Spec)))); 10814 Next (Par_Spec); 10815 end loop; 10816 end; 10817 end if; 10818 10819 return Def; 10820 end Copy_Access_Def; 10821 10822 -- Start of processing for Instantiate_Object 10823 10824 begin 10825 -- Formal may be an anonymous access 10826 10827 if Present (Subtype_Mark (Formal)) then 10828 Subt_Mark := Subtype_Mark (Formal); 10829 else 10830 Check_Access_Definition (Formal); 10831 Acc_Def := Access_Definition (Formal); 10832 end if; 10833 10834 -- Sloc for error message on missing actual 10835 10836 Error_Msg_Sloc := Sloc (Scope (A_Gen_Obj)); 10837 10838 if Get_Instance_Of (Gen_Obj) /= Gen_Obj then 10839 Error_Msg_N ("duplicate instantiation of generic parameter", Actual); 10840 end if; 10841 10842 Set_Parent (List, Parent (Actual)); 10843 10844 -- OUT present 10845 10846 if Out_Present (Formal) then 10847 10848 -- An IN OUT generic actual must be a name. The instantiation is a 10849 -- renaming declaration. The actual is the name being renamed. We 10850 -- use the actual directly, rather than a copy, because it is not 10851 -- used further in the list of actuals, and because a copy or a use 10852 -- of relocate_node is incorrect if the instance is nested within a 10853 -- generic. In order to simplify ASIS searches, the Generic_Parent 10854 -- field links the declaration to the generic association. 10855 10856 if No (Actual) then 10857 Error_Msg_NE 10858 ("missing actual &", 10859 Instantiation_Node, Gen_Obj); 10860 Error_Msg_NE 10861 ("\in instantiation of & declared#", 10862 Instantiation_Node, Scope (A_Gen_Obj)); 10863 Abandon_Instantiation (Instantiation_Node); 10864 end if; 10865 10866 if Present (Subt_Mark) then 10867 Decl_Node := 10868 Make_Object_Renaming_Declaration (Loc, 10869 Defining_Identifier => New_Copy (Gen_Obj), 10870 Subtype_Mark => New_Copy_Tree (Subt_Mark), 10871 Name => Actual); 10872 10873 else pragma Assert (Present (Acc_Def)); 10874 Decl_Node := 10875 Make_Object_Renaming_Declaration (Loc, 10876 Defining_Identifier => New_Copy (Gen_Obj), 10877 Access_Definition => New_Copy_Tree (Acc_Def), 10878 Name => Actual); 10879 end if; 10880 10881 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc); 10882 10883 -- The analysis of the actual may produce Insert_Action nodes, so 10884 -- the declaration must have a context in which to attach them. 10885 10886 Append (Decl_Node, List); 10887 Analyze (Actual); 10888 10889 -- Return if the analysis of the actual reported some error 10890 10891 if Etype (Actual) = Any_Type then 10892 return List; 10893 end if; 10894 10895 -- This check is performed here because Analyze_Object_Renaming will 10896 -- not check it when Comes_From_Source is False. Note though that the 10897 -- check for the actual being the name of an object will be performed 10898 -- in Analyze_Object_Renaming. 10899 10900 if Is_Object_Reference (Actual) 10901 and then Is_Dependent_Component_Of_Mutable_Object (Actual) 10902 then 10903 Error_Msg_N 10904 ("illegal discriminant-dependent component for in out parameter", 10905 Actual); 10906 end if; 10907 10908 -- The actual has to be resolved in order to check that it is a 10909 -- variable (due to cases such as F (1), where F returns access to 10910 -- an array, and for overloaded prefixes). 10911 10912 Ftyp := Get_Instance_Of (Etype (A_Gen_Obj)); 10913 10914 -- If the type of the formal is not itself a formal, and the current 10915 -- unit is a child unit, the formal type must be declared in a 10916 -- parent, and must be retrieved by visibility. 10917 10918 if Ftyp = Orig_Ftyp 10919 and then Is_Generic_Unit (Scope (Ftyp)) 10920 and then Is_Child_Unit (Scope (A_Gen_Obj)) 10921 then 10922 declare 10923 Temp : constant Node_Id := 10924 New_Copy_Tree (Subtype_Mark (Analyzed_Formal)); 10925 begin 10926 Set_Entity (Temp, Empty); 10927 Find_Type (Temp); 10928 Ftyp := Entity (Temp); 10929 end; 10930 end if; 10931 10932 if Is_Private_Type (Ftyp) 10933 and then not Is_Private_Type (Etype (Actual)) 10934 and then (Base_Type (Full_View (Ftyp)) = Base_Type (Etype (Actual)) 10935 or else Base_Type (Etype (Actual)) = Ftyp) 10936 then 10937 -- If the actual has the type of the full view of the formal, or 10938 -- else a non-private subtype of the formal, then the visibility 10939 -- of the formal type has changed. Add to the actuals a subtype 10940 -- declaration that will force the exchange of views in the body 10941 -- of the instance as well. 10942 10943 Subt_Decl := 10944 Make_Subtype_Declaration (Loc, 10945 Defining_Identifier => Make_Temporary (Loc, 'P'), 10946 Subtype_Indication => New_Occurrence_Of (Ftyp, Loc)); 10947 10948 Prepend (Subt_Decl, List); 10949 10950 Prepend_Elmt (Full_View (Ftyp), Exchanged_Views); 10951 Exchange_Declarations (Ftyp); 10952 end if; 10953 10954 Resolve (Actual, Ftyp); 10955 10956 if not Denotes_Variable (Actual) then 10957 Error_Msg_NE ("actual for& must be a variable", Actual, Gen_Obj); 10958 10959 elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then 10960 10961 -- Ada 2005 (AI-423): For a generic formal object of mode in out, 10962 -- the type of the actual shall resolve to a specific anonymous 10963 -- access type. 10964 10965 if Ada_Version < Ada_2005 10966 or else Ekind (Base_Type (Ftyp)) /= 10967 E_Anonymous_Access_Type 10968 or else Ekind (Base_Type (Etype (Actual))) /= 10969 E_Anonymous_Access_Type 10970 then 10971 Error_Msg_NE 10972 ("type of actual does not match type of&", Actual, Gen_Obj); 10973 end if; 10974 end if; 10975 10976 Note_Possible_Modification (Actual, Sure => True); 10977 10978 -- Check for instantiation of atomic/volatile actual for 10979 -- non-atomic/volatile formal (RM C.6 (12)). 10980 10981 if Is_Atomic_Object (Actual) and then not Is_Atomic (Orig_Ftyp) then 10982 Error_Msg_N 10983 ("cannot instantiate non-atomic formal object " 10984 & "with atomic actual", Actual); 10985 10986 elsif Is_Volatile_Object (Actual) and then not Is_Volatile (Orig_Ftyp) 10987 then 10988 Error_Msg_N 10989 ("cannot instantiate non-volatile formal object " 10990 & "with volatile actual", Actual); 10991 end if; 10992 10993 -- Formal in-parameter 10994 10995 else 10996 -- The instantiation of a generic formal in-parameter is constant 10997 -- declaration. The actual is the expression for that declaration. 10998 -- Its type is a full copy of the type of the formal. This may be 10999 -- an access to subprogram, for which we need to generate entities 11000 -- for the formals in the new signature. 11001 11002 if Present (Actual) then 11003 if Present (Subt_Mark) then 11004 Def := New_Copy_Tree (Subt_Mark); 11005 else pragma Assert (Present (Acc_Def)); 11006 Def := Copy_Access_Def; 11007 end if; 11008 11009 Decl_Node := 11010 Make_Object_Declaration (Loc, 11011 Defining_Identifier => New_Copy (Gen_Obj), 11012 Constant_Present => True, 11013 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 11014 Object_Definition => Def, 11015 Expression => Actual); 11016 11017 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc); 11018 11019 -- A generic formal object of a tagged type is defined to be 11020 -- aliased so the new constant must also be treated as aliased. 11021 11022 if Is_Tagged_Type (Etype (A_Gen_Obj)) then 11023 Set_Aliased_Present (Decl_Node); 11024 end if; 11025 11026 Append (Decl_Node, List); 11027 11028 -- No need to repeat (pre-)analysis of some expression nodes 11029 -- already handled in Preanalyze_Actuals. 11030 11031 if Nkind (Actual) /= N_Allocator then 11032 Analyze (Actual); 11033 11034 -- Return if the analysis of the actual reported some error 11035 11036 if Etype (Actual) = Any_Type then 11037 return List; 11038 end if; 11039 end if; 11040 11041 declare 11042 Formal_Type : constant Entity_Id := Etype (A_Gen_Obj); 11043 Typ : Entity_Id; 11044 11045 begin 11046 Typ := Get_Instance_Of (Formal_Type); 11047 11048 -- If the actual appears in the current or an enclosing scope, 11049 -- use its type directly. This is relevant if it has an actual 11050 -- subtype that is distinct from its nominal one. This cannot 11051 -- be done in general because the type of the actual may 11052 -- depend on other actuals, and only be fully determined when 11053 -- the enclosing instance is analyzed. 11054 11055 if Present (Etype (Actual)) 11056 and then Is_Constr_Subt_For_U_Nominal (Etype (Actual)) 11057 then 11058 Freeze_Before (Instantiation_Node, Etype (Actual)); 11059 else 11060 Freeze_Before (Instantiation_Node, Typ); 11061 end if; 11062 11063 -- If the actual is an aggregate, perform name resolution on 11064 -- its components (the analysis of an aggregate does not do it) 11065 -- to capture local names that may be hidden if the generic is 11066 -- a child unit. 11067 11068 if Nkind (Actual) = N_Aggregate then 11069 Preanalyze_And_Resolve (Actual, Typ); 11070 end if; 11071 11072 if Is_Limited_Type (Typ) 11073 and then not OK_For_Limited_Init (Typ, Actual) 11074 then 11075 Error_Msg_N 11076 ("initialization not allowed for limited types", Actual); 11077 Explain_Limited_Type (Typ, Actual); 11078 end if; 11079 end; 11080 11081 elsif Present (Default_Expression (Formal)) then 11082 11083 -- Use default to construct declaration 11084 11085 if Present (Subt_Mark) then 11086 Def := New_Copy (Subt_Mark); 11087 else pragma Assert (Present (Acc_Def)); 11088 Def := Copy_Access_Def; 11089 end if; 11090 11091 Decl_Node := 11092 Make_Object_Declaration (Sloc (Formal), 11093 Defining_Identifier => New_Copy (Gen_Obj), 11094 Constant_Present => True, 11095 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 11096 Object_Definition => Def, 11097 Expression => New_Copy_Tree 11098 (Default_Expression (Formal))); 11099 11100 Set_Corresponding_Generic_Association 11101 (Decl_Node, Expression (Decl_Node)); 11102 11103 Append (Decl_Node, List); 11104 Set_Analyzed (Expression (Decl_Node), False); 11105 11106 else 11107 Error_Msg_NE ("missing actual&", Instantiation_Node, Gen_Obj); 11108 Error_Msg_NE ("\in instantiation of & declared#", 11109 Instantiation_Node, Scope (A_Gen_Obj)); 11110 11111 if Is_Scalar_Type (Etype (A_Gen_Obj)) then 11112 11113 -- Create dummy constant declaration so that instance can be 11114 -- analyzed, to minimize cascaded visibility errors. 11115 11116 if Present (Subt_Mark) then 11117 Def := Subt_Mark; 11118 else pragma Assert (Present (Acc_Def)); 11119 Def := Acc_Def; 11120 end if; 11121 11122 Decl_Node := 11123 Make_Object_Declaration (Loc, 11124 Defining_Identifier => New_Copy (Gen_Obj), 11125 Constant_Present => True, 11126 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 11127 Object_Definition => New_Copy (Def), 11128 Expression => 11129 Make_Attribute_Reference (Sloc (Gen_Obj), 11130 Attribute_Name => Name_First, 11131 Prefix => New_Copy (Def))); 11132 11133 Append (Decl_Node, List); 11134 11135 else 11136 Abandon_Instantiation (Instantiation_Node); 11137 end if; 11138 end if; 11139 end if; 11140 11141 if Nkind (Actual) in N_Has_Entity then 11142 Actual_Decl := Parent (Entity (Actual)); 11143 end if; 11144 11145 -- Ada 2005 (AI-423): For a formal object declaration with a null 11146 -- exclusion or an access definition that has a null exclusion: If the 11147 -- actual matching the formal object declaration denotes a generic 11148 -- formal object of another generic unit G, and the instantiation 11149 -- containing the actual occurs within the body of G or within the body 11150 -- of a generic unit declared within the declarative region of G, then 11151 -- the declaration of the formal object of G must have a null exclusion. 11152 -- Otherwise, the subtype of the actual matching the formal object 11153 -- declaration shall exclude null. 11154 11155 if Ada_Version >= Ada_2005 11156 and then Present (Actual_Decl) 11157 and then Nkind_In (Actual_Decl, N_Formal_Object_Declaration, 11158 N_Object_Declaration) 11159 and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration 11160 and then not Has_Null_Exclusion (Actual_Decl) 11161 and then Has_Null_Exclusion (Analyzed_Formal) 11162 then 11163 Error_Msg_Sloc := Sloc (Analyzed_Formal); 11164 Error_Msg_N 11165 ("actual must exclude null to match generic formal#", Actual); 11166 end if; 11167 11168 -- An effectively volatile object cannot be used as an actual in a 11169 -- generic instantiation (SPARK RM 7.1.3(7)). The following check is 11170 -- relevant only when SPARK_Mode is on as it is not a standard Ada 11171 -- legality rule, and also verifies that the actual is an object. 11172 11173 if SPARK_Mode = On 11174 and then Present (Actual) 11175 and then Is_Object_Reference (Actual) 11176 and then Is_Effectively_Volatile_Object (Actual) 11177 then 11178 Error_Msg_N 11179 ("volatile object cannot act as actual in generic instantiation", 11180 Actual); 11181 end if; 11182 11183 return List; 11184 end Instantiate_Object; 11185 11186 ------------------------------ 11187 -- Instantiate_Package_Body -- 11188 ------------------------------ 11189 11190 -- WARNING: This routine manages Ghost and SPARK regions. Return statements 11191 -- must be replaced by gotos which jump to the end of the routine in order 11192 -- to restore the Ghost and SPARK modes. 11193 11194 procedure Instantiate_Package_Body 11195 (Body_Info : Pending_Body_Info; 11196 Inlined_Body : Boolean := False; 11197 Body_Optional : Boolean := False) 11198 is 11199 Act_Decl : constant Node_Id := Body_Info.Act_Decl; 11200 Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Decl); 11201 Act_Spec : constant Node_Id := Specification (Act_Decl); 11202 Inst_Node : constant Node_Id := Body_Info.Inst_Node; 11203 Gen_Id : constant Node_Id := Name (Inst_Node); 11204 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 11205 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); 11206 Loc : constant Source_Ptr := Sloc (Inst_Node); 11207 11208 procedure Check_Initialized_Types; 11209 -- In a generic package body, an entity of a generic private type may 11210 -- appear uninitialized. This is suspicious, unless the actual is a 11211 -- fully initialized type. 11212 11213 ----------------------------- 11214 -- Check_Initialized_Types -- 11215 ----------------------------- 11216 11217 procedure Check_Initialized_Types is 11218 Decl : Node_Id; 11219 Formal : Entity_Id; 11220 Actual : Entity_Id; 11221 Uninit_Var : Entity_Id; 11222 11223 begin 11224 Decl := First (Generic_Formal_Declarations (Gen_Decl)); 11225 while Present (Decl) loop 11226 Uninit_Var := Empty; 11227 11228 if Nkind (Decl) = N_Private_Extension_Declaration then 11229 Uninit_Var := Uninitialized_Variable (Decl); 11230 11231 elsif Nkind (Decl) = N_Formal_Type_Declaration 11232 and then Nkind (Formal_Type_Definition (Decl)) = 11233 N_Formal_Private_Type_Definition 11234 then 11235 Uninit_Var := 11236 Uninitialized_Variable (Formal_Type_Definition (Decl)); 11237 end if; 11238 11239 if Present (Uninit_Var) then 11240 Formal := Defining_Identifier (Decl); 11241 Actual := First_Entity (Act_Decl_Id); 11242 11243 -- For each formal there is a subtype declaration that renames 11244 -- the actual and has the same name as the formal. Locate the 11245 -- formal for warning message about uninitialized variables 11246 -- in the generic, for which the actual type should be a fully 11247 -- initialized type. 11248 11249 while Present (Actual) loop 11250 exit when Ekind (Actual) = E_Package 11251 and then Present (Renamed_Object (Actual)); 11252 11253 if Chars (Actual) = Chars (Formal) 11254 and then not Is_Scalar_Type (Actual) 11255 and then not Is_Fully_Initialized_Type (Actual) 11256 and then Warn_On_No_Value_Assigned 11257 then 11258 Error_Msg_Node_2 := Formal; 11259 Error_Msg_NE 11260 ("generic unit has uninitialized variable& of " 11261 & "formal private type &?v?", Actual, Uninit_Var); 11262 Error_Msg_NE 11263 ("actual type for& should be fully initialized type?v?", 11264 Actual, Formal); 11265 exit; 11266 end if; 11267 11268 Next_Entity (Actual); 11269 end loop; 11270 end if; 11271 11272 Next (Decl); 11273 end loop; 11274 end Check_Initialized_Types; 11275 11276 -- Local variables 11277 11278 -- The following constants capture the context prior to instantiating 11279 -- the package body. 11280 11281 Saved_CS : constant Config_Switches_Type := Save_Config_Switches; 11282 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 11283 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 11284 Saved_ISMP : constant Boolean := 11285 Ignore_SPARK_Mode_Pragmas_In_Instance; 11286 Saved_LSST : constant Suppress_Stack_Entry_Ptr := 11287 Local_Suppress_Stack_Top; 11288 Saved_SC : constant Boolean := Style_Check; 11289 Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; 11290 Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; 11291 Saved_SS : constant Suppress_Record := Scope_Suppress; 11292 Saved_Warn : constant Warning_Record := Save_Warnings; 11293 11294 Act_Body : Node_Id; 11295 Act_Body_Id : Entity_Id; 11296 Act_Body_Name : Node_Id; 11297 Gen_Body : Node_Id; 11298 Gen_Body_Id : Node_Id; 11299 Par_Ent : Entity_Id := Empty; 11300 Par_Installed : Boolean := False; 11301 Par_Vis : Boolean := False; 11302 11303 Vis_Prims_List : Elist_Id := No_Elist; 11304 -- List of primitives made temporarily visible in the instantiation 11305 -- to match the visibility of the formal type. 11306 11307 -- Start of processing for Instantiate_Package_Body 11308 11309 begin 11310 Gen_Body_Id := Corresponding_Body (Gen_Decl); 11311 11312 -- The instance body may already have been processed, as the parent of 11313 -- another instance that is inlined (Load_Parent_Of_Generic). 11314 11315 if Present (Corresponding_Body (Instance_Spec (Inst_Node))) then 11316 return; 11317 end if; 11318 11319 -- The package being instantiated may be subject to pragma Ghost. Set 11320 -- the mode now to ensure that any nodes generated during instantiation 11321 -- are properly marked as Ghost. 11322 11323 Set_Ghost_Mode (Act_Decl_Id); 11324 11325 Expander_Mode_Save_And_Set (Body_Info.Expander_Status); 11326 11327 -- Re-establish the state of information on which checks are suppressed. 11328 -- This information was set in Body_Info at the point of instantiation, 11329 -- and now we restore it so that the instance is compiled using the 11330 -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01). 11331 11332 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; 11333 Scope_Suppress := Body_Info.Scope_Suppress; 11334 11335 Restore_Config_Switches (Body_Info.Config_Switches); 11336 Restore_Warnings (Body_Info.Warnings); 11337 11338 if No (Gen_Body_Id) then 11339 11340 -- Do not look for parent of generic body if none is required. 11341 -- This may happen when the routine is called as part of the 11342 -- Pending_Instantiations processing, when nested instances 11343 -- may precede the one generated from the main unit. 11344 11345 if not Unit_Requires_Body (Defining_Entity (Gen_Decl)) 11346 and then Body_Optional 11347 then 11348 goto Leave; 11349 else 11350 Load_Parent_Of_Generic 11351 (Inst_Node, Specification (Gen_Decl), Body_Optional); 11352 Gen_Body_Id := Corresponding_Body (Gen_Decl); 11353 end if; 11354 end if; 11355 11356 -- Establish global variable for sloc adjustment and for error recovery 11357 -- In the case of an instance body for an instantiation with actuals 11358 -- from a limited view, the instance body is placed at the beginning 11359 -- of the enclosing package body: use the body entity as the source 11360 -- location for nodes of the instance body. 11361 11362 if not Is_Empty_Elmt_List (Incomplete_Actuals (Act_Decl_Id)) then 11363 declare 11364 Scop : constant Entity_Id := Scope (Act_Decl_Id); 11365 Body_Id : constant Node_Id := 11366 Corresponding_Body (Unit_Declaration_Node (Scop)); 11367 11368 begin 11369 Instantiation_Node := Body_Id; 11370 end; 11371 else 11372 Instantiation_Node := Inst_Node; 11373 end if; 11374 11375 if Present (Gen_Body_Id) then 11376 Save_Env (Gen_Unit, Act_Decl_Id); 11377 Style_Check := False; 11378 11379 -- If the context of the instance is subject to SPARK_Mode "off", the 11380 -- annotation is missing, or the body is instantiated at a later pass 11381 -- and its spec ignored SPARK_Mode pragma, set the global flag which 11382 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within the 11383 -- instance. 11384 11385 if SPARK_Mode /= On 11386 or else Ignore_SPARK_Mode_Pragmas (Act_Decl_Id) 11387 then 11388 Ignore_SPARK_Mode_Pragmas_In_Instance := True; 11389 end if; 11390 11391 Current_Sem_Unit := Body_Info.Current_Sem_Unit; 11392 Gen_Body := Unit_Declaration_Node (Gen_Body_Id); 11393 11394 Create_Instantiation_Source 11395 (Inst_Node, Gen_Body_Id, S_Adjustment); 11396 11397 Act_Body := 11398 Copy_Generic_Node 11399 (Original_Node (Gen_Body), Empty, Instantiating => True); 11400 11401 -- Create proper (possibly qualified) defining name for the body, to 11402 -- correspond to the one in the spec. 11403 11404 Act_Body_Id := 11405 Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id)); 11406 Set_Comes_From_Source (Act_Body_Id, Comes_From_Source (Act_Decl_Id)); 11407 11408 -- Some attributes of spec entity are not inherited by body entity 11409 11410 Set_Handler_Records (Act_Body_Id, No_List); 11411 11412 if Nkind (Defining_Unit_Name (Act_Spec)) = 11413 N_Defining_Program_Unit_Name 11414 then 11415 Act_Body_Name := 11416 Make_Defining_Program_Unit_Name (Loc, 11417 Name => 11418 New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))), 11419 Defining_Identifier => Act_Body_Id); 11420 else 11421 Act_Body_Name := Act_Body_Id; 11422 end if; 11423 11424 Set_Defining_Unit_Name (Act_Body, Act_Body_Name); 11425 11426 Set_Corresponding_Spec (Act_Body, Act_Decl_Id); 11427 Check_Generic_Actuals (Act_Decl_Id, False); 11428 Check_Initialized_Types; 11429 11430 -- Install primitives hidden at the point of the instantiation but 11431 -- visible when processing the generic formals 11432 11433 declare 11434 E : Entity_Id; 11435 11436 begin 11437 E := First_Entity (Act_Decl_Id); 11438 while Present (E) loop 11439 if Is_Type (E) 11440 and then not Is_Itype (E) 11441 and then Is_Generic_Actual_Type (E) 11442 and then Is_Tagged_Type (E) 11443 then 11444 Install_Hidden_Primitives 11445 (Prims_List => Vis_Prims_List, 11446 Gen_T => Generic_Parent_Type (Parent (E)), 11447 Act_T => E); 11448 end if; 11449 11450 Next_Entity (E); 11451 end loop; 11452 end; 11453 11454 -- If it is a child unit, make the parent instance (which is an 11455 -- instance of the parent of the generic) visible. The parent 11456 -- instance is the prefix of the name of the generic unit. 11457 11458 if Ekind (Scope (Gen_Unit)) = E_Generic_Package 11459 and then Nkind (Gen_Id) = N_Expanded_Name 11460 then 11461 Par_Ent := Entity (Prefix (Gen_Id)); 11462 Par_Vis := Is_Immediately_Visible (Par_Ent); 11463 Install_Parent (Par_Ent, In_Body => True); 11464 Par_Installed := True; 11465 11466 elsif Is_Child_Unit (Gen_Unit) then 11467 Par_Ent := Scope (Gen_Unit); 11468 Par_Vis := Is_Immediately_Visible (Par_Ent); 11469 Install_Parent (Par_Ent, In_Body => True); 11470 Par_Installed := True; 11471 end if; 11472 11473 -- If the instantiation is a library unit, and this is the main unit, 11474 -- then build the resulting compilation unit nodes for the instance. 11475 -- If this is a compilation unit but it is not the main unit, then it 11476 -- is the body of a unit in the context, that is being compiled 11477 -- because it is encloses some inlined unit or another generic unit 11478 -- being instantiated. In that case, this body is not part of the 11479 -- current compilation, and is not attached to the tree, but its 11480 -- parent must be set for analysis. 11481 11482 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 11483 11484 -- Replace instance node with body of instance, and create new 11485 -- node for corresponding instance declaration. 11486 11487 Build_Instance_Compilation_Unit_Nodes 11488 (Inst_Node, Act_Body, Act_Decl); 11489 Analyze (Inst_Node); 11490 11491 if Parent (Inst_Node) = Cunit (Main_Unit) then 11492 11493 -- If the instance is a child unit itself, then set the scope 11494 -- of the expanded body to be the parent of the instantiation 11495 -- (ensuring that the fully qualified name will be generated 11496 -- for the elaboration subprogram). 11497 11498 if Nkind (Defining_Unit_Name (Act_Spec)) = 11499 N_Defining_Program_Unit_Name 11500 then 11501 Set_Scope (Defining_Entity (Inst_Node), Scope (Act_Decl_Id)); 11502 end if; 11503 end if; 11504 11505 -- Case where instantiation is not a library unit 11506 11507 else 11508 -- If this is an early instantiation, i.e. appears textually 11509 -- before the corresponding body and must be elaborated first, 11510 -- indicate that the body instance is to be delayed. 11511 11512 Install_Body (Act_Body, Inst_Node, Gen_Body, Gen_Decl); 11513 11514 -- Now analyze the body. We turn off all checks if this is an 11515 -- internal unit, since there is no reason to have checks on for 11516 -- any predefined run-time library code. All such code is designed 11517 -- to be compiled with checks off. 11518 11519 -- Note that we do NOT apply this criterion to children of GNAT 11520 -- The latter units must suppress checks explicitly if needed. 11521 11522 -- We also do not suppress checks in CodePeer mode where we are 11523 -- interested in finding possible runtime errors. 11524 11525 if not CodePeer_Mode 11526 and then In_Predefined_Unit (Gen_Decl) 11527 then 11528 Analyze (Act_Body, Suppress => All_Checks); 11529 else 11530 Analyze (Act_Body); 11531 end if; 11532 end if; 11533 11534 Inherit_Context (Gen_Body, Inst_Node); 11535 11536 -- Remove the parent instances if they have been placed on the scope 11537 -- stack to compile the body. 11538 11539 if Par_Installed then 11540 Remove_Parent (In_Body => True); 11541 11542 -- Restore the previous visibility of the parent 11543 11544 Set_Is_Immediately_Visible (Par_Ent, Par_Vis); 11545 end if; 11546 11547 Restore_Hidden_Primitives (Vis_Prims_List); 11548 Restore_Private_Views (Act_Decl_Id); 11549 11550 -- Remove the current unit from visibility if this is an instance 11551 -- that is not elaborated on the fly for inlining purposes. 11552 11553 if not Inlined_Body then 11554 Set_Is_Immediately_Visible (Act_Decl_Id, False); 11555 end if; 11556 11557 Restore_Env; 11558 11559 -- If we have no body, and the unit requires a body, then complain. This 11560 -- complaint is suppressed if we have detected other errors (since a 11561 -- common reason for missing the body is that it had errors). 11562 -- In CodePeer mode, a warning has been emitted already, no need for 11563 -- further messages. 11564 11565 elsif Unit_Requires_Body (Gen_Unit) 11566 and then not Body_Optional 11567 then 11568 if CodePeer_Mode then 11569 null; 11570 11571 elsif Serious_Errors_Detected = 0 then 11572 Error_Msg_NE 11573 ("cannot find body of generic package &", Inst_Node, Gen_Unit); 11574 11575 -- Don't attempt to perform any cleanup actions if some other error 11576 -- was already detected, since this can cause blowups. 11577 11578 else 11579 goto Leave; 11580 end if; 11581 11582 -- Case of package that does not need a body 11583 11584 else 11585 -- If the instantiation of the declaration is a library unit, rewrite 11586 -- the original package instantiation as a package declaration in the 11587 -- compilation unit node. 11588 11589 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 11590 Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node)); 11591 Rewrite (Inst_Node, Act_Decl); 11592 11593 -- Generate elaboration entity, in case spec has elaboration code. 11594 -- This cannot be done when the instance is analyzed, because it 11595 -- is not known yet whether the body exists. 11596 11597 Set_Elaboration_Entity_Required (Act_Decl_Id, False); 11598 Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id); 11599 11600 -- If the instantiation is not a library unit, then append the 11601 -- declaration to the list of implicitly generated entities, unless 11602 -- it is already a list member which means that it was already 11603 -- processed 11604 11605 elsif not Is_List_Member (Act_Decl) then 11606 Mark_Rewrite_Insertion (Act_Decl); 11607 Insert_Before (Inst_Node, Act_Decl); 11608 end if; 11609 end if; 11610 11611 <<Leave>> 11612 11613 -- Restore the context that was in effect prior to instantiating the 11614 -- package body. 11615 11616 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 11617 Local_Suppress_Stack_Top := Saved_LSST; 11618 Scope_Suppress := Saved_SS; 11619 Style_Check := Saved_SC; 11620 11621 Expander_Mode_Restore; 11622 Restore_Config_Switches (Saved_CS); 11623 Restore_Ghost_Region (Saved_GM, Saved_IGR); 11624 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 11625 Restore_Warnings (Saved_Warn); 11626 end Instantiate_Package_Body; 11627 11628 --------------------------------- 11629 -- Instantiate_Subprogram_Body -- 11630 --------------------------------- 11631 11632 -- WARNING: This routine manages Ghost and SPARK regions. Return statements 11633 -- must be replaced by gotos which jump to the end of the routine in order 11634 -- to restore the Ghost and SPARK modes. 11635 11636 procedure Instantiate_Subprogram_Body 11637 (Body_Info : Pending_Body_Info; 11638 Body_Optional : Boolean := False) 11639 is 11640 Act_Decl : constant Node_Id := Body_Info.Act_Decl; 11641 Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Decl); 11642 Inst_Node : constant Node_Id := Body_Info.Inst_Node; 11643 Gen_Id : constant Node_Id := Name (Inst_Node); 11644 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 11645 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); 11646 Loc : constant Source_Ptr := Sloc (Inst_Node); 11647 Pack_Id : constant Entity_Id := 11648 Defining_Unit_Name (Parent (Act_Decl)); 11649 11650 -- The following constants capture the context prior to instantiating 11651 -- the subprogram body. 11652 11653 Saved_CS : constant Config_Switches_Type := Save_Config_Switches; 11654 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 11655 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 11656 Saved_ISMP : constant Boolean := 11657 Ignore_SPARK_Mode_Pragmas_In_Instance; 11658 Saved_LSST : constant Suppress_Stack_Entry_Ptr := 11659 Local_Suppress_Stack_Top; 11660 Saved_SC : constant Boolean := Style_Check; 11661 Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; 11662 Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; 11663 Saved_SS : constant Suppress_Record := Scope_Suppress; 11664 Saved_Warn : constant Warning_Record := Save_Warnings; 11665 11666 Act_Body : Node_Id; 11667 Act_Body_Id : Entity_Id; 11668 Gen_Body : Node_Id; 11669 Gen_Body_Id : Node_Id; 11670 Pack_Body : Node_Id; 11671 Par_Ent : Entity_Id := Empty; 11672 Par_Installed : Boolean := False; 11673 Par_Vis : Boolean := False; 11674 Ret_Expr : Node_Id; 11675 11676 begin 11677 Gen_Body_Id := Corresponding_Body (Gen_Decl); 11678 11679 -- Subprogram body may have been created already because of an inline 11680 -- pragma, or because of multiple elaborations of the enclosing package 11681 -- when several instances of the subprogram appear in the main unit. 11682 11683 if Present (Corresponding_Body (Act_Decl)) then 11684 return; 11685 end if; 11686 11687 -- The subprogram being instantiated may be subject to pragma Ghost. Set 11688 -- the mode now to ensure that any nodes generated during instantiation 11689 -- are properly marked as Ghost. 11690 11691 Set_Ghost_Mode (Act_Decl_Id); 11692 11693 Expander_Mode_Save_And_Set (Body_Info.Expander_Status); 11694 11695 -- Re-establish the state of information on which checks are suppressed. 11696 -- This information was set in Body_Info at the point of instantiation, 11697 -- and now we restore it so that the instance is compiled using the 11698 -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01). 11699 11700 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; 11701 Scope_Suppress := Body_Info.Scope_Suppress; 11702 11703 Restore_Config_Switches (Body_Info.Config_Switches); 11704 Restore_Warnings (Body_Info.Warnings); 11705 11706 if No (Gen_Body_Id) then 11707 11708 -- For imported generic subprogram, no body to compile, complete 11709 -- the spec entity appropriately. 11710 11711 if Is_Imported (Gen_Unit) then 11712 Set_Is_Imported (Act_Decl_Id); 11713 Set_First_Rep_Item (Act_Decl_Id, First_Rep_Item (Gen_Unit)); 11714 Set_Interface_Name (Act_Decl_Id, Interface_Name (Gen_Unit)); 11715 Set_Convention (Act_Decl_Id, Convention (Gen_Unit)); 11716 Set_Has_Completion (Act_Decl_Id); 11717 goto Leave; 11718 11719 -- For other cases, compile the body 11720 11721 else 11722 Load_Parent_Of_Generic 11723 (Inst_Node, Specification (Gen_Decl), Body_Optional); 11724 Gen_Body_Id := Corresponding_Body (Gen_Decl); 11725 end if; 11726 end if; 11727 11728 Instantiation_Node := Inst_Node; 11729 11730 if Present (Gen_Body_Id) then 11731 Gen_Body := Unit_Declaration_Node (Gen_Body_Id); 11732 11733 if Nkind (Gen_Body) = N_Subprogram_Body_Stub then 11734 11735 -- Either body is not present, or context is non-expanding, as 11736 -- when compiling a subunit. Mark the instance as completed, and 11737 -- diagnose a missing body when needed. 11738 11739 if Expander_Active 11740 and then Operating_Mode = Generate_Code 11741 then 11742 Error_Msg_N ("missing proper body for instantiation", Gen_Body); 11743 end if; 11744 11745 Set_Has_Completion (Act_Decl_Id); 11746 goto Leave; 11747 end if; 11748 11749 Save_Env (Gen_Unit, Act_Decl_Id); 11750 Style_Check := False; 11751 11752 -- If the context of the instance is subject to SPARK_Mode "off", the 11753 -- annotation is missing, or the body is instantiated at a later pass 11754 -- and its spec ignored SPARK_Mode pragma, set the global flag which 11755 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within the 11756 -- instance. 11757 11758 if SPARK_Mode /= On 11759 or else Ignore_SPARK_Mode_Pragmas (Act_Decl_Id) 11760 then 11761 Ignore_SPARK_Mode_Pragmas_In_Instance := True; 11762 end if; 11763 11764 -- If the context of an instance is not subject to SPARK_Mode "off", 11765 -- and the generic body is subject to an explicit SPARK_Mode pragma, 11766 -- the latter should be the one applicable to the instance. 11767 11768 if not Ignore_SPARK_Mode_Pragmas_In_Instance 11769 and then SPARK_Mode /= Off 11770 and then Present (SPARK_Pragma (Gen_Body_Id)) 11771 then 11772 Set_SPARK_Mode (Gen_Body_Id); 11773 end if; 11774 11775 Current_Sem_Unit := Body_Info.Current_Sem_Unit; 11776 Create_Instantiation_Source 11777 (Inst_Node, 11778 Gen_Body_Id, 11779 S_Adjustment); 11780 11781 Act_Body := 11782 Copy_Generic_Node 11783 (Original_Node (Gen_Body), Empty, Instantiating => True); 11784 11785 -- Create proper defining name for the body, to correspond to the one 11786 -- in the spec. 11787 11788 Act_Body_Id := 11789 Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id)); 11790 11791 Set_Comes_From_Source (Act_Body_Id, Comes_From_Source (Act_Decl_Id)); 11792 Set_Defining_Unit_Name (Specification (Act_Body), Act_Body_Id); 11793 11794 Set_Corresponding_Spec (Act_Body, Act_Decl_Id); 11795 Set_Has_Completion (Act_Decl_Id); 11796 Check_Generic_Actuals (Pack_Id, False); 11797 11798 -- Generate a reference to link the visible subprogram instance to 11799 -- the generic body, which for navigation purposes is the only 11800 -- available source for the instance. 11801 11802 Generate_Reference 11803 (Related_Instance (Pack_Id), 11804 Gen_Body_Id, 'b', Set_Ref => False, Force => True); 11805 11806 -- If it is a child unit, make the parent instance (which is an 11807 -- instance of the parent of the generic) visible. The parent 11808 -- instance is the prefix of the name of the generic unit. 11809 11810 if Ekind (Scope (Gen_Unit)) = E_Generic_Package 11811 and then Nkind (Gen_Id) = N_Expanded_Name 11812 then 11813 Par_Ent := Entity (Prefix (Gen_Id)); 11814 Par_Vis := Is_Immediately_Visible (Par_Ent); 11815 Install_Parent (Par_Ent, In_Body => True); 11816 Par_Installed := True; 11817 11818 elsif Is_Child_Unit (Gen_Unit) then 11819 Par_Ent := Scope (Gen_Unit); 11820 Par_Vis := Is_Immediately_Visible (Par_Ent); 11821 Install_Parent (Par_Ent, In_Body => True); 11822 Par_Installed := True; 11823 end if; 11824 11825 -- Subprogram body is placed in the body of wrapper package, 11826 -- whose spec contains the subprogram declaration as well as 11827 -- the renaming declarations for the generic parameters. 11828 11829 Pack_Body := 11830 Make_Package_Body (Loc, 11831 Defining_Unit_Name => New_Copy (Pack_Id), 11832 Declarations => New_List (Act_Body)); 11833 11834 Set_Corresponding_Spec (Pack_Body, Pack_Id); 11835 11836 -- If the instantiation is a library unit, then build resulting 11837 -- compilation unit nodes for the instance. The declaration of 11838 -- the enclosing package is the grandparent of the subprogram 11839 -- declaration. First replace the instantiation node as the unit 11840 -- of the corresponding compilation. 11841 11842 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 11843 if Parent (Inst_Node) = Cunit (Main_Unit) then 11844 Set_Unit (Parent (Inst_Node), Inst_Node); 11845 Build_Instance_Compilation_Unit_Nodes 11846 (Inst_Node, Pack_Body, Parent (Parent (Act_Decl))); 11847 Analyze (Inst_Node); 11848 else 11849 Set_Parent (Pack_Body, Parent (Inst_Node)); 11850 Analyze (Pack_Body); 11851 end if; 11852 11853 else 11854 Insert_Before (Inst_Node, Pack_Body); 11855 Mark_Rewrite_Insertion (Pack_Body); 11856 Analyze (Pack_Body); 11857 11858 if Expander_Active then 11859 Freeze_Subprogram_Body (Inst_Node, Gen_Body, Pack_Id); 11860 end if; 11861 end if; 11862 11863 Inherit_Context (Gen_Body, Inst_Node); 11864 11865 Restore_Private_Views (Pack_Id, False); 11866 11867 if Par_Installed then 11868 Remove_Parent (In_Body => True); 11869 11870 -- Restore the previous visibility of the parent 11871 11872 Set_Is_Immediately_Visible (Par_Ent, Par_Vis); 11873 end if; 11874 11875 Restore_Env; 11876 11877 -- Body not found. Error was emitted already. If there were no previous 11878 -- errors, this may be an instance whose scope is a premature instance. 11879 -- In that case we must insure that the (legal) program does raise 11880 -- program error if executed. We generate a subprogram body for this 11881 -- purpose. See DEC ac30vso. 11882 11883 -- Should not reference proprietary DEC tests in comments ??? 11884 11885 elsif Serious_Errors_Detected = 0 11886 and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit 11887 then 11888 if Body_Optional then 11889 goto Leave; 11890 11891 elsif Ekind (Act_Decl_Id) = E_Procedure then 11892 Act_Body := 11893 Make_Subprogram_Body (Loc, 11894 Specification => 11895 Make_Procedure_Specification (Loc, 11896 Defining_Unit_Name => 11897 Make_Defining_Identifier (Loc, Chars (Act_Decl_Id)), 11898 Parameter_Specifications => 11899 New_Copy_List 11900 (Parameter_Specifications (Parent (Act_Decl_Id)))), 11901 11902 Declarations => Empty_List, 11903 Handled_Statement_Sequence => 11904 Make_Handled_Sequence_Of_Statements (Loc, 11905 Statements => New_List ( 11906 Make_Raise_Program_Error (Loc, 11907 Reason => PE_Access_Before_Elaboration)))); 11908 11909 else 11910 Ret_Expr := 11911 Make_Raise_Program_Error (Loc, 11912 Reason => PE_Access_Before_Elaboration); 11913 11914 Set_Etype (Ret_Expr, (Etype (Act_Decl_Id))); 11915 Set_Analyzed (Ret_Expr); 11916 11917 Act_Body := 11918 Make_Subprogram_Body (Loc, 11919 Specification => 11920 Make_Function_Specification (Loc, 11921 Defining_Unit_Name => 11922 Make_Defining_Identifier (Loc, Chars (Act_Decl_Id)), 11923 Parameter_Specifications => 11924 New_Copy_List 11925 (Parameter_Specifications (Parent (Act_Decl_Id))), 11926 Result_Definition => 11927 New_Occurrence_Of (Etype (Act_Decl_Id), Loc)), 11928 11929 Declarations => Empty_List, 11930 Handled_Statement_Sequence => 11931 Make_Handled_Sequence_Of_Statements (Loc, 11932 Statements => New_List ( 11933 Make_Simple_Return_Statement (Loc, Ret_Expr)))); 11934 end if; 11935 11936 Pack_Body := 11937 Make_Package_Body (Loc, 11938 Defining_Unit_Name => New_Copy (Pack_Id), 11939 Declarations => New_List (Act_Body)); 11940 11941 Insert_After (Inst_Node, Pack_Body); 11942 Set_Corresponding_Spec (Pack_Body, Pack_Id); 11943 Analyze (Pack_Body); 11944 end if; 11945 11946 <<Leave>> 11947 11948 -- Restore the context that was in effect prior to instantiating the 11949 -- subprogram body. 11950 11951 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 11952 Local_Suppress_Stack_Top := Saved_LSST; 11953 Scope_Suppress := Saved_SS; 11954 Style_Check := Saved_SC; 11955 11956 Expander_Mode_Restore; 11957 Restore_Config_Switches (Saved_CS); 11958 Restore_Ghost_Region (Saved_GM, Saved_IGR); 11959 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 11960 Restore_Warnings (Saved_Warn); 11961 end Instantiate_Subprogram_Body; 11962 11963 ---------------------- 11964 -- Instantiate_Type -- 11965 ---------------------- 11966 11967 function Instantiate_Type 11968 (Formal : Node_Id; 11969 Actual : Node_Id; 11970 Analyzed_Formal : Node_Id; 11971 Actual_Decls : List_Id) return List_Id 11972 is 11973 A_Gen_T : constant Entity_Id := 11974 Defining_Identifier (Analyzed_Formal); 11975 Def : constant Node_Id := Formal_Type_Definition (Formal); 11976 Gen_T : constant Entity_Id := Defining_Identifier (Formal); 11977 Act_T : Entity_Id; 11978 Ancestor : Entity_Id := Empty; 11979 Decl_Node : Node_Id; 11980 Decl_Nodes : List_Id; 11981 Loc : Source_Ptr; 11982 Subt : Entity_Id; 11983 11984 procedure Diagnose_Predicated_Actual; 11985 -- There are a number of constructs in which a discrete type with 11986 -- predicates is illegal, e.g. as an index in an array type declaration. 11987 -- If a generic type is used is such a construct in a generic package 11988 -- declaration, it carries the flag No_Predicate_On_Actual. it is part 11989 -- of the generic contract that the actual cannot have predicates. 11990 11991 procedure Validate_Array_Type_Instance; 11992 procedure Validate_Access_Subprogram_Instance; 11993 procedure Validate_Access_Type_Instance; 11994 procedure Validate_Derived_Type_Instance; 11995 procedure Validate_Derived_Interface_Type_Instance; 11996 procedure Validate_Discriminated_Formal_Type; 11997 procedure Validate_Interface_Type_Instance; 11998 procedure Validate_Private_Type_Instance; 11999 procedure Validate_Incomplete_Type_Instance; 12000 -- These procedures perform validation tests for the named case. 12001 -- Validate_Discriminated_Formal_Type is shared by formal private 12002 -- types and Ada 2012 formal incomplete types. 12003 12004 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean; 12005 -- Check that base types are the same and that the subtypes match 12006 -- statically. Used in several of the above. 12007 12008 --------------------------------- 12009 -- Diagnose_Predicated_Actual -- 12010 --------------------------------- 12011 12012 procedure Diagnose_Predicated_Actual is 12013 begin 12014 if No_Predicate_On_Actual (A_Gen_T) 12015 and then Has_Predicates (Act_T) 12016 then 12017 Error_Msg_NE 12018 ("actual for& cannot be a type with predicate", 12019 Instantiation_Node, A_Gen_T); 12020 12021 elsif No_Dynamic_Predicate_On_Actual (A_Gen_T) 12022 and then Has_Predicates (Act_T) 12023 and then not Has_Static_Predicate_Aspect (Act_T) 12024 then 12025 Error_Msg_NE 12026 ("actual for& cannot be a type with a dynamic predicate", 12027 Instantiation_Node, A_Gen_T); 12028 end if; 12029 end Diagnose_Predicated_Actual; 12030 12031 -------------------- 12032 -- Subtypes_Match -- 12033 -------------------- 12034 12035 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean is 12036 T : constant Entity_Id := Get_Instance_Of (Gen_T); 12037 12038 begin 12039 -- Some detailed comments would be useful here ??? 12040 12041 return ((Base_Type (T) = Act_T 12042 or else Base_Type (T) = Base_Type (Act_T)) 12043 and then Subtypes_Statically_Match (T, Act_T)) 12044 12045 or else (Is_Class_Wide_Type (Gen_T) 12046 and then Is_Class_Wide_Type (Act_T) 12047 and then Subtypes_Match 12048 (Get_Instance_Of (Root_Type (Gen_T)), 12049 Root_Type (Act_T))) 12050 12051 or else 12052 (Ekind_In (Gen_T, E_Anonymous_Access_Subprogram_Type, 12053 E_Anonymous_Access_Type) 12054 and then Ekind (Act_T) = Ekind (Gen_T) 12055 and then Subtypes_Statically_Match 12056 (Designated_Type (Gen_T), Designated_Type (Act_T))); 12057 end Subtypes_Match; 12058 12059 ----------------------------------------- 12060 -- Validate_Access_Subprogram_Instance -- 12061 ----------------------------------------- 12062 12063 procedure Validate_Access_Subprogram_Instance is 12064 begin 12065 if not Is_Access_Type (Act_T) 12066 or else Ekind (Designated_Type (Act_T)) /= E_Subprogram_Type 12067 then 12068 Error_Msg_NE 12069 ("expect access type in instantiation of &", Actual, Gen_T); 12070 Abandon_Instantiation (Actual); 12071 end if; 12072 12073 -- According to AI05-288, actuals for access_to_subprograms must be 12074 -- subtype conformant with the generic formal. Previous to AI05-288 12075 -- only mode conformance was required. 12076 12077 -- This is a binding interpretation that applies to previous versions 12078 -- of the language, no need to maintain previous weaker checks. 12079 12080 Check_Subtype_Conformant 12081 (Designated_Type (Act_T), 12082 Designated_Type (A_Gen_T), 12083 Actual, 12084 Get_Inst => True); 12085 12086 if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then 12087 if Ekind (A_Gen_T) = E_Access_Subprogram_Type then 12088 Error_Msg_NE 12089 ("protected access type not allowed for formal &", 12090 Actual, Gen_T); 12091 end if; 12092 12093 elsif Ekind (A_Gen_T) = E_Access_Protected_Subprogram_Type then 12094 Error_Msg_NE 12095 ("expect protected access type for formal &", 12096 Actual, Gen_T); 12097 end if; 12098 12099 -- If the formal has a specified convention (which in most cases 12100 -- will be StdCall) verify that the actual has the same convention. 12101 12102 if Has_Convention_Pragma (A_Gen_T) 12103 and then Convention (A_Gen_T) /= Convention (Act_T) 12104 then 12105 Error_Msg_Name_1 := Get_Convention_Name (Convention (A_Gen_T)); 12106 Error_Msg_NE 12107 ("actual for formal & must have convention %", Actual, Gen_T); 12108 end if; 12109 end Validate_Access_Subprogram_Instance; 12110 12111 ----------------------------------- 12112 -- Validate_Access_Type_Instance -- 12113 ----------------------------------- 12114 12115 procedure Validate_Access_Type_Instance is 12116 Desig_Type : constant Entity_Id := 12117 Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T); 12118 Desig_Act : Entity_Id; 12119 12120 begin 12121 if not Is_Access_Type (Act_T) then 12122 Error_Msg_NE 12123 ("expect access type in instantiation of &", Actual, Gen_T); 12124 Abandon_Instantiation (Actual); 12125 end if; 12126 12127 if Is_Access_Constant (A_Gen_T) then 12128 if not Is_Access_Constant (Act_T) then 12129 Error_Msg_N 12130 ("actual type must be access-to-constant type", Actual); 12131 Abandon_Instantiation (Actual); 12132 end if; 12133 else 12134 if Is_Access_Constant (Act_T) then 12135 Error_Msg_N 12136 ("actual type must be access-to-variable type", Actual); 12137 Abandon_Instantiation (Actual); 12138 12139 elsif Ekind (A_Gen_T) = E_General_Access_Type 12140 and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type 12141 then 12142 Error_Msg_N -- CODEFIX 12143 ("actual must be general access type!", Actual); 12144 Error_Msg_NE -- CODEFIX 12145 ("add ALL to }!", Actual, Act_T); 12146 Abandon_Instantiation (Actual); 12147 end if; 12148 end if; 12149 12150 -- The designated subtypes, that is to say the subtypes introduced 12151 -- by an access type declaration (and not by a subtype declaration) 12152 -- must match. 12153 12154 Desig_Act := Designated_Type (Base_Type (Act_T)); 12155 12156 -- The designated type may have been introduced through a limited_ 12157 -- with clause, in which case retrieve the non-limited view. This 12158 -- applies to incomplete types as well as to class-wide types. 12159 12160 if From_Limited_With (Desig_Act) then 12161 Desig_Act := Available_View (Desig_Act); 12162 end if; 12163 12164 if not Subtypes_Match (Desig_Type, Desig_Act) then 12165 Error_Msg_NE 12166 ("designated type of actual does not match that of formal &", 12167 Actual, Gen_T); 12168 12169 if not Predicates_Match (Desig_Type, Desig_Act) then 12170 Error_Msg_N ("\predicates do not match", Actual); 12171 end if; 12172 12173 Abandon_Instantiation (Actual); 12174 12175 elsif Is_Access_Type (Designated_Type (Act_T)) 12176 and then Is_Constrained (Designated_Type (Designated_Type (Act_T))) 12177 /= 12178 Is_Constrained (Designated_Type (Desig_Type)) 12179 then 12180 Error_Msg_NE 12181 ("designated type of actual does not match that of formal &", 12182 Actual, Gen_T); 12183 12184 if not Predicates_Match (Desig_Type, Desig_Act) then 12185 Error_Msg_N ("\predicates do not match", Actual); 12186 end if; 12187 12188 Abandon_Instantiation (Actual); 12189 end if; 12190 12191 -- Ada 2005: null-exclusion indicators of the two types must agree 12192 12193 if Can_Never_Be_Null (A_Gen_T) /= Can_Never_Be_Null (Act_T) then 12194 Error_Msg_NE 12195 ("non null exclusion of actual and formal & do not match", 12196 Actual, Gen_T); 12197 end if; 12198 end Validate_Access_Type_Instance; 12199 12200 ---------------------------------- 12201 -- Validate_Array_Type_Instance -- 12202 ---------------------------------- 12203 12204 procedure Validate_Array_Type_Instance is 12205 I1 : Node_Id; 12206 I2 : Node_Id; 12207 T2 : Entity_Id; 12208 12209 function Formal_Dimensions return Nat; 12210 -- Count number of dimensions in array type formal 12211 12212 ----------------------- 12213 -- Formal_Dimensions -- 12214 ----------------------- 12215 12216 function Formal_Dimensions return Nat is 12217 Num : Nat := 0; 12218 Index : Node_Id; 12219 12220 begin 12221 if Nkind (Def) = N_Constrained_Array_Definition then 12222 Index := First (Discrete_Subtype_Definitions (Def)); 12223 else 12224 Index := First (Subtype_Marks (Def)); 12225 end if; 12226 12227 while Present (Index) loop 12228 Num := Num + 1; 12229 Next_Index (Index); 12230 end loop; 12231 12232 return Num; 12233 end Formal_Dimensions; 12234 12235 -- Start of processing for Validate_Array_Type_Instance 12236 12237 begin 12238 if not Is_Array_Type (Act_T) then 12239 Error_Msg_NE 12240 ("expect array type in instantiation of &", Actual, Gen_T); 12241 Abandon_Instantiation (Actual); 12242 12243 elsif Nkind (Def) = N_Constrained_Array_Definition then 12244 if not (Is_Constrained (Act_T)) then 12245 Error_Msg_NE 12246 ("expect constrained array in instantiation of &", 12247 Actual, Gen_T); 12248 Abandon_Instantiation (Actual); 12249 end if; 12250 12251 else 12252 if Is_Constrained (Act_T) then 12253 Error_Msg_NE 12254 ("expect unconstrained array in instantiation of &", 12255 Actual, Gen_T); 12256 Abandon_Instantiation (Actual); 12257 end if; 12258 end if; 12259 12260 if Formal_Dimensions /= Number_Dimensions (Act_T) then 12261 Error_Msg_NE 12262 ("dimensions of actual do not match formal &", Actual, Gen_T); 12263 Abandon_Instantiation (Actual); 12264 end if; 12265 12266 I1 := First_Index (A_Gen_T); 12267 I2 := First_Index (Act_T); 12268 for J in 1 .. Formal_Dimensions loop 12269 12270 -- If the indexes of the actual were given by a subtype_mark, 12271 -- the index was transformed into a range attribute. Retrieve 12272 -- the original type mark for checking. 12273 12274 if Is_Entity_Name (Original_Node (I2)) then 12275 T2 := Entity (Original_Node (I2)); 12276 else 12277 T2 := Etype (I2); 12278 end if; 12279 12280 if not Subtypes_Match 12281 (Find_Actual_Type (Etype (I1), A_Gen_T), T2) 12282 then 12283 Error_Msg_NE 12284 ("index types of actual do not match those of formal &", 12285 Actual, Gen_T); 12286 Abandon_Instantiation (Actual); 12287 end if; 12288 12289 Next_Index (I1); 12290 Next_Index (I2); 12291 end loop; 12292 12293 -- Check matching subtypes. Note that there are complex visibility 12294 -- issues when the generic is a child unit and some aspect of the 12295 -- generic type is declared in a parent unit of the generic. We do 12296 -- the test to handle this special case only after a direct check 12297 -- for static matching has failed. The case where both the component 12298 -- type and the array type are separate formals, and the component 12299 -- type is a private view may also require special checking in 12300 -- Subtypes_Match. Finally, we assume that a child instance where 12301 -- the component type comes from a formal of a parent instance is 12302 -- correct because the generic was correct. A more precise check 12303 -- seems too complex to install??? 12304 12305 if Subtypes_Match 12306 (Component_Type (A_Gen_T), Component_Type (Act_T)) 12307 or else 12308 Subtypes_Match 12309 (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T), 12310 Component_Type (Act_T)) 12311 or else 12312 (not Inside_A_Generic 12313 and then Is_Child_Unit (Scope (Component_Type (A_Gen_T)))) 12314 then 12315 null; 12316 else 12317 Error_Msg_NE 12318 ("component subtype of actual does not match that of formal &", 12319 Actual, Gen_T); 12320 Abandon_Instantiation (Actual); 12321 end if; 12322 12323 if Has_Aliased_Components (A_Gen_T) 12324 and then not Has_Aliased_Components (Act_T) 12325 then 12326 Error_Msg_NE 12327 ("actual must have aliased components to match formal type &", 12328 Actual, Gen_T); 12329 end if; 12330 end Validate_Array_Type_Instance; 12331 12332 ----------------------------------------------- 12333 -- Validate_Derived_Interface_Type_Instance -- 12334 ----------------------------------------------- 12335 12336 procedure Validate_Derived_Interface_Type_Instance is 12337 Par : constant Entity_Id := Entity (Subtype_Indication (Def)); 12338 Elmt : Elmt_Id; 12339 12340 begin 12341 -- First apply interface instance checks 12342 12343 Validate_Interface_Type_Instance; 12344 12345 -- Verify that immediate parent interface is an ancestor of 12346 -- the actual. 12347 12348 if Present (Par) 12349 and then not Interface_Present_In_Ancestor (Act_T, Par) 12350 then 12351 Error_Msg_NE 12352 ("interface actual must include progenitor&", Actual, Par); 12353 end if; 12354 12355 -- Now verify that the actual includes all other ancestors of 12356 -- the formal. 12357 12358 Elmt := First_Elmt (Interfaces (A_Gen_T)); 12359 while Present (Elmt) loop 12360 if not Interface_Present_In_Ancestor 12361 (Act_T, Get_Instance_Of (Node (Elmt))) 12362 then 12363 Error_Msg_NE 12364 ("interface actual must include progenitor&", 12365 Actual, Node (Elmt)); 12366 end if; 12367 12368 Next_Elmt (Elmt); 12369 end loop; 12370 end Validate_Derived_Interface_Type_Instance; 12371 12372 ------------------------------------ 12373 -- Validate_Derived_Type_Instance -- 12374 ------------------------------------ 12375 12376 procedure Validate_Derived_Type_Instance is 12377 Actual_Discr : Entity_Id; 12378 Ancestor_Discr : Entity_Id; 12379 12380 begin 12381 -- Verify that the actual includes the progenitors of the formal, 12382 -- if any. The formal may depend on previous formals and their 12383 -- instance, so we must examine instance of interfaces if present. 12384 -- The actual may be an extension of an interface, in which case 12385 -- it does not appear in the interface list, so this must be 12386 -- checked separately. 12387 12388 if Present (Interface_List (Def)) then 12389 if not Has_Interfaces (Act_T) then 12390 Error_Msg_NE 12391 ("actual must implement all interfaces of formal&", 12392 Actual, A_Gen_T); 12393 12394 else 12395 declare 12396 Act_Iface_List : Elist_Id; 12397 Iface : Node_Id; 12398 Iface_Ent : Entity_Id; 12399 12400 function Instance_Exists (I : Entity_Id) return Boolean; 12401 -- If the interface entity is declared in a generic unit, 12402 -- this can only be legal if we are within an instantiation 12403 -- of a child of that generic. There is currently no 12404 -- mechanism to relate an interface declared within a 12405 -- generic to the corresponding interface in an instance, 12406 -- so we traverse the list of interfaces of the actual, 12407 -- looking for a name match. 12408 12409 --------------------- 12410 -- Instance_Exists -- 12411 --------------------- 12412 12413 function Instance_Exists (I : Entity_Id) return Boolean is 12414 Iface_Elmt : Elmt_Id; 12415 12416 begin 12417 Iface_Elmt := First_Elmt (Act_Iface_List); 12418 while Present (Iface_Elmt) loop 12419 if Is_Generic_Instance (Scope (Node (Iface_Elmt))) 12420 and then Chars (Node (Iface_Elmt)) = Chars (I) 12421 then 12422 return True; 12423 end if; 12424 12425 Next_Elmt (Iface_Elmt); 12426 end loop; 12427 12428 return False; 12429 end Instance_Exists; 12430 12431 begin 12432 Iface := First (Abstract_Interface_List (A_Gen_T)); 12433 Collect_Interfaces (Act_T, Act_Iface_List); 12434 12435 while Present (Iface) loop 12436 Iface_Ent := Get_Instance_Of (Entity (Iface)); 12437 12438 if Is_Ancestor (Iface_Ent, Act_T) 12439 or else Is_Progenitor (Iface_Ent, Act_T) 12440 then 12441 null; 12442 12443 elsif Ekind (Scope (Iface_Ent)) = E_Generic_Package 12444 and then Instance_Exists (Iface_Ent) 12445 then 12446 null; 12447 12448 else 12449 Error_Msg_Name_1 := Chars (Act_T); 12450 Error_Msg_NE 12451 ("Actual% must implement interface&", 12452 Actual, Etype (Iface)); 12453 end if; 12454 12455 Next (Iface); 12456 end loop; 12457 end; 12458 end if; 12459 end if; 12460 12461 -- If the parent type in the generic declaration is itself a previous 12462 -- formal type, then it is local to the generic and absent from the 12463 -- analyzed generic definition. In that case the ancestor is the 12464 -- instance of the formal (which must have been instantiated 12465 -- previously), unless the ancestor is itself a formal derived type. 12466 -- In this latter case (which is the subject of Corrigendum 8652/0038 12467 -- (AI-202) the ancestor of the formals is the ancestor of its 12468 -- parent. Otherwise, the analyzed generic carries the parent type. 12469 -- If the parent type is defined in a previous formal package, then 12470 -- the scope of that formal package is that of the generic type 12471 -- itself, and it has already been mapped into the corresponding type 12472 -- in the actual package. 12473 12474 -- Common case: parent type defined outside of the generic 12475 12476 if Is_Entity_Name (Subtype_Mark (Def)) 12477 and then Present (Entity (Subtype_Mark (Def))) 12478 then 12479 Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def))); 12480 12481 -- Check whether parent is defined in a previous formal package 12482 12483 elsif 12484 Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T) 12485 then 12486 Ancestor := 12487 Get_Instance_Of (Base_Type (Etype (A_Gen_T))); 12488 12489 -- The type may be a local derivation, or a type extension of a 12490 -- previous formal, or of a formal of a parent package. 12491 12492 elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T)) 12493 or else 12494 Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private 12495 then 12496 -- Check whether the parent is another derived formal type in the 12497 -- same generic unit. 12498 12499 if Etype (A_Gen_T) /= A_Gen_T 12500 and then Is_Generic_Type (Etype (A_Gen_T)) 12501 and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T) 12502 and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T) 12503 then 12504 -- Locate ancestor of parent from the subtype declaration 12505 -- created for the actual. 12506 12507 declare 12508 Decl : Node_Id; 12509 12510 begin 12511 Decl := First (Actual_Decls); 12512 while Present (Decl) loop 12513 if Nkind (Decl) = N_Subtype_Declaration 12514 and then Chars (Defining_Identifier (Decl)) = 12515 Chars (Etype (A_Gen_T)) 12516 then 12517 Ancestor := Generic_Parent_Type (Decl); 12518 exit; 12519 else 12520 Next (Decl); 12521 end if; 12522 end loop; 12523 end; 12524 12525 pragma Assert (Present (Ancestor)); 12526 12527 -- The ancestor itself may be a previous formal that has been 12528 -- instantiated. 12529 12530 Ancestor := Get_Instance_Of (Ancestor); 12531 12532 else 12533 Ancestor := 12534 Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T))); 12535 end if; 12536 12537 -- Check whether parent is a previous formal of the current generic 12538 12539 elsif Is_Derived_Type (A_Gen_T) 12540 and then Is_Generic_Type (Etype (A_Gen_T)) 12541 and then Scope (A_Gen_T) = Scope (Etype (A_Gen_T)) 12542 then 12543 Ancestor := Get_Instance_Of (First_Subtype (Etype (A_Gen_T))); 12544 12545 -- An unusual case: the actual is a type declared in a parent unit, 12546 -- but is not a formal type so there is no instance_of for it. 12547 -- Retrieve it by analyzing the record extension. 12548 12549 elsif Is_Child_Unit (Scope (A_Gen_T)) 12550 and then In_Open_Scopes (Scope (Act_T)) 12551 and then Is_Generic_Instance (Scope (Act_T)) 12552 then 12553 Analyze (Subtype_Mark (Def)); 12554 Ancestor := Entity (Subtype_Mark (Def)); 12555 12556 else 12557 Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T))); 12558 end if; 12559 12560 -- If the formal derived type has pragma Preelaborable_Initialization 12561 -- then the actual type must have preelaborable initialization. 12562 12563 if Known_To_Have_Preelab_Init (A_Gen_T) 12564 and then not Has_Preelaborable_Initialization (Act_T) 12565 then 12566 Error_Msg_NE 12567 ("actual for & must have preelaborable initialization", 12568 Actual, Gen_T); 12569 end if; 12570 12571 -- Ada 2005 (AI-251) 12572 12573 if Ada_Version >= Ada_2005 and then Is_Interface (Ancestor) then 12574 if not Interface_Present_In_Ancestor (Act_T, Ancestor) then 12575 Error_Msg_NE 12576 ("(Ada 2005) expected type implementing & in instantiation", 12577 Actual, Ancestor); 12578 end if; 12579 12580 -- Finally verify that the (instance of) the ancestor is an ancestor 12581 -- of the actual. 12582 12583 elsif not Is_Ancestor (Base_Type (Ancestor), Act_T) then 12584 Error_Msg_NE 12585 ("expect type derived from & in instantiation", 12586 Actual, First_Subtype (Ancestor)); 12587 Abandon_Instantiation (Actual); 12588 end if; 12589 12590 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note 12591 -- that the formal type declaration has been rewritten as a private 12592 -- extension. 12593 12594 if Ada_Version >= Ada_2005 12595 and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration 12596 and then Synchronized_Present (Parent (A_Gen_T)) 12597 then 12598 -- The actual must be a synchronized tagged type 12599 12600 if not Is_Tagged_Type (Act_T) then 12601 Error_Msg_N 12602 ("actual of synchronized type must be tagged", Actual); 12603 Abandon_Instantiation (Actual); 12604 12605 elsif Nkind (Parent (Act_T)) = N_Full_Type_Declaration 12606 and then Nkind (Type_Definition (Parent (Act_T))) = 12607 N_Derived_Type_Definition 12608 and then not Synchronized_Present 12609 (Type_Definition (Parent (Act_T))) 12610 then 12611 Error_Msg_N 12612 ("actual of synchronized type must be synchronized", Actual); 12613 Abandon_Instantiation (Actual); 12614 end if; 12615 end if; 12616 12617 -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1 12618 -- removes the second instance of the phrase "or allow pass by copy". 12619 12620 if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then 12621 Error_Msg_N 12622 ("cannot have atomic actual type for non-atomic formal type", 12623 Actual); 12624 12625 elsif Is_Volatile (Act_T) and then not Is_Volatile (Ancestor) then 12626 Error_Msg_N 12627 ("cannot have volatile actual type for non-volatile formal type", 12628 Actual); 12629 end if; 12630 12631 -- It should not be necessary to check for unknown discriminants on 12632 -- Formal, but for some reason Has_Unknown_Discriminants is false for 12633 -- A_Gen_T, so Is_Definite_Subtype incorrectly returns True. This 12634 -- needs fixing. ??? 12635 12636 if Is_Definite_Subtype (A_Gen_T) 12637 and then not Unknown_Discriminants_Present (Formal) 12638 and then not Is_Definite_Subtype (Act_T) 12639 then 12640 Error_Msg_N ("actual subtype must be constrained", Actual); 12641 Abandon_Instantiation (Actual); 12642 end if; 12643 12644 if not Unknown_Discriminants_Present (Formal) then 12645 if Is_Constrained (Ancestor) then 12646 if not Is_Constrained (Act_T) then 12647 Error_Msg_N ("actual subtype must be constrained", Actual); 12648 Abandon_Instantiation (Actual); 12649 end if; 12650 12651 -- Ancestor is unconstrained, Check if generic formal and actual 12652 -- agree on constrainedness. The check only applies to array types 12653 -- and discriminated types. 12654 12655 elsif Is_Constrained (Act_T) then 12656 if Ekind (Ancestor) = E_Access_Type 12657 or else (not Is_Constrained (A_Gen_T) 12658 and then Is_Composite_Type (A_Gen_T)) 12659 then 12660 Error_Msg_N ("actual subtype must be unconstrained", Actual); 12661 Abandon_Instantiation (Actual); 12662 end if; 12663 12664 -- A class-wide type is only allowed if the formal has unknown 12665 -- discriminants. 12666 12667 elsif Is_Class_Wide_Type (Act_T) 12668 and then not Has_Unknown_Discriminants (Ancestor) 12669 then 12670 Error_Msg_NE 12671 ("actual for & cannot be a class-wide type", Actual, Gen_T); 12672 Abandon_Instantiation (Actual); 12673 12674 -- Otherwise, the formal and actual must have the same number 12675 -- of discriminants and each discriminant of the actual must 12676 -- correspond to a discriminant of the formal. 12677 12678 elsif Has_Discriminants (Act_T) 12679 and then not Has_Unknown_Discriminants (Act_T) 12680 and then Has_Discriminants (Ancestor) 12681 then 12682 Actual_Discr := First_Discriminant (Act_T); 12683 Ancestor_Discr := First_Discriminant (Ancestor); 12684 while Present (Actual_Discr) 12685 and then Present (Ancestor_Discr) 12686 loop 12687 if Base_Type (Act_T) /= Base_Type (Ancestor) and then 12688 No (Corresponding_Discriminant (Actual_Discr)) 12689 then 12690 Error_Msg_NE 12691 ("discriminant & does not correspond " 12692 & "to ancestor discriminant", Actual, Actual_Discr); 12693 Abandon_Instantiation (Actual); 12694 end if; 12695 12696 Next_Discriminant (Actual_Discr); 12697 Next_Discriminant (Ancestor_Discr); 12698 end loop; 12699 12700 if Present (Actual_Discr) or else Present (Ancestor_Discr) then 12701 Error_Msg_NE 12702 ("actual for & must have same number of discriminants", 12703 Actual, Gen_T); 12704 Abandon_Instantiation (Actual); 12705 end if; 12706 12707 -- This case should be caught by the earlier check for 12708 -- constrainedness, but the check here is added for completeness. 12709 12710 elsif Has_Discriminants (Act_T) 12711 and then not Has_Unknown_Discriminants (Act_T) 12712 then 12713 Error_Msg_NE 12714 ("actual for & must not have discriminants", Actual, Gen_T); 12715 Abandon_Instantiation (Actual); 12716 12717 elsif Has_Discriminants (Ancestor) then 12718 Error_Msg_NE 12719 ("actual for & must have known discriminants", Actual, Gen_T); 12720 Abandon_Instantiation (Actual); 12721 end if; 12722 12723 if not Subtypes_Statically_Compatible 12724 (Act_T, Ancestor, Formal_Derived_Matching => True) 12725 then 12726 Error_Msg_N 12727 ("constraint on actual is incompatible with formal", Actual); 12728 Abandon_Instantiation (Actual); 12729 end if; 12730 end if; 12731 12732 -- If the formal and actual types are abstract, check that there 12733 -- are no abstract primitives of the actual type that correspond to 12734 -- nonabstract primitives of the formal type (second sentence of 12735 -- RM95 3.9.3(9)). 12736 12737 if Is_Abstract_Type (A_Gen_T) and then Is_Abstract_Type (Act_T) then 12738 Check_Abstract_Primitives : declare 12739 Gen_Prims : constant Elist_Id := 12740 Primitive_Operations (A_Gen_T); 12741 Gen_Elmt : Elmt_Id; 12742 Gen_Subp : Entity_Id; 12743 Anc_Subp : Entity_Id; 12744 Anc_Formal : Entity_Id; 12745 Anc_F_Type : Entity_Id; 12746 12747 Act_Prims : constant Elist_Id := Primitive_Operations (Act_T); 12748 Act_Elmt : Elmt_Id; 12749 Act_Subp : Entity_Id; 12750 Act_Formal : Entity_Id; 12751 Act_F_Type : Entity_Id; 12752 12753 Subprograms_Correspond : Boolean; 12754 12755 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean; 12756 -- Returns true if T2 is derived directly or indirectly from 12757 -- T1, including derivations from interfaces. T1 and T2 are 12758 -- required to be specific tagged base types. 12759 12760 ------------------------ 12761 -- Is_Tagged_Ancestor -- 12762 ------------------------ 12763 12764 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean 12765 is 12766 Intfc_Elmt : Elmt_Id; 12767 12768 begin 12769 -- The predicate is satisfied if the types are the same 12770 12771 if T1 = T2 then 12772 return True; 12773 12774 -- If we've reached the top of the derivation chain then 12775 -- we know that T1 is not an ancestor of T2. 12776 12777 elsif Etype (T2) = T2 then 12778 return False; 12779 12780 -- Proceed to check T2's immediate parent 12781 12782 elsif Is_Ancestor (T1, Base_Type (Etype (T2))) then 12783 return True; 12784 12785 -- Finally, check to see if T1 is an ancestor of any of T2's 12786 -- progenitors. 12787 12788 else 12789 Intfc_Elmt := First_Elmt (Interfaces (T2)); 12790 while Present (Intfc_Elmt) loop 12791 if Is_Ancestor (T1, Node (Intfc_Elmt)) then 12792 return True; 12793 end if; 12794 12795 Next_Elmt (Intfc_Elmt); 12796 end loop; 12797 end if; 12798 12799 return False; 12800 end Is_Tagged_Ancestor; 12801 12802 -- Start of processing for Check_Abstract_Primitives 12803 12804 begin 12805 -- Loop over all of the formal derived type's primitives 12806 12807 Gen_Elmt := First_Elmt (Gen_Prims); 12808 while Present (Gen_Elmt) loop 12809 Gen_Subp := Node (Gen_Elmt); 12810 12811 -- If the primitive of the formal is not abstract, then 12812 -- determine whether there is a corresponding primitive of 12813 -- the actual type that's abstract. 12814 12815 if not Is_Abstract_Subprogram (Gen_Subp) then 12816 Act_Elmt := First_Elmt (Act_Prims); 12817 while Present (Act_Elmt) loop 12818 Act_Subp := Node (Act_Elmt); 12819 12820 -- If we find an abstract primitive of the actual, 12821 -- then we need to test whether it corresponds to the 12822 -- subprogram from which the generic formal primitive 12823 -- is inherited. 12824 12825 if Is_Abstract_Subprogram (Act_Subp) then 12826 Anc_Subp := Alias (Gen_Subp); 12827 12828 -- Test whether we have a corresponding primitive 12829 -- by comparing names, kinds, formal types, and 12830 -- result types. 12831 12832 if Chars (Anc_Subp) = Chars (Act_Subp) 12833 and then Ekind (Anc_Subp) = Ekind (Act_Subp) 12834 then 12835 Anc_Formal := First_Formal (Anc_Subp); 12836 Act_Formal := First_Formal (Act_Subp); 12837 while Present (Anc_Formal) 12838 and then Present (Act_Formal) 12839 loop 12840 Anc_F_Type := Etype (Anc_Formal); 12841 Act_F_Type := Etype (Act_Formal); 12842 12843 if Ekind (Anc_F_Type) = 12844 E_Anonymous_Access_Type 12845 then 12846 Anc_F_Type := Designated_Type (Anc_F_Type); 12847 12848 if Ekind (Act_F_Type) = 12849 E_Anonymous_Access_Type 12850 then 12851 Act_F_Type := 12852 Designated_Type (Act_F_Type); 12853 else 12854 exit; 12855 end if; 12856 12857 elsif 12858 Ekind (Act_F_Type) = E_Anonymous_Access_Type 12859 then 12860 exit; 12861 end if; 12862 12863 Anc_F_Type := Base_Type (Anc_F_Type); 12864 Act_F_Type := Base_Type (Act_F_Type); 12865 12866 -- If the formal is controlling, then the 12867 -- the type of the actual primitive's formal 12868 -- must be derived directly or indirectly 12869 -- from the type of the ancestor primitive's 12870 -- formal. 12871 12872 if Is_Controlling_Formal (Anc_Formal) then 12873 if not Is_Tagged_Ancestor 12874 (Anc_F_Type, Act_F_Type) 12875 then 12876 exit; 12877 end if; 12878 12879 -- Otherwise the types of the formals must 12880 -- be the same. 12881 12882 elsif Anc_F_Type /= Act_F_Type then 12883 exit; 12884 end if; 12885 12886 Next_Entity (Anc_Formal); 12887 Next_Entity (Act_Formal); 12888 end loop; 12889 12890 -- If we traversed through all of the formals 12891 -- then so far the subprograms correspond, so 12892 -- now check that any result types correspond. 12893 12894 if No (Anc_Formal) and then No (Act_Formal) then 12895 Subprograms_Correspond := True; 12896 12897 if Ekind (Act_Subp) = E_Function then 12898 Anc_F_Type := Etype (Anc_Subp); 12899 Act_F_Type := Etype (Act_Subp); 12900 12901 if Ekind (Anc_F_Type) = 12902 E_Anonymous_Access_Type 12903 then 12904 Anc_F_Type := 12905 Designated_Type (Anc_F_Type); 12906 12907 if Ekind (Act_F_Type) = 12908 E_Anonymous_Access_Type 12909 then 12910 Act_F_Type := 12911 Designated_Type (Act_F_Type); 12912 else 12913 Subprograms_Correspond := False; 12914 end if; 12915 12916 elsif 12917 Ekind (Act_F_Type) 12918 = E_Anonymous_Access_Type 12919 then 12920 Subprograms_Correspond := False; 12921 end if; 12922 12923 Anc_F_Type := Base_Type (Anc_F_Type); 12924 Act_F_Type := Base_Type (Act_F_Type); 12925 12926 -- Now either the result types must be 12927 -- the same or, if the result type is 12928 -- controlling, the result type of the 12929 -- actual primitive must descend from the 12930 -- result type of the ancestor primitive. 12931 12932 if Subprograms_Correspond 12933 and then Anc_F_Type /= Act_F_Type 12934 and then 12935 Has_Controlling_Result (Anc_Subp) 12936 and then not Is_Tagged_Ancestor 12937 (Anc_F_Type, Act_F_Type) 12938 then 12939 Subprograms_Correspond := False; 12940 end if; 12941 end if; 12942 12943 -- Found a matching subprogram belonging to 12944 -- formal ancestor type, so actual subprogram 12945 -- corresponds and this violates 3.9.3(9). 12946 12947 if Subprograms_Correspond then 12948 Error_Msg_NE 12949 ("abstract subprogram & overrides " 12950 & "nonabstract subprogram of ancestor", 12951 Actual, Act_Subp); 12952 end if; 12953 end if; 12954 end if; 12955 end if; 12956 12957 Next_Elmt (Act_Elmt); 12958 end loop; 12959 end if; 12960 12961 Next_Elmt (Gen_Elmt); 12962 end loop; 12963 end Check_Abstract_Primitives; 12964 end if; 12965 12966 -- Verify that limitedness matches. If parent is a limited 12967 -- interface then the generic formal is not unless declared 12968 -- explicitly so. If not declared limited, the actual cannot be 12969 -- limited (see AI05-0087). 12970 12971 -- Even though this AI is a binding interpretation, we enable the 12972 -- check only in Ada 2012 mode, because this improper construct 12973 -- shows up in user code and in existing B-tests. 12974 12975 if Is_Limited_Type (Act_T) 12976 and then not Is_Limited_Type (A_Gen_T) 12977 and then Ada_Version >= Ada_2012 12978 then 12979 if In_Instance then 12980 null; 12981 else 12982 Error_Msg_NE 12983 ("actual for non-limited & cannot be a limited type", 12984 Actual, Gen_T); 12985 Explain_Limited_Type (Act_T, Actual); 12986 Abandon_Instantiation (Actual); 12987 end if; 12988 end if; 12989 end Validate_Derived_Type_Instance; 12990 12991 ---------------------------------------- 12992 -- Validate_Discriminated_Formal_Type -- 12993 ---------------------------------------- 12994 12995 procedure Validate_Discriminated_Formal_Type is 12996 Formal_Discr : Entity_Id; 12997 Actual_Discr : Entity_Id; 12998 Formal_Subt : Entity_Id; 12999 13000 begin 13001 if Has_Discriminants (A_Gen_T) then 13002 if not Has_Discriminants (Act_T) then 13003 Error_Msg_NE 13004 ("actual for & must have discriminants", Actual, Gen_T); 13005 Abandon_Instantiation (Actual); 13006 13007 elsif Is_Constrained (Act_T) then 13008 Error_Msg_NE 13009 ("actual for & must be unconstrained", Actual, Gen_T); 13010 Abandon_Instantiation (Actual); 13011 13012 else 13013 Formal_Discr := First_Discriminant (A_Gen_T); 13014 Actual_Discr := First_Discriminant (Act_T); 13015 while Formal_Discr /= Empty loop 13016 if Actual_Discr = Empty then 13017 Error_Msg_NE 13018 ("discriminants on actual do not match formal", 13019 Actual, Gen_T); 13020 Abandon_Instantiation (Actual); 13021 end if; 13022 13023 Formal_Subt := Get_Instance_Of (Etype (Formal_Discr)); 13024 13025 -- Access discriminants match if designated types do 13026 13027 if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type 13028 and then (Ekind (Base_Type (Etype (Actual_Discr)))) = 13029 E_Anonymous_Access_Type 13030 and then 13031 Get_Instance_Of 13032 (Designated_Type (Base_Type (Formal_Subt))) = 13033 Designated_Type (Base_Type (Etype (Actual_Discr))) 13034 then 13035 null; 13036 13037 elsif Base_Type (Formal_Subt) /= 13038 Base_Type (Etype (Actual_Discr)) 13039 then 13040 Error_Msg_NE 13041 ("types of actual discriminants must match formal", 13042 Actual, Gen_T); 13043 Abandon_Instantiation (Actual); 13044 13045 elsif not Subtypes_Statically_Match 13046 (Formal_Subt, Etype (Actual_Discr)) 13047 and then Ada_Version >= Ada_95 13048 then 13049 Error_Msg_NE 13050 ("subtypes of actual discriminants must match formal", 13051 Actual, Gen_T); 13052 Abandon_Instantiation (Actual); 13053 end if; 13054 13055 Next_Discriminant (Formal_Discr); 13056 Next_Discriminant (Actual_Discr); 13057 end loop; 13058 13059 if Actual_Discr /= Empty then 13060 Error_Msg_NE 13061 ("discriminants on actual do not match formal", 13062 Actual, Gen_T); 13063 Abandon_Instantiation (Actual); 13064 end if; 13065 end if; 13066 end if; 13067 end Validate_Discriminated_Formal_Type; 13068 13069 --------------------------------------- 13070 -- Validate_Incomplete_Type_Instance -- 13071 --------------------------------------- 13072 13073 procedure Validate_Incomplete_Type_Instance is 13074 begin 13075 if not Is_Tagged_Type (Act_T) 13076 and then Is_Tagged_Type (A_Gen_T) 13077 then 13078 Error_Msg_NE 13079 ("actual for & must be a tagged type", Actual, Gen_T); 13080 end if; 13081 13082 Validate_Discriminated_Formal_Type; 13083 end Validate_Incomplete_Type_Instance; 13084 13085 -------------------------------------- 13086 -- Validate_Interface_Type_Instance -- 13087 -------------------------------------- 13088 13089 procedure Validate_Interface_Type_Instance is 13090 begin 13091 if not Is_Interface (Act_T) then 13092 Error_Msg_NE 13093 ("actual for formal interface type must be an interface", 13094 Actual, Gen_T); 13095 13096 elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T) 13097 or else Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T) 13098 or else Is_Protected_Interface (A_Gen_T) /= 13099 Is_Protected_Interface (Act_T) 13100 or else Is_Synchronized_Interface (A_Gen_T) /= 13101 Is_Synchronized_Interface (Act_T) 13102 then 13103 Error_Msg_NE 13104 ("actual for interface& does not match (RM 12.5.5(4))", 13105 Actual, Gen_T); 13106 end if; 13107 end Validate_Interface_Type_Instance; 13108 13109 ------------------------------------ 13110 -- Validate_Private_Type_Instance -- 13111 ------------------------------------ 13112 13113 procedure Validate_Private_Type_Instance is 13114 begin 13115 if Is_Limited_Type (Act_T) 13116 and then not Is_Limited_Type (A_Gen_T) 13117 then 13118 if In_Instance then 13119 null; 13120 else 13121 Error_Msg_NE 13122 ("actual for non-limited & cannot be a limited type", Actual, 13123 Gen_T); 13124 Explain_Limited_Type (Act_T, Actual); 13125 Abandon_Instantiation (Actual); 13126 end if; 13127 13128 elsif Known_To_Have_Preelab_Init (A_Gen_T) 13129 and then not Has_Preelaborable_Initialization (Act_T) 13130 then 13131 Error_Msg_NE 13132 ("actual for & must have preelaborable initialization", Actual, 13133 Gen_T); 13134 13135 elsif not Is_Definite_Subtype (Act_T) 13136 and then Is_Definite_Subtype (A_Gen_T) 13137 and then Ada_Version >= Ada_95 13138 then 13139 Error_Msg_NE 13140 ("actual for & must be a definite subtype", Actual, Gen_T); 13141 13142 elsif not Is_Tagged_Type (Act_T) 13143 and then Is_Tagged_Type (A_Gen_T) 13144 then 13145 Error_Msg_NE 13146 ("actual for & must be a tagged type", Actual, Gen_T); 13147 end if; 13148 13149 Validate_Discriminated_Formal_Type; 13150 Ancestor := Gen_T; 13151 end Validate_Private_Type_Instance; 13152 13153 -- Start of processing for Instantiate_Type 13154 13155 begin 13156 if Get_Instance_Of (A_Gen_T) /= A_Gen_T then 13157 Error_Msg_N ("duplicate instantiation of generic type", Actual); 13158 return New_List (Error); 13159 13160 elsif not Is_Entity_Name (Actual) 13161 or else not Is_Type (Entity (Actual)) 13162 then 13163 Error_Msg_NE 13164 ("expect valid subtype mark to instantiate &", Actual, Gen_T); 13165 Abandon_Instantiation (Actual); 13166 13167 else 13168 Act_T := Entity (Actual); 13169 13170 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed 13171 -- as a generic actual parameter if the corresponding formal type 13172 -- does not have a known_discriminant_part, or is a formal derived 13173 -- type that is an Unchecked_Union type. 13174 13175 if Is_Unchecked_Union (Base_Type (Act_T)) then 13176 if not Has_Discriminants (A_Gen_T) 13177 or else (Is_Derived_Type (A_Gen_T) 13178 and then Is_Unchecked_Union (A_Gen_T)) 13179 then 13180 null; 13181 else 13182 Error_Msg_N ("unchecked union cannot be the actual for a " 13183 & "discriminated formal type", Act_T); 13184 13185 end if; 13186 end if; 13187 13188 -- Deal with fixed/floating restrictions 13189 13190 if Is_Floating_Point_Type (Act_T) then 13191 Check_Restriction (No_Floating_Point, Actual); 13192 elsif Is_Fixed_Point_Type (Act_T) then 13193 Check_Restriction (No_Fixed_Point, Actual); 13194 end if; 13195 13196 -- Deal with error of using incomplete type as generic actual. 13197 -- This includes limited views of a type, even if the non-limited 13198 -- view may be available. 13199 13200 if Ekind (Act_T) = E_Incomplete_Type 13201 or else (Is_Class_Wide_Type (Act_T) 13202 and then Ekind (Root_Type (Act_T)) = E_Incomplete_Type) 13203 then 13204 -- If the formal is an incomplete type, the actual can be 13205 -- incomplete as well. 13206 13207 if Ekind (A_Gen_T) = E_Incomplete_Type then 13208 null; 13209 13210 elsif Is_Class_Wide_Type (Act_T) 13211 or else No (Full_View (Act_T)) 13212 then 13213 Error_Msg_N ("premature use of incomplete type", Actual); 13214 Abandon_Instantiation (Actual); 13215 else 13216 Act_T := Full_View (Act_T); 13217 Set_Entity (Actual, Act_T); 13218 13219 if Has_Private_Component (Act_T) then 13220 Error_Msg_N 13221 ("premature use of type with private component", Actual); 13222 end if; 13223 end if; 13224 13225 -- Deal with error of premature use of private type as generic actual 13226 13227 elsif Is_Private_Type (Act_T) 13228 and then Is_Private_Type (Base_Type (Act_T)) 13229 and then not Is_Generic_Type (Act_T) 13230 and then not Is_Derived_Type (Act_T) 13231 and then No (Full_View (Root_Type (Act_T))) 13232 then 13233 -- If the formal is an incomplete type, the actual can be 13234 -- private or incomplete as well. 13235 13236 if Ekind (A_Gen_T) = E_Incomplete_Type then 13237 null; 13238 else 13239 Error_Msg_N ("premature use of private type", Actual); 13240 end if; 13241 13242 elsif Has_Private_Component (Act_T) then 13243 Error_Msg_N 13244 ("premature use of type with private component", Actual); 13245 end if; 13246 13247 Set_Instance_Of (A_Gen_T, Act_T); 13248 13249 -- If the type is generic, the class-wide type may also be used 13250 13251 if Is_Tagged_Type (A_Gen_T) 13252 and then Is_Tagged_Type (Act_T) 13253 and then not Is_Class_Wide_Type (A_Gen_T) 13254 then 13255 Set_Instance_Of (Class_Wide_Type (A_Gen_T), 13256 Class_Wide_Type (Act_T)); 13257 end if; 13258 13259 if not Is_Abstract_Type (A_Gen_T) 13260 and then Is_Abstract_Type (Act_T) 13261 then 13262 Error_Msg_N 13263 ("actual of non-abstract formal cannot be abstract", Actual); 13264 end if; 13265 13266 -- A generic scalar type is a first subtype for which we generate 13267 -- an anonymous base type. Indicate that the instance of this base 13268 -- is the base type of the actual. 13269 13270 if Is_Scalar_Type (A_Gen_T) then 13271 Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T)); 13272 end if; 13273 end if; 13274 13275 if Error_Posted (Act_T) then 13276 null; 13277 else 13278 case Nkind (Def) is 13279 when N_Formal_Private_Type_Definition => 13280 Validate_Private_Type_Instance; 13281 13282 when N_Formal_Incomplete_Type_Definition => 13283 Validate_Incomplete_Type_Instance; 13284 13285 when N_Formal_Derived_Type_Definition => 13286 Validate_Derived_Type_Instance; 13287 13288 when N_Formal_Discrete_Type_Definition => 13289 if not Is_Discrete_Type (Act_T) then 13290 Error_Msg_NE 13291 ("expect discrete type in instantiation of&", 13292 Actual, Gen_T); 13293 Abandon_Instantiation (Actual); 13294 end if; 13295 13296 Diagnose_Predicated_Actual; 13297 13298 when N_Formal_Signed_Integer_Type_Definition => 13299 if not Is_Signed_Integer_Type (Act_T) then 13300 Error_Msg_NE 13301 ("expect signed integer type in instantiation of&", 13302 Actual, Gen_T); 13303 Abandon_Instantiation (Actual); 13304 end if; 13305 13306 Diagnose_Predicated_Actual; 13307 13308 when N_Formal_Modular_Type_Definition => 13309 if not Is_Modular_Integer_Type (Act_T) then 13310 Error_Msg_NE 13311 ("expect modular type in instantiation of &", 13312 Actual, Gen_T); 13313 Abandon_Instantiation (Actual); 13314 end if; 13315 13316 Diagnose_Predicated_Actual; 13317 13318 when N_Formal_Floating_Point_Definition => 13319 if not Is_Floating_Point_Type (Act_T) then 13320 Error_Msg_NE 13321 ("expect float type in instantiation of &", Actual, Gen_T); 13322 Abandon_Instantiation (Actual); 13323 end if; 13324 13325 when N_Formal_Ordinary_Fixed_Point_Definition => 13326 if not Is_Ordinary_Fixed_Point_Type (Act_T) then 13327 Error_Msg_NE 13328 ("expect ordinary fixed point type in instantiation of &", 13329 Actual, Gen_T); 13330 Abandon_Instantiation (Actual); 13331 end if; 13332 13333 when N_Formal_Decimal_Fixed_Point_Definition => 13334 if not Is_Decimal_Fixed_Point_Type (Act_T) then 13335 Error_Msg_NE 13336 ("expect decimal type in instantiation of &", 13337 Actual, Gen_T); 13338 Abandon_Instantiation (Actual); 13339 end if; 13340 13341 when N_Array_Type_Definition => 13342 Validate_Array_Type_Instance; 13343 13344 when N_Access_To_Object_Definition => 13345 Validate_Access_Type_Instance; 13346 13347 when N_Access_Function_Definition 13348 | N_Access_Procedure_Definition 13349 => 13350 Validate_Access_Subprogram_Instance; 13351 13352 when N_Record_Definition => 13353 Validate_Interface_Type_Instance; 13354 13355 when N_Derived_Type_Definition => 13356 Validate_Derived_Interface_Type_Instance; 13357 13358 when others => 13359 raise Program_Error; 13360 end case; 13361 end if; 13362 13363 Subt := New_Copy (Gen_T); 13364 13365 -- Use adjusted sloc of subtype name as the location for other nodes in 13366 -- the subtype declaration. 13367 13368 Loc := Sloc (Subt); 13369 13370 Decl_Node := 13371 Make_Subtype_Declaration (Loc, 13372 Defining_Identifier => Subt, 13373 Subtype_Indication => New_Occurrence_Of (Act_T, Loc)); 13374 13375 if Is_Private_Type (Act_T) then 13376 Set_Has_Private_View (Subtype_Indication (Decl_Node)); 13377 13378 elsif Is_Access_Type (Act_T) 13379 and then Is_Private_Type (Designated_Type (Act_T)) 13380 then 13381 Set_Has_Private_View (Subtype_Indication (Decl_Node)); 13382 end if; 13383 13384 -- In Ada 2012 the actual may be a limited view. Indicate that 13385 -- the local subtype must be treated as such. 13386 13387 if From_Limited_With (Act_T) then 13388 Set_Ekind (Subt, E_Incomplete_Subtype); 13389 Set_From_Limited_With (Subt); 13390 end if; 13391 13392 Decl_Nodes := New_List (Decl_Node); 13393 13394 -- Flag actual derived types so their elaboration produces the 13395 -- appropriate renamings for the primitive operations of the ancestor. 13396 -- Flag actual for formal private types as well, to determine whether 13397 -- operations in the private part may override inherited operations. 13398 -- If the formal has an interface list, the ancestor is not the 13399 -- parent, but the analyzed formal that includes the interface 13400 -- operations of all its progenitors. 13401 13402 -- Same treatment for formal private types, so we can check whether the 13403 -- type is tagged limited when validating derivations in the private 13404 -- part. (See AI05-096). 13405 13406 if Nkind (Def) = N_Formal_Derived_Type_Definition then 13407 if Present (Interface_List (Def)) then 13408 Set_Generic_Parent_Type (Decl_Node, A_Gen_T); 13409 else 13410 Set_Generic_Parent_Type (Decl_Node, Ancestor); 13411 end if; 13412 13413 elsif Nkind_In (Def, N_Formal_Private_Type_Definition, 13414 N_Formal_Incomplete_Type_Definition) 13415 then 13416 Set_Generic_Parent_Type (Decl_Node, A_Gen_T); 13417 end if; 13418 13419 -- If the actual is a synchronized type that implements an interface, 13420 -- the primitive operations are attached to the corresponding record, 13421 -- and we have to treat it as an additional generic actual, so that its 13422 -- primitive operations become visible in the instance. The task or 13423 -- protected type itself does not carry primitive operations. 13424 13425 if Is_Concurrent_Type (Act_T) 13426 and then Is_Tagged_Type (Act_T) 13427 and then Present (Corresponding_Record_Type (Act_T)) 13428 and then Present (Ancestor) 13429 and then Is_Interface (Ancestor) 13430 then 13431 declare 13432 Corr_Rec : constant Entity_Id := 13433 Corresponding_Record_Type (Act_T); 13434 New_Corr : Entity_Id; 13435 Corr_Decl : Node_Id; 13436 13437 begin 13438 New_Corr := Make_Temporary (Loc, 'S'); 13439 Corr_Decl := 13440 Make_Subtype_Declaration (Loc, 13441 Defining_Identifier => New_Corr, 13442 Subtype_Indication => 13443 New_Occurrence_Of (Corr_Rec, Loc)); 13444 Append_To (Decl_Nodes, Corr_Decl); 13445 13446 if Ekind (Act_T) = E_Task_Type then 13447 Set_Ekind (Subt, E_Task_Subtype); 13448 else 13449 Set_Ekind (Subt, E_Protected_Subtype); 13450 end if; 13451 13452 Set_Corresponding_Record_Type (Subt, Corr_Rec); 13453 Set_Generic_Parent_Type (Corr_Decl, Ancestor); 13454 Set_Generic_Parent_Type (Decl_Node, Empty); 13455 end; 13456 end if; 13457 13458 -- For a floating-point type, capture dimension info if any, because 13459 -- the generated subtype declaration does not come from source and 13460 -- will not process dimensions. 13461 13462 if Is_Floating_Point_Type (Act_T) then 13463 Copy_Dimensions (Act_T, Subt); 13464 end if; 13465 13466 return Decl_Nodes; 13467 end Instantiate_Type; 13468 13469 --------------------- 13470 -- Is_In_Main_Unit -- 13471 --------------------- 13472 13473 function Is_In_Main_Unit (N : Node_Id) return Boolean is 13474 Unum : constant Unit_Number_Type := Get_Source_Unit (N); 13475 Current_Unit : Node_Id; 13476 13477 begin 13478 if Unum = Main_Unit then 13479 return True; 13480 13481 -- If the current unit is a subunit then it is either the main unit or 13482 -- is being compiled as part of the main unit. 13483 13484 elsif Nkind (N) = N_Compilation_Unit then 13485 return Nkind (Unit (N)) = N_Subunit; 13486 end if; 13487 13488 Current_Unit := Parent (N); 13489 while Present (Current_Unit) 13490 and then Nkind (Current_Unit) /= N_Compilation_Unit 13491 loop 13492 Current_Unit := Parent (Current_Unit); 13493 end loop; 13494 13495 -- The instantiation node is in the main unit, or else the current node 13496 -- (perhaps as the result of nested instantiations) is in the main unit, 13497 -- or in the declaration of the main unit, which in this last case must 13498 -- be a body. 13499 13500 return 13501 Current_Unit = Cunit (Main_Unit) 13502 or else Current_Unit = Library_Unit (Cunit (Main_Unit)) 13503 or else (Present (Current_Unit) 13504 and then Present (Library_Unit (Current_Unit)) 13505 and then Is_In_Main_Unit (Library_Unit (Current_Unit))); 13506 end Is_In_Main_Unit; 13507 13508 ---------------------------- 13509 -- Load_Parent_Of_Generic -- 13510 ---------------------------- 13511 13512 procedure Load_Parent_Of_Generic 13513 (N : Node_Id; 13514 Spec : Node_Id; 13515 Body_Optional : Boolean := False) 13516 is 13517 Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec)); 13518 Saved_Style_Check : constant Boolean := Style_Check; 13519 Saved_Warnings : constant Warning_Record := Save_Warnings; 13520 True_Parent : Node_Id; 13521 Inst_Node : Node_Id; 13522 OK : Boolean; 13523 Previous_Instances : constant Elist_Id := New_Elmt_List; 13524 13525 procedure Collect_Previous_Instances (Decls : List_Id); 13526 -- Collect all instantiations in the given list of declarations, that 13527 -- precede the generic that we need to load. If the bodies of these 13528 -- instantiations are available, we must analyze them, to ensure that 13529 -- the public symbols generated are the same when the unit is compiled 13530 -- to generate code, and when it is compiled in the context of a unit 13531 -- that needs a particular nested instance. This process is applied to 13532 -- both package and subprogram instances. 13533 13534 -------------------------------- 13535 -- Collect_Previous_Instances -- 13536 -------------------------------- 13537 13538 procedure Collect_Previous_Instances (Decls : List_Id) is 13539 Decl : Node_Id; 13540 13541 begin 13542 Decl := First (Decls); 13543 while Present (Decl) loop 13544 if Sloc (Decl) >= Sloc (Inst_Node) then 13545 return; 13546 13547 -- If Decl is an instantiation, then record it as requiring 13548 -- instantiation of the corresponding body, except if it is an 13549 -- abbreviated instantiation generated internally for conformance 13550 -- checking purposes only for the case of a formal package 13551 -- declared without a box (see Instantiate_Formal_Package). Such 13552 -- an instantiation does not generate any code (the actual code 13553 -- comes from actual) and thus does not need to be analyzed here. 13554 -- If the instantiation appears with a generic package body it is 13555 -- not analyzed here either. 13556 13557 elsif Nkind (Decl) = N_Package_Instantiation 13558 and then not Is_Internal (Defining_Entity (Decl)) 13559 then 13560 Append_Elmt (Decl, Previous_Instances); 13561 13562 -- For a subprogram instantiation, omit instantiations intrinsic 13563 -- operations (Unchecked_Conversions, etc.) that have no bodies. 13564 13565 elsif Nkind_In (Decl, N_Function_Instantiation, 13566 N_Procedure_Instantiation) 13567 and then not Is_Intrinsic_Subprogram (Entity (Name (Decl))) 13568 then 13569 Append_Elmt (Decl, Previous_Instances); 13570 13571 elsif Nkind (Decl) = N_Package_Declaration then 13572 Collect_Previous_Instances 13573 (Visible_Declarations (Specification (Decl))); 13574 Collect_Previous_Instances 13575 (Private_Declarations (Specification (Decl))); 13576 13577 -- Previous non-generic bodies may contain instances as well 13578 13579 elsif Nkind (Decl) = N_Package_Body 13580 and then Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package 13581 then 13582 Collect_Previous_Instances (Declarations (Decl)); 13583 13584 elsif Nkind (Decl) = N_Subprogram_Body 13585 and then not Acts_As_Spec (Decl) 13586 and then not Is_Generic_Subprogram (Corresponding_Spec (Decl)) 13587 then 13588 Collect_Previous_Instances (Declarations (Decl)); 13589 end if; 13590 13591 Next (Decl); 13592 end loop; 13593 end Collect_Previous_Instances; 13594 13595 -- Start of processing for Load_Parent_Of_Generic 13596 13597 begin 13598 if not In_Same_Source_Unit (N, Spec) 13599 or else Nkind (Unit (Comp_Unit)) = N_Package_Declaration 13600 or else (Nkind (Unit (Comp_Unit)) = N_Package_Body 13601 and then not Is_In_Main_Unit (Spec)) 13602 then 13603 -- Find body of parent of spec, and analyze it. A special case arises 13604 -- when the parent is an instantiation, that is to say when we are 13605 -- currently instantiating a nested generic. In that case, there is 13606 -- no separate file for the body of the enclosing instance. Instead, 13607 -- the enclosing body must be instantiated as if it were a pending 13608 -- instantiation, in order to produce the body for the nested generic 13609 -- we require now. Note that in that case the generic may be defined 13610 -- in a package body, the instance defined in the same package body, 13611 -- and the original enclosing body may not be in the main unit. 13612 13613 Inst_Node := Empty; 13614 13615 True_Parent := Parent (Spec); 13616 while Present (True_Parent) 13617 and then Nkind (True_Parent) /= N_Compilation_Unit 13618 loop 13619 if Nkind (True_Parent) = N_Package_Declaration 13620 and then 13621 Nkind (Original_Node (True_Parent)) = N_Package_Instantiation 13622 then 13623 -- Parent is a compilation unit that is an instantiation. 13624 -- Instantiation node has been replaced with package decl. 13625 13626 Inst_Node := Original_Node (True_Parent); 13627 exit; 13628 13629 elsif Nkind (True_Parent) = N_Package_Declaration 13630 and then Present (Generic_Parent (Specification (True_Parent))) 13631 and then Nkind (Parent (True_Parent)) /= N_Compilation_Unit 13632 then 13633 -- Parent is an instantiation within another specification. 13634 -- Declaration for instance has been inserted before original 13635 -- instantiation node. A direct link would be preferable? 13636 13637 Inst_Node := Next (True_Parent); 13638 while Present (Inst_Node) 13639 and then Nkind (Inst_Node) /= N_Package_Instantiation 13640 loop 13641 Next (Inst_Node); 13642 end loop; 13643 13644 -- If the instance appears within a generic, and the generic 13645 -- unit is defined within a formal package of the enclosing 13646 -- generic, there is no generic body available, and none 13647 -- needed. A more precise test should be used ??? 13648 13649 if No (Inst_Node) then 13650 return; 13651 end if; 13652 13653 exit; 13654 13655 else 13656 True_Parent := Parent (True_Parent); 13657 end if; 13658 end loop; 13659 13660 -- Case where we are currently instantiating a nested generic 13661 13662 if Present (Inst_Node) then 13663 if Nkind (Parent (True_Parent)) = N_Compilation_Unit then 13664 13665 -- Instantiation node and declaration of instantiated package 13666 -- were exchanged when only the declaration was needed. 13667 -- Restore instantiation node before proceeding with body. 13668 13669 Set_Unit (Parent (True_Parent), Inst_Node); 13670 end if; 13671 13672 -- Now complete instantiation of enclosing body, if it appears in 13673 -- some other unit. If it appears in the current unit, the body 13674 -- will have been instantiated already. 13675 13676 if No (Corresponding_Body (Instance_Spec (Inst_Node))) then 13677 13678 -- We need to determine the expander mode to instantiate the 13679 -- enclosing body. Because the generic body we need may use 13680 -- global entities declared in the enclosing package (including 13681 -- aggregates) it is in general necessary to compile this body 13682 -- with expansion enabled, except if we are within a generic 13683 -- package, in which case the usual generic rule applies. 13684 13685 declare 13686 Exp_Status : Boolean := True; 13687 Scop : Entity_Id; 13688 13689 begin 13690 -- Loop through scopes looking for generic package 13691 13692 Scop := Scope (Defining_Entity (Instance_Spec (Inst_Node))); 13693 while Present (Scop) 13694 and then Scop /= Standard_Standard 13695 loop 13696 if Ekind (Scop) = E_Generic_Package then 13697 Exp_Status := False; 13698 exit; 13699 end if; 13700 13701 Scop := Scope (Scop); 13702 end loop; 13703 13704 -- Collect previous instantiations in the unit that contains 13705 -- the desired generic. 13706 13707 if Nkind (Parent (True_Parent)) /= N_Compilation_Unit 13708 and then not Body_Optional 13709 then 13710 declare 13711 Decl : Elmt_Id; 13712 Info : Pending_Body_Info; 13713 Par : Node_Id; 13714 13715 begin 13716 Par := Parent (Inst_Node); 13717 while Present (Par) loop 13718 exit when Nkind (Parent (Par)) = N_Compilation_Unit; 13719 Par := Parent (Par); 13720 end loop; 13721 13722 pragma Assert (Present (Par)); 13723 13724 if Nkind (Par) = N_Package_Body then 13725 Collect_Previous_Instances (Declarations (Par)); 13726 13727 elsif Nkind (Par) = N_Package_Declaration then 13728 Collect_Previous_Instances 13729 (Visible_Declarations (Specification (Par))); 13730 Collect_Previous_Instances 13731 (Private_Declarations (Specification (Par))); 13732 13733 else 13734 -- Enclosing unit is a subprogram body. In this 13735 -- case all instance bodies are processed in order 13736 -- and there is no need to collect them separately. 13737 13738 null; 13739 end if; 13740 13741 Decl := First_Elmt (Previous_Instances); 13742 while Present (Decl) loop 13743 Info := 13744 (Act_Decl => 13745 Instance_Spec (Node (Decl)), 13746 Config_Switches => Save_Config_Switches, 13747 Current_Sem_Unit => 13748 Get_Code_Unit (Sloc (Node (Decl))), 13749 Expander_Status => Exp_Status, 13750 Inst_Node => Node (Decl), 13751 Local_Suppress_Stack_Top => 13752 Local_Suppress_Stack_Top, 13753 Scope_Suppress => Scope_Suppress, 13754 Warnings => Save_Warnings); 13755 13756 -- Package instance 13757 13758 if Nkind (Node (Decl)) = N_Package_Instantiation 13759 then 13760 Instantiate_Package_Body 13761 (Info, Body_Optional => True); 13762 13763 -- Subprogram instance 13764 13765 else 13766 -- The instance_spec is in the wrapper package, 13767 -- usually followed by its local renaming 13768 -- declaration. See Build_Subprogram_Renaming 13769 -- for details. If the instance carries aspects, 13770 -- these result in the corresponding pragmas, 13771 -- inserted after the subprogram declaration. 13772 -- They must be skipped as well when retrieving 13773 -- the desired spec. Some of them may have been 13774 -- rewritten as null statements. 13775 -- A direct link would be more robust ??? 13776 13777 declare 13778 Decl : Node_Id := 13779 (Last (Visible_Declarations 13780 (Specification (Info.Act_Decl)))); 13781 begin 13782 while Nkind_In (Decl, 13783 N_Null_Statement, 13784 N_Pragma, 13785 N_Subprogram_Renaming_Declaration) 13786 loop 13787 Decl := Prev (Decl); 13788 end loop; 13789 13790 Info.Act_Decl := Decl; 13791 end; 13792 13793 Instantiate_Subprogram_Body 13794 (Info, Body_Optional => True); 13795 end if; 13796 13797 Next_Elmt (Decl); 13798 end loop; 13799 end; 13800 end if; 13801 13802 Instantiate_Package_Body 13803 (Body_Info => 13804 ((Act_Decl => True_Parent, 13805 Config_Switches => Save_Config_Switches, 13806 Current_Sem_Unit => 13807 Get_Code_Unit (Sloc (Inst_Node)), 13808 Expander_Status => Exp_Status, 13809 Inst_Node => Inst_Node, 13810 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 13811 Scope_Suppress => Scope_Suppress, 13812 Warnings => Save_Warnings)), 13813 Body_Optional => Body_Optional); 13814 end; 13815 end if; 13816 13817 -- Case where we are not instantiating a nested generic 13818 13819 else 13820 Opt.Style_Check := False; 13821 Expander_Mode_Save_And_Set (True); 13822 Load_Needed_Body (Comp_Unit, OK); 13823 Opt.Style_Check := Saved_Style_Check; 13824 Restore_Warnings (Saved_Warnings); 13825 Expander_Mode_Restore; 13826 13827 if not OK 13828 and then Unit_Requires_Body (Defining_Entity (Spec)) 13829 and then not Body_Optional 13830 then 13831 declare 13832 Bname : constant Unit_Name_Type := 13833 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))); 13834 13835 begin 13836 -- In CodePeer mode, the missing body may make the analysis 13837 -- incomplete, but we do not treat it as fatal. 13838 13839 if CodePeer_Mode then 13840 return; 13841 13842 else 13843 Error_Msg_Unit_1 := Bname; 13844 Error_Msg_N ("this instantiation requires$!", N); 13845 Error_Msg_File_1 := 13846 Get_File_Name (Bname, Subunit => False); 13847 Error_Msg_N ("\but file{ was not found!", N); 13848 raise Unrecoverable_Error; 13849 end if; 13850 end; 13851 end if; 13852 end if; 13853 end if; 13854 13855 -- If loading parent of the generic caused an instantiation circularity, 13856 -- we abandon compilation at this point, because otherwise in some cases 13857 -- we get into trouble with infinite recursions after this point. 13858 13859 if Circularity_Detected then 13860 raise Unrecoverable_Error; 13861 end if; 13862 end Load_Parent_Of_Generic; 13863 13864 --------------------------------- 13865 -- Map_Formal_Package_Entities -- 13866 --------------------------------- 13867 13868 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id) is 13869 E1 : Entity_Id; 13870 E2 : Entity_Id; 13871 13872 begin 13873 Set_Instance_Of (Form, Act); 13874 13875 -- Traverse formal and actual package to map the corresponding entities. 13876 -- We skip over internal entities that may be generated during semantic 13877 -- analysis, and find the matching entities by name, given that they 13878 -- must appear in the same order. 13879 13880 E1 := First_Entity (Form); 13881 E2 := First_Entity (Act); 13882 while Present (E1) and then E1 /= First_Private_Entity (Form) loop 13883 -- Could this test be a single condition??? Seems like it could, and 13884 -- isn't FPE (Form) a constant anyway??? 13885 13886 if not Is_Internal (E1) 13887 and then Present (Parent (E1)) 13888 and then not Is_Class_Wide_Type (E1) 13889 and then not Is_Internal_Name (Chars (E1)) 13890 then 13891 while Present (E2) and then Chars (E2) /= Chars (E1) loop 13892 Next_Entity (E2); 13893 end loop; 13894 13895 if No (E2) then 13896 exit; 13897 else 13898 Set_Instance_Of (E1, E2); 13899 13900 if Is_Type (E1) and then Is_Tagged_Type (E2) then 13901 Set_Instance_Of (Class_Wide_Type (E1), Class_Wide_Type (E2)); 13902 end if; 13903 13904 if Is_Constrained (E1) then 13905 Set_Instance_Of (Base_Type (E1), Base_Type (E2)); 13906 end if; 13907 13908 if Ekind (E1) = E_Package and then No (Renamed_Object (E1)) then 13909 Map_Formal_Package_Entities (E1, E2); 13910 end if; 13911 end if; 13912 end if; 13913 13914 Next_Entity (E1); 13915 end loop; 13916 end Map_Formal_Package_Entities; 13917 13918 ----------------------- 13919 -- Move_Freeze_Nodes -- 13920 ----------------------- 13921 13922 procedure Move_Freeze_Nodes 13923 (Out_Of : Entity_Id; 13924 After : Node_Id; 13925 L : List_Id) 13926 is 13927 Decl : Node_Id; 13928 Next_Decl : Node_Id; 13929 Next_Node : Node_Id := After; 13930 Spec : Node_Id; 13931 13932 function Is_Outer_Type (T : Entity_Id) return Boolean; 13933 -- Check whether entity is declared in a scope external to that of the 13934 -- generic unit. 13935 13936 ------------------- 13937 -- Is_Outer_Type -- 13938 ------------------- 13939 13940 function Is_Outer_Type (T : Entity_Id) return Boolean is 13941 Scop : Entity_Id := Scope (T); 13942 13943 begin 13944 if Scope_Depth (Scop) < Scope_Depth (Out_Of) then 13945 return True; 13946 13947 else 13948 while Scop /= Standard_Standard loop 13949 if Scop = Out_Of then 13950 return False; 13951 else 13952 Scop := Scope (Scop); 13953 end if; 13954 end loop; 13955 13956 return True; 13957 end if; 13958 end Is_Outer_Type; 13959 13960 -- Start of processing for Move_Freeze_Nodes 13961 13962 begin 13963 if No (L) then 13964 return; 13965 end if; 13966 13967 -- First remove the freeze nodes that may appear before all other 13968 -- declarations. 13969 13970 Decl := First (L); 13971 while Present (Decl) 13972 and then Nkind (Decl) = N_Freeze_Entity 13973 and then Is_Outer_Type (Entity (Decl)) 13974 loop 13975 Decl := Remove_Head (L); 13976 Insert_After (Next_Node, Decl); 13977 Set_Analyzed (Decl, False); 13978 Next_Node := Decl; 13979 Decl := First (L); 13980 end loop; 13981 13982 -- Next scan the list of declarations and remove each freeze node that 13983 -- appears ahead of the current node. 13984 13985 while Present (Decl) loop 13986 while Present (Next (Decl)) 13987 and then Nkind (Next (Decl)) = N_Freeze_Entity 13988 and then Is_Outer_Type (Entity (Next (Decl))) 13989 loop 13990 Next_Decl := Remove_Next (Decl); 13991 Insert_After (Next_Node, Next_Decl); 13992 Set_Analyzed (Next_Decl, False); 13993 Next_Node := Next_Decl; 13994 end loop; 13995 13996 -- If the declaration is a nested package or concurrent type, then 13997 -- recurse. Nested generic packages will have been processed from the 13998 -- inside out. 13999 14000 case Nkind (Decl) is 14001 when N_Package_Declaration => 14002 Spec := Specification (Decl); 14003 14004 when N_Task_Type_Declaration => 14005 Spec := Task_Definition (Decl); 14006 14007 when N_Protected_Type_Declaration => 14008 Spec := Protected_Definition (Decl); 14009 14010 when others => 14011 Spec := Empty; 14012 end case; 14013 14014 if Present (Spec) then 14015 Move_Freeze_Nodes (Out_Of, Next_Node, Visible_Declarations (Spec)); 14016 Move_Freeze_Nodes (Out_Of, Next_Node, Private_Declarations (Spec)); 14017 end if; 14018 14019 Next (Decl); 14020 end loop; 14021 end Move_Freeze_Nodes; 14022 14023 ---------------- 14024 -- Next_Assoc -- 14025 ---------------- 14026 14027 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr is 14028 begin 14029 return Generic_Renamings.Table (E).Next_In_HTable; 14030 end Next_Assoc; 14031 14032 ------------------------ 14033 -- Preanalyze_Actuals -- 14034 ------------------------ 14035 14036 procedure Preanalyze_Actuals (N : Node_Id; Inst : Entity_Id := Empty) is 14037 Assoc : Node_Id; 14038 Act : Node_Id; 14039 Errs : constant Nat := Serious_Errors_Detected; 14040 14041 Cur : Entity_Id := Empty; 14042 -- Current homograph of the instance name 14043 14044 Vis : Boolean := False; 14045 -- Saved visibility status of the current homograph 14046 14047 begin 14048 Assoc := First (Generic_Associations (N)); 14049 14050 -- If the instance is a child unit, its name may hide an outer homonym, 14051 -- so make it invisible to perform name resolution on the actuals. 14052 14053 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name 14054 and then Present 14055 (Current_Entity (Defining_Identifier (Defining_Unit_Name (N)))) 14056 then 14057 Cur := Current_Entity (Defining_Identifier (Defining_Unit_Name (N))); 14058 14059 if Is_Compilation_Unit (Cur) then 14060 Vis := Is_Immediately_Visible (Cur); 14061 Set_Is_Immediately_Visible (Cur, False); 14062 else 14063 Cur := Empty; 14064 end if; 14065 end if; 14066 14067 while Present (Assoc) loop 14068 if Nkind (Assoc) /= N_Others_Choice then 14069 Act := Explicit_Generic_Actual_Parameter (Assoc); 14070 14071 -- Within a nested instantiation, a defaulted actual is an empty 14072 -- association, so nothing to analyze. If the subprogram actual 14073 -- is an attribute, analyze prefix only, because actual is not a 14074 -- complete attribute reference. 14075 14076 -- If actual is an allocator, analyze expression only. The full 14077 -- analysis can generate code, and if instance is a compilation 14078 -- unit we have to wait until the package instance is installed 14079 -- to have a proper place to insert this code. 14080 14081 -- String literals may be operators, but at this point we do not 14082 -- know whether the actual is a formal subprogram or a string. 14083 14084 if No (Act) then 14085 null; 14086 14087 elsif Nkind (Act) = N_Attribute_Reference then 14088 Analyze (Prefix (Act)); 14089 14090 elsif Nkind (Act) = N_Explicit_Dereference then 14091 Analyze (Prefix (Act)); 14092 14093 elsif Nkind (Act) = N_Allocator then 14094 declare 14095 Expr : constant Node_Id := Expression (Act); 14096 14097 begin 14098 if Nkind (Expr) = N_Subtype_Indication then 14099 Analyze (Subtype_Mark (Expr)); 14100 14101 -- Analyze separately each discriminant constraint, when 14102 -- given with a named association. 14103 14104 declare 14105 Constr : Node_Id; 14106 14107 begin 14108 Constr := First (Constraints (Constraint (Expr))); 14109 while Present (Constr) loop 14110 if Nkind (Constr) = N_Discriminant_Association then 14111 Analyze (Expression (Constr)); 14112 else 14113 Analyze (Constr); 14114 end if; 14115 14116 Next (Constr); 14117 end loop; 14118 end; 14119 14120 else 14121 Analyze (Expr); 14122 end if; 14123 end; 14124 14125 elsif Nkind (Act) /= N_Operator_Symbol then 14126 Analyze (Act); 14127 14128 -- Within a package instance, mark actuals that are limited 14129 -- views, so their use can be moved to the body of the 14130 -- enclosing unit. 14131 14132 if Is_Entity_Name (Act) 14133 and then Is_Type (Entity (Act)) 14134 and then From_Limited_With (Entity (Act)) 14135 and then Present (Inst) 14136 then 14137 Append_Elmt (Entity (Act), Incomplete_Actuals (Inst)); 14138 end if; 14139 end if; 14140 14141 if Errs /= Serious_Errors_Detected then 14142 14143 -- Do a minimal analysis of the generic, to prevent spurious 14144 -- warnings complaining about the generic being unreferenced, 14145 -- before abandoning the instantiation. 14146 14147 Analyze (Name (N)); 14148 14149 if Is_Entity_Name (Name (N)) 14150 and then Etype (Name (N)) /= Any_Type 14151 then 14152 Generate_Reference (Entity (Name (N)), Name (N)); 14153 Set_Is_Instantiated (Entity (Name (N))); 14154 end if; 14155 14156 if Present (Cur) then 14157 14158 -- For the case of a child instance hiding an outer homonym, 14159 -- provide additional warning which might explain the error. 14160 14161 Set_Is_Immediately_Visible (Cur, Vis); 14162 Error_Msg_NE 14163 ("& hides outer unit with the same name??", 14164 N, Defining_Unit_Name (N)); 14165 end if; 14166 14167 Abandon_Instantiation (Act); 14168 end if; 14169 end if; 14170 14171 Next (Assoc); 14172 end loop; 14173 14174 if Present (Cur) then 14175 Set_Is_Immediately_Visible (Cur, Vis); 14176 end if; 14177 end Preanalyze_Actuals; 14178 14179 ------------------------------- 14180 -- Provide_Completing_Bodies -- 14181 ------------------------------- 14182 14183 procedure Provide_Completing_Bodies (N : Node_Id) is 14184 procedure Build_Completing_Body (Subp_Decl : Node_Id); 14185 -- Generate the completing body for subprogram declaration Subp_Decl 14186 14187 procedure Provide_Completing_Bodies_In (Decls : List_Id); 14188 -- Generating completing bodies for all subprograms found in declarative 14189 -- list Decls. 14190 14191 --------------------------- 14192 -- Build_Completing_Body -- 14193 --------------------------- 14194 14195 procedure Build_Completing_Body (Subp_Decl : Node_Id) is 14196 Loc : constant Source_Ptr := Sloc (Subp_Decl); 14197 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); 14198 Spec : Node_Id; 14199 14200 begin 14201 -- Nothing to do if the subprogram already has a completing body 14202 14203 if Present (Corresponding_Body (Subp_Decl)) then 14204 return; 14205 14206 -- Mark the function as having a valid return statement even though 14207 -- the body contains a single raise statement. 14208 14209 elsif Ekind (Subp_Id) = E_Function then 14210 Set_Return_Present (Subp_Id); 14211 end if; 14212 14213 -- Clone the specification to obtain new entities and reset the only 14214 -- semantic field. 14215 14216 Spec := Copy_Subprogram_Spec (Specification (Subp_Decl)); 14217 Set_Generic_Parent (Spec, Empty); 14218 14219 -- Generate: 14220 -- function Func ... return ... is 14221 -- <or> 14222 -- procedure Proc ... is 14223 -- begin 14224 -- raise Program_Error with "access before elaboration"; 14225 -- edn Proc; 14226 14227 Insert_After_And_Analyze (Subp_Decl, 14228 Make_Subprogram_Body (Loc, 14229 Specification => Spec, 14230 Declarations => New_List, 14231 Handled_Statement_Sequence => 14232 Make_Handled_Sequence_Of_Statements (Loc, 14233 Statements => New_List ( 14234 Make_Raise_Program_Error (Loc, 14235 Reason => PE_Access_Before_Elaboration))))); 14236 end Build_Completing_Body; 14237 14238 ---------------------------------- 14239 -- Provide_Completing_Bodies_In -- 14240 ---------------------------------- 14241 14242 procedure Provide_Completing_Bodies_In (Decls : List_Id) is 14243 Decl : Node_Id; 14244 14245 begin 14246 if Present (Decls) then 14247 Decl := First (Decls); 14248 while Present (Decl) loop 14249 Provide_Completing_Bodies (Decl); 14250 Next (Decl); 14251 end loop; 14252 end if; 14253 end Provide_Completing_Bodies_In; 14254 14255 -- Local variables 14256 14257 Spec : Node_Id; 14258 14259 -- Start of processing for Provide_Completing_Bodies 14260 14261 begin 14262 if Nkind (N) = N_Package_Declaration then 14263 Spec := Specification (N); 14264 14265 Push_Scope (Defining_Entity (N)); 14266 Provide_Completing_Bodies_In (Visible_Declarations (Spec)); 14267 Provide_Completing_Bodies_In (Private_Declarations (Spec)); 14268 Pop_Scope; 14269 14270 elsif Nkind (N) = N_Subprogram_Declaration then 14271 Build_Completing_Body (N); 14272 end if; 14273 end Provide_Completing_Bodies; 14274 14275 ------------------- 14276 -- Remove_Parent -- 14277 ------------------- 14278 14279 procedure Remove_Parent (In_Body : Boolean := False) is 14280 S : Entity_Id := Current_Scope; 14281 -- S is the scope containing the instantiation just completed. The scope 14282 -- stack contains the parent instances of the instantiation, followed by 14283 -- the original S. 14284 14285 Cur_P : Entity_Id; 14286 E : Entity_Id; 14287 P : Entity_Id; 14288 Hidden : Elmt_Id; 14289 14290 begin 14291 -- After child instantiation is complete, remove from scope stack the 14292 -- extra copy of the current scope, and then remove parent instances. 14293 14294 if not In_Body then 14295 Pop_Scope; 14296 14297 while Current_Scope /= S loop 14298 P := Current_Scope; 14299 End_Package_Scope (Current_Scope); 14300 14301 if In_Open_Scopes (P) then 14302 E := First_Entity (P); 14303 while Present (E) loop 14304 Set_Is_Immediately_Visible (E, True); 14305 Next_Entity (E); 14306 end loop; 14307 14308 -- If instantiation is declared in a block, it is the enclosing 14309 -- scope that might be a parent instance. Note that only one 14310 -- block can be involved, because the parent instances have 14311 -- been installed within it. 14312 14313 if Ekind (P) = E_Block then 14314 Cur_P := Scope (P); 14315 else 14316 Cur_P := P; 14317 end if; 14318 14319 if Is_Generic_Instance (Cur_P) and then P /= Current_Scope then 14320 -- We are within an instance of some sibling. Retain 14321 -- visibility of parent, for proper subsequent cleanup, and 14322 -- reinstall private declarations as well. 14323 14324 Set_In_Private_Part (P); 14325 Install_Private_Declarations (P); 14326 end if; 14327 14328 -- If the ultimate parent is a top-level unit recorded in 14329 -- Instance_Parent_Unit, then reset its visibility to what it was 14330 -- before instantiation. (It's not clear what the purpose is of 14331 -- testing whether Scope (P) is In_Open_Scopes, but that test was 14332 -- present before the ultimate parent test was added.???) 14333 14334 elsif not In_Open_Scopes (Scope (P)) 14335 or else (P = Instance_Parent_Unit 14336 and then not Parent_Unit_Visible) 14337 then 14338 Set_Is_Immediately_Visible (P, False); 14339 14340 -- If the current scope is itself an instantiation of a generic 14341 -- nested within P, and we are in the private part of body of this 14342 -- instantiation, restore the full views of P, that were removed 14343 -- in End_Package_Scope above. This obscure case can occur when a 14344 -- subunit of a generic contains an instance of a child unit of 14345 -- its generic parent unit. 14346 14347 elsif S = Current_Scope and then Is_Generic_Instance (S) then 14348 declare 14349 Par : constant Entity_Id := 14350 Generic_Parent (Package_Specification (S)); 14351 begin 14352 if Present (Par) 14353 and then P = Scope (Par) 14354 and then (In_Package_Body (S) or else In_Private_Part (S)) 14355 then 14356 Set_In_Private_Part (P); 14357 Install_Private_Declarations (P); 14358 end if; 14359 end; 14360 end if; 14361 end loop; 14362 14363 -- Reset visibility of entities in the enclosing scope 14364 14365 Set_Is_Hidden_Open_Scope (Current_Scope, False); 14366 14367 Hidden := First_Elmt (Hidden_Entities); 14368 while Present (Hidden) loop 14369 Set_Is_Immediately_Visible (Node (Hidden), True); 14370 Next_Elmt (Hidden); 14371 end loop; 14372 14373 else 14374 -- Each body is analyzed separately, and there is no context that 14375 -- needs preserving from one body instance to the next, so remove all 14376 -- parent scopes that have been installed. 14377 14378 while Present (S) loop 14379 End_Package_Scope (S); 14380 Set_Is_Immediately_Visible (S, False); 14381 S := Current_Scope; 14382 exit when S = Standard_Standard; 14383 end loop; 14384 end if; 14385 end Remove_Parent; 14386 14387 ----------------- 14388 -- Restore_Env -- 14389 ----------------- 14390 14391 procedure Restore_Env is 14392 Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last); 14393 14394 begin 14395 if No (Current_Instantiated_Parent.Act_Id) then 14396 -- Restore environment after subprogram inlining 14397 14398 Restore_Private_Views (Empty); 14399 end if; 14400 14401 Current_Instantiated_Parent := Saved.Instantiated_Parent; 14402 Exchanged_Views := Saved.Exchanged_Views; 14403 Hidden_Entities := Saved.Hidden_Entities; 14404 Current_Sem_Unit := Saved.Current_Sem_Unit; 14405 Parent_Unit_Visible := Saved.Parent_Unit_Visible; 14406 Instance_Parent_Unit := Saved.Instance_Parent_Unit; 14407 14408 Restore_Config_Switches (Saved.Switches); 14409 14410 Instance_Envs.Decrement_Last; 14411 end Restore_Env; 14412 14413 --------------------------- 14414 -- Restore_Private_Views -- 14415 --------------------------- 14416 14417 procedure Restore_Private_Views 14418 (Pack_Id : Entity_Id; 14419 Is_Package : Boolean := True) 14420 is 14421 M : Elmt_Id; 14422 E : Entity_Id; 14423 Typ : Entity_Id; 14424 Dep_Elmt : Elmt_Id; 14425 Dep_Typ : Node_Id; 14426 14427 procedure Restore_Nested_Formal (Formal : Entity_Id); 14428 -- Hide the generic formals of formal packages declared with box which 14429 -- were reachable in the current instantiation. 14430 14431 --------------------------- 14432 -- Restore_Nested_Formal -- 14433 --------------------------- 14434 14435 procedure Restore_Nested_Formal (Formal : Entity_Id) is 14436 Ent : Entity_Id; 14437 14438 begin 14439 if Present (Renamed_Object (Formal)) 14440 and then Denotes_Formal_Package (Renamed_Object (Formal), True) 14441 then 14442 return; 14443 14444 elsif Present (Associated_Formal_Package (Formal)) then 14445 Ent := First_Entity (Formal); 14446 while Present (Ent) loop 14447 exit when Ekind (Ent) = E_Package 14448 and then Renamed_Entity (Ent) = Renamed_Entity (Formal); 14449 14450 Set_Is_Hidden (Ent); 14451 Set_Is_Potentially_Use_Visible (Ent, False); 14452 14453 -- If package, then recurse 14454 14455 if Ekind (Ent) = E_Package then 14456 Restore_Nested_Formal (Ent); 14457 end if; 14458 14459 Next_Entity (Ent); 14460 end loop; 14461 end if; 14462 end Restore_Nested_Formal; 14463 14464 -- Start of processing for Restore_Private_Views 14465 14466 begin 14467 M := First_Elmt (Exchanged_Views); 14468 while Present (M) loop 14469 Typ := Node (M); 14470 14471 -- Subtypes of types whose views have been exchanged, and that are 14472 -- defined within the instance, were not on the Private_Dependents 14473 -- list on entry to the instance, so they have to be exchanged 14474 -- explicitly now, in order to remain consistent with the view of the 14475 -- parent type. 14476 14477 if Ekind_In (Typ, E_Private_Type, 14478 E_Limited_Private_Type, 14479 E_Record_Type_With_Private) 14480 then 14481 Dep_Elmt := First_Elmt (Private_Dependents (Typ)); 14482 while Present (Dep_Elmt) loop 14483 Dep_Typ := Node (Dep_Elmt); 14484 14485 if Scope (Dep_Typ) = Pack_Id 14486 and then Present (Full_View (Dep_Typ)) 14487 then 14488 Replace_Elmt (Dep_Elmt, Full_View (Dep_Typ)); 14489 Exchange_Declarations (Dep_Typ); 14490 end if; 14491 14492 Next_Elmt (Dep_Elmt); 14493 end loop; 14494 end if; 14495 14496 Exchange_Declarations (Node (M)); 14497 Next_Elmt (M); 14498 end loop; 14499 14500 if No (Pack_Id) then 14501 return; 14502 end if; 14503 14504 -- Make the generic formal parameters private, and make the formal types 14505 -- into subtypes of the actuals again. 14506 14507 E := First_Entity (Pack_Id); 14508 while Present (E) loop 14509 Set_Is_Hidden (E, True); 14510 14511 if Is_Type (E) 14512 and then Nkind (Parent (E)) = N_Subtype_Declaration 14513 then 14514 -- If the actual for E is itself a generic actual type from 14515 -- an enclosing instance, E is still a generic actual type 14516 -- outside of the current instance. This matter when resolving 14517 -- an overloaded call that may be ambiguous in the enclosing 14518 -- instance, when two of its actuals coincide. 14519 14520 if Is_Entity_Name (Subtype_Indication (Parent (E))) 14521 and then Is_Generic_Actual_Type 14522 (Entity (Subtype_Indication (Parent (E)))) 14523 then 14524 null; 14525 else 14526 Set_Is_Generic_Actual_Type (E, False); 14527 end if; 14528 14529 -- An unusual case of aliasing: the actual may also be directly 14530 -- visible in the generic, and be private there, while it is fully 14531 -- visible in the context of the instance. The internal subtype 14532 -- is private in the instance but has full visibility like its 14533 -- parent in the enclosing scope. This enforces the invariant that 14534 -- the privacy status of all private dependents of a type coincide 14535 -- with that of the parent type. This can only happen when a 14536 -- generic child unit is instantiated within a sibling. 14537 14538 if Is_Private_Type (E) 14539 and then not Is_Private_Type (Etype (E)) 14540 then 14541 Exchange_Declarations (E); 14542 end if; 14543 14544 elsif Ekind (E) = E_Package then 14545 14546 -- The end of the renaming list is the renaming of the generic 14547 -- package itself. If the instance is a subprogram, all entities 14548 -- in the corresponding package are renamings. If this entity is 14549 -- a formal package, make its own formals private as well. The 14550 -- actual in this case is itself the renaming of an instantiation. 14551 -- If the entity is not a package renaming, it is the entity 14552 -- created to validate formal package actuals: ignore it. 14553 14554 -- If the actual is itself a formal package for the enclosing 14555 -- generic, or the actual for such a formal package, it remains 14556 -- visible on exit from the instance, and therefore nothing needs 14557 -- to be done either, except to keep it accessible. 14558 14559 if Is_Package and then Renamed_Object (E) = Pack_Id then 14560 exit; 14561 14562 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 14563 null; 14564 14565 elsif 14566 Denotes_Formal_Package (Renamed_Object (E), True, Pack_Id) 14567 then 14568 Set_Is_Hidden (E, False); 14569 14570 else 14571 declare 14572 Act_P : constant Entity_Id := Renamed_Object (E); 14573 Id : Entity_Id; 14574 14575 begin 14576 Id := First_Entity (Act_P); 14577 while Present (Id) 14578 and then Id /= First_Private_Entity (Act_P) 14579 loop 14580 exit when Ekind (Id) = E_Package 14581 and then Renamed_Object (Id) = Act_P; 14582 14583 Set_Is_Hidden (Id, True); 14584 Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P)); 14585 14586 if Ekind (Id) = E_Package then 14587 Restore_Nested_Formal (Id); 14588 end if; 14589 14590 Next_Entity (Id); 14591 end loop; 14592 end; 14593 end if; 14594 end if; 14595 14596 Next_Entity (E); 14597 end loop; 14598 end Restore_Private_Views; 14599 14600 -------------- 14601 -- Save_Env -- 14602 -------------- 14603 14604 procedure Save_Env 14605 (Gen_Unit : Entity_Id; 14606 Act_Unit : Entity_Id) 14607 is 14608 begin 14609 Init_Env; 14610 Set_Instance_Env (Gen_Unit, Act_Unit); 14611 end Save_Env; 14612 14613 ---------------------------- 14614 -- Save_Global_References -- 14615 ---------------------------- 14616 14617 procedure Save_Global_References (Templ : Node_Id) is 14618 14619 -- ??? it is horrible to use global variables in highly recursive code 14620 14621 E : Entity_Id; 14622 -- The entity of the current associated node 14623 14624 Gen_Scope : Entity_Id; 14625 -- The scope of the generic for which references are being saved 14626 14627 N2 : Node_Id; 14628 -- The current associated node 14629 14630 function Is_Global (E : Entity_Id) return Boolean; 14631 -- Check whether entity is defined outside of generic unit. Examine the 14632 -- scope of an entity, and the scope of the scope, etc, until we find 14633 -- either Standard, in which case the entity is global, or the generic 14634 -- unit itself, which indicates that the entity is local. If the entity 14635 -- is the generic unit itself, as in the case of a recursive call, or 14636 -- the enclosing generic unit, if different from the current scope, then 14637 -- it is local as well, because it will be replaced at the point of 14638 -- instantiation. On the other hand, if it is a reference to a child 14639 -- unit of a common ancestor, which appears in an instantiation, it is 14640 -- global because it is used to denote a specific compilation unit at 14641 -- the time the instantiations will be analyzed. 14642 14643 procedure Qualify_Universal_Operands 14644 (Op : Node_Id; 14645 Func_Call : Node_Id); 14646 -- Op denotes a binary or unary operator in generic template Templ. Node 14647 -- Func_Call is the function call alternative of the operator within the 14648 -- the analyzed copy of the template. Change each operand which yields a 14649 -- universal type by wrapping it into a qualified expression 14650 -- 14651 -- Actual_Typ'(Operand) 14652 -- 14653 -- where Actual_Typ is the type of corresponding actual parameter of 14654 -- Operand in Func_Call. 14655 14656 procedure Reset_Entity (N : Node_Id); 14657 -- Save semantic information on global entity so that it is not resolved 14658 -- again at instantiation time. 14659 14660 procedure Save_Entity_Descendants (N : Node_Id); 14661 -- Apply Save_Global_References to the two syntactic descendants of 14662 -- non-terminal nodes that carry an Associated_Node and are processed 14663 -- through Reset_Entity. Once the global entity (if any) has been 14664 -- captured together with its type, only two syntactic descendants need 14665 -- to be traversed to complete the processing of the tree rooted at N. 14666 -- This applies to Selected_Components, Expanded_Names, and to Operator 14667 -- nodes. N can also be a character literal, identifier, or operator 14668 -- symbol node, but the call has no effect in these cases. 14669 14670 procedure Save_Global_Defaults (N1 : Node_Id; N2 : Node_Id); 14671 -- Default actuals in nested instances must be handled specially 14672 -- because there is no link to them from the original tree. When an 14673 -- actual subprogram is given by a default, we add an explicit generic 14674 -- association for it in the instantiation node. When we save the 14675 -- global references on the name of the instance, we recover the list 14676 -- of generic associations, and add an explicit one to the original 14677 -- generic tree, through which a global actual can be preserved. 14678 -- Similarly, if a child unit is instantiated within a sibling, in the 14679 -- context of the parent, we must preserve the identifier of the parent 14680 -- so that it can be properly resolved in a subsequent instantiation. 14681 14682 procedure Save_Global_Descendant (D : Union_Id); 14683 -- Apply Save_References recursively to the descendants of node D 14684 14685 procedure Save_References (N : Node_Id); 14686 -- This is the recursive procedure that does the work, once the 14687 -- enclosing generic scope has been established. 14688 14689 --------------- 14690 -- Is_Global -- 14691 --------------- 14692 14693 function Is_Global (E : Entity_Id) return Boolean is 14694 Se : Entity_Id; 14695 14696 function Is_Instance_Node (Decl : Node_Id) return Boolean; 14697 -- Determine whether the parent node of a reference to a child unit 14698 -- denotes an instantiation or a formal package, in which case the 14699 -- reference to the child unit is global, even if it appears within 14700 -- the current scope (e.g. when the instance appears within the body 14701 -- of an ancestor). 14702 14703 ---------------------- 14704 -- Is_Instance_Node -- 14705 ---------------------- 14706 14707 function Is_Instance_Node (Decl : Node_Id) return Boolean is 14708 begin 14709 return Nkind (Decl) in N_Generic_Instantiation 14710 or else 14711 Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration; 14712 end Is_Instance_Node; 14713 14714 -- Start of processing for Is_Global 14715 14716 begin 14717 if E = Gen_Scope then 14718 return False; 14719 14720 elsif E = Standard_Standard then 14721 return True; 14722 14723 elsif Is_Child_Unit (E) 14724 and then (Is_Instance_Node (Parent (N2)) 14725 or else (Nkind (Parent (N2)) = N_Expanded_Name 14726 and then N2 = Selector_Name (Parent (N2)) 14727 and then 14728 Is_Instance_Node (Parent (Parent (N2))))) 14729 then 14730 return True; 14731 14732 else 14733 Se := Scope (E); 14734 while Se /= Gen_Scope loop 14735 if Se = Standard_Standard then 14736 return True; 14737 else 14738 Se := Scope (Se); 14739 end if; 14740 end loop; 14741 14742 return False; 14743 end if; 14744 end Is_Global; 14745 14746 -------------------------------- 14747 -- Qualify_Universal_Operands -- 14748 -------------------------------- 14749 14750 procedure Qualify_Universal_Operands 14751 (Op : Node_Id; 14752 Func_Call : Node_Id) 14753 is 14754 procedure Qualify_Operand (Opnd : Node_Id; Actual : Node_Id); 14755 -- Rewrite operand Opnd as a qualified expression of the form 14756 -- 14757 -- Actual_Typ'(Opnd) 14758 -- 14759 -- where Actual is the corresponding actual parameter of Opnd in 14760 -- function call Func_Call. 14761 14762 function Qualify_Type 14763 (Loc : Source_Ptr; 14764 Typ : Entity_Id) return Node_Id; 14765 -- Qualify type Typ by creating a selected component of the form 14766 -- 14767 -- Scope_Of_Typ.Typ 14768 14769 --------------------- 14770 -- Qualify_Operand -- 14771 --------------------- 14772 14773 procedure Qualify_Operand (Opnd : Node_Id; Actual : Node_Id) is 14774 Loc : constant Source_Ptr := Sloc (Opnd); 14775 Typ : constant Entity_Id := Etype (Actual); 14776 Mark : Node_Id; 14777 Qual : Node_Id; 14778 14779 begin 14780 -- Qualify the operand when it is of a universal type. Note that 14781 -- the template is unanalyzed and it is not possible to directly 14782 -- query the type. This transformation is not done when the type 14783 -- of the actual is internally generated because the type will be 14784 -- regenerated in the instance. 14785 14786 if Yields_Universal_Type (Opnd) 14787 and then Comes_From_Source (Typ) 14788 and then not Is_Hidden (Typ) 14789 then 14790 -- The type of the actual may be a global reference. Save this 14791 -- information by creating a reference to it. 14792 14793 if Is_Global (Typ) then 14794 Mark := New_Occurrence_Of (Typ, Loc); 14795 14796 -- Otherwise rely on resolution to find the proper type within 14797 -- the instance. 14798 14799 else 14800 Mark := Qualify_Type (Loc, Typ); 14801 end if; 14802 14803 Qual := 14804 Make_Qualified_Expression (Loc, 14805 Subtype_Mark => Mark, 14806 Expression => Relocate_Node (Opnd)); 14807 14808 -- Mark the qualification to distinguish it from other source 14809 -- constructs and signal the instantiation mechanism that this 14810 -- node requires special processing. See Copy_Generic_Node for 14811 -- details. 14812 14813 Set_Is_Qualified_Universal_Literal (Qual); 14814 14815 Rewrite (Opnd, Qual); 14816 end if; 14817 end Qualify_Operand; 14818 14819 ------------------ 14820 -- Qualify_Type -- 14821 ------------------ 14822 14823 function Qualify_Type 14824 (Loc : Source_Ptr; 14825 Typ : Entity_Id) return Node_Id 14826 is 14827 Scop : constant Entity_Id := Scope (Typ); 14828 Result : Node_Id; 14829 14830 begin 14831 Result := Make_Identifier (Loc, Chars (Typ)); 14832 14833 if Present (Scop) and then not Is_Generic_Unit (Scop) then 14834 Result := 14835 Make_Selected_Component (Loc, 14836 Prefix => Make_Identifier (Loc, Chars (Scop)), 14837 Selector_Name => Result); 14838 end if; 14839 14840 return Result; 14841 end Qualify_Type; 14842 14843 -- Local variables 14844 14845 Actuals : constant List_Id := Parameter_Associations (Func_Call); 14846 14847 -- Start of processing for Qualify_Universal_Operands 14848 14849 begin 14850 if Nkind (Op) in N_Binary_Op then 14851 Qualify_Operand (Left_Opnd (Op), First (Actuals)); 14852 Qualify_Operand (Right_Opnd (Op), Next (First (Actuals))); 14853 14854 elsif Nkind (Op) in N_Unary_Op then 14855 Qualify_Operand (Right_Opnd (Op), First (Actuals)); 14856 end if; 14857 end Qualify_Universal_Operands; 14858 14859 ------------------ 14860 -- Reset_Entity -- 14861 ------------------ 14862 14863 procedure Reset_Entity (N : Node_Id) is 14864 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id); 14865 -- If the type of N2 is global to the generic unit, save the type in 14866 -- the generic node. Just as we perform name capture for explicit 14867 -- references within the generic, we must capture the global types 14868 -- of local entities because they may participate in resolution in 14869 -- the instance. 14870 14871 function Top_Ancestor (E : Entity_Id) return Entity_Id; 14872 -- Find the ultimate ancestor of the current unit. If it is not a 14873 -- generic unit, then the name of the current unit in the prefix of 14874 -- an expanded name must be replaced with its generic homonym to 14875 -- ensure that it will be properly resolved in an instance. 14876 14877 --------------------- 14878 -- Set_Global_Type -- 14879 --------------------- 14880 14881 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is 14882 Typ : constant Entity_Id := Etype (N2); 14883 14884 begin 14885 Set_Etype (N, Typ); 14886 14887 -- If the entity of N is not the associated node, this is a 14888 -- nested generic and it has an associated node as well, whose 14889 -- type is already the full view (see below). Indicate that the 14890 -- original node has a private view. 14891 14892 if Entity (N) /= N2 and then Has_Private_View (Entity (N)) then 14893 Set_Has_Private_View (N); 14894 end if; 14895 14896 -- If not a private type, nothing else to do 14897 14898 if not Is_Private_Type (Typ) then 14899 if Is_Array_Type (Typ) 14900 and then Is_Private_Type (Component_Type (Typ)) 14901 then 14902 Set_Has_Private_View (N); 14903 end if; 14904 14905 -- If it is a derivation of a private type in a context where no 14906 -- full view is needed, nothing to do either. 14907 14908 elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then 14909 null; 14910 14911 -- Otherwise mark the type for flipping and use the full view when 14912 -- available. 14913 14914 else 14915 Set_Has_Private_View (N); 14916 14917 if Present (Full_View (Typ)) then 14918 Set_Etype (N2, Full_View (Typ)); 14919 end if; 14920 end if; 14921 14922 if Is_Floating_Point_Type (Typ) 14923 and then Has_Dimension_System (Typ) 14924 then 14925 Copy_Dimensions (N2, N); 14926 end if; 14927 end Set_Global_Type; 14928 14929 ------------------ 14930 -- Top_Ancestor -- 14931 ------------------ 14932 14933 function Top_Ancestor (E : Entity_Id) return Entity_Id is 14934 Par : Entity_Id; 14935 14936 begin 14937 Par := E; 14938 while Is_Child_Unit (Par) loop 14939 Par := Scope (Par); 14940 end loop; 14941 14942 return Par; 14943 end Top_Ancestor; 14944 14945 -- Start of processing for Reset_Entity 14946 14947 begin 14948 N2 := Get_Associated_Node (N); 14949 E := Entity (N2); 14950 14951 if Present (E) then 14952 14953 -- If the node is an entry call to an entry in an enclosing task, 14954 -- it is rewritten as a selected component. No global entity to 14955 -- preserve in this case, since the expansion will be redone in 14956 -- the instance. 14957 14958 if not Nkind_In (E, N_Defining_Character_Literal, 14959 N_Defining_Identifier, 14960 N_Defining_Operator_Symbol) 14961 then 14962 Set_Associated_Node (N, Empty); 14963 Set_Etype (N, Empty); 14964 return; 14965 end if; 14966 14967 -- If the entity is an itype created as a subtype of an access 14968 -- type with a null exclusion restore source entity for proper 14969 -- visibility. The itype will be created anew in the instance. 14970 14971 if Is_Itype (E) 14972 and then Ekind (E) = E_Access_Subtype 14973 and then Is_Entity_Name (N) 14974 and then Chars (Etype (E)) = Chars (N) 14975 then 14976 E := Etype (E); 14977 Set_Entity (N2, E); 14978 Set_Etype (N2, E); 14979 end if; 14980 14981 if Is_Global (E) then 14982 14983 -- If the entity is a package renaming that is the prefix of 14984 -- an expanded name, it has been rewritten as the renamed 14985 -- package, which is necessary semantically but complicates 14986 -- ASIS tree traversal, so we recover the original entity to 14987 -- expose the renaming. Take into account that the context may 14988 -- be a nested generic, that the original node may itself have 14989 -- an associated node that had better be an entity, and that 14990 -- the current node is still a selected component. 14991 14992 if Ekind (E) = E_Package 14993 and then Nkind (N) = N_Selected_Component 14994 and then Nkind (Parent (N)) = N_Expanded_Name 14995 and then Present (Original_Node (N2)) 14996 and then Is_Entity_Name (Original_Node (N2)) 14997 and then Present (Entity (Original_Node (N2))) 14998 then 14999 if Is_Global (Entity (Original_Node (N2))) then 15000 N2 := Original_Node (N2); 15001 Set_Associated_Node (N, N2); 15002 Set_Global_Type (N, N2); 15003 15004 -- Renaming is local, and will be resolved in instance 15005 15006 else 15007 Set_Associated_Node (N, Empty); 15008 Set_Etype (N, Empty); 15009 end if; 15010 15011 else 15012 Set_Global_Type (N, N2); 15013 end if; 15014 15015 elsif Nkind (N) = N_Op_Concat 15016 and then Is_Generic_Type (Etype (N2)) 15017 and then (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2) 15018 or else 15019 Base_Type (Etype (Left_Opnd (N2))) = Etype (N2)) 15020 and then Is_Intrinsic_Subprogram (E) 15021 then 15022 null; 15023 15024 -- Entity is local. Mark generic node as unresolved. Note that now 15025 -- it does not have an entity. 15026 15027 else 15028 Set_Associated_Node (N, Empty); 15029 Set_Etype (N, Empty); 15030 end if; 15031 15032 if Nkind (Parent (N)) in N_Generic_Instantiation 15033 and then N = Name (Parent (N)) 15034 then 15035 Save_Global_Defaults (Parent (N), Parent (N2)); 15036 end if; 15037 15038 elsif Nkind (Parent (N)) = N_Selected_Component 15039 and then Nkind (Parent (N2)) = N_Expanded_Name 15040 then 15041 if Is_Global (Entity (Parent (N2))) then 15042 Change_Selected_Component_To_Expanded_Name (Parent (N)); 15043 Set_Associated_Node (Parent (N), Parent (N2)); 15044 Set_Global_Type (Parent (N), Parent (N2)); 15045 Save_Entity_Descendants (N); 15046 15047 -- If this is a reference to the current generic entity, replace 15048 -- by the name of the generic homonym of the current package. This 15049 -- is because in an instantiation Par.P.Q will not resolve to the 15050 -- name of the instance, whose enclosing scope is not necessarily 15051 -- Par. We use the generic homonym rather that the name of the 15052 -- generic itself because it may be hidden by a local declaration. 15053 15054 elsif In_Open_Scopes (Entity (Parent (N2))) 15055 and then not 15056 Is_Generic_Unit (Top_Ancestor (Entity (Prefix (Parent (N2))))) 15057 then 15058 if Ekind (Entity (Parent (N2))) = E_Generic_Package then 15059 Rewrite (Parent (N), 15060 Make_Identifier (Sloc (N), 15061 Chars => 15062 Chars (Generic_Homonym (Entity (Parent (N2)))))); 15063 else 15064 Rewrite (Parent (N), 15065 Make_Identifier (Sloc (N), 15066 Chars => Chars (Selector_Name (Parent (N2))))); 15067 end if; 15068 end if; 15069 15070 if Nkind (Parent (Parent (N))) in N_Generic_Instantiation 15071 and then Parent (N) = Name (Parent (Parent (N))) 15072 then 15073 Save_Global_Defaults 15074 (Parent (Parent (N)), Parent (Parent (N2))); 15075 end if; 15076 15077 -- A selected component may denote a static constant that has been 15078 -- folded. If the static constant is global to the generic, capture 15079 -- its value. Otherwise the folding will happen in any instantiation. 15080 15081 elsif Nkind (Parent (N)) = N_Selected_Component 15082 and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal) 15083 then 15084 if Present (Entity (Original_Node (Parent (N2)))) 15085 and then Is_Global (Entity (Original_Node (Parent (N2)))) 15086 then 15087 Rewrite (Parent (N), New_Copy (Parent (N2))); 15088 Set_Analyzed (Parent (N), False); 15089 end if; 15090 15091 -- A selected component may be transformed into a parameterless 15092 -- function call. If the called entity is global, rewrite the node 15093 -- appropriately, i.e. as an extended name for the global entity. 15094 15095 elsif Nkind (Parent (N)) = N_Selected_Component 15096 and then Nkind (Parent (N2)) = N_Function_Call 15097 and then N = Selector_Name (Parent (N)) 15098 then 15099 if No (Parameter_Associations (Parent (N2))) then 15100 if Is_Global (Entity (Name (Parent (N2)))) then 15101 Change_Selected_Component_To_Expanded_Name (Parent (N)); 15102 Set_Associated_Node (Parent (N), Name (Parent (N2))); 15103 Set_Global_Type (Parent (N), Name (Parent (N2))); 15104 Save_Entity_Descendants (N); 15105 15106 else 15107 Set_Is_Prefixed_Call (Parent (N)); 15108 Set_Associated_Node (N, Empty); 15109 Set_Etype (N, Empty); 15110 end if; 15111 15112 -- In Ada 2005, X.F may be a call to a primitive operation, 15113 -- rewritten as F (X). This rewriting will be done again in an 15114 -- instance, so keep the original node. Global entities will be 15115 -- captured as for other constructs. Indicate that this must 15116 -- resolve as a call, to prevent accidental overloading in the 15117 -- instance, if both a component and a primitive operation appear 15118 -- as candidates. 15119 15120 else 15121 Set_Is_Prefixed_Call (Parent (N)); 15122 end if; 15123 15124 -- Entity is local. Reset in generic unit, so that node is resolved 15125 -- anew at the point of instantiation. 15126 15127 else 15128 Set_Associated_Node (N, Empty); 15129 Set_Etype (N, Empty); 15130 end if; 15131 end Reset_Entity; 15132 15133 ----------------------------- 15134 -- Save_Entity_Descendants -- 15135 ----------------------------- 15136 15137 procedure Save_Entity_Descendants (N : Node_Id) is 15138 begin 15139 case Nkind (N) is 15140 when N_Binary_Op => 15141 Save_Global_Descendant (Union_Id (Left_Opnd (N))); 15142 Save_Global_Descendant (Union_Id (Right_Opnd (N))); 15143 15144 when N_Unary_Op => 15145 Save_Global_Descendant (Union_Id (Right_Opnd (N))); 15146 15147 when N_Expanded_Name 15148 | N_Selected_Component 15149 => 15150 Save_Global_Descendant (Union_Id (Prefix (N))); 15151 Save_Global_Descendant (Union_Id (Selector_Name (N))); 15152 15153 when N_Character_Literal 15154 | N_Identifier 15155 | N_Operator_Symbol 15156 => 15157 null; 15158 15159 when others => 15160 raise Program_Error; 15161 end case; 15162 end Save_Entity_Descendants; 15163 15164 -------------------------- 15165 -- Save_Global_Defaults -- 15166 -------------------------- 15167 15168 procedure Save_Global_Defaults (N1 : Node_Id; N2 : Node_Id) is 15169 Loc : constant Source_Ptr := Sloc (N1); 15170 Assoc2 : constant List_Id := Generic_Associations (N2); 15171 Gen_Id : constant Entity_Id := Get_Generic_Entity (N2); 15172 Assoc1 : List_Id; 15173 Act1 : Node_Id; 15174 Act2 : Node_Id; 15175 Def : Node_Id; 15176 Ndec : Node_Id; 15177 Subp : Entity_Id; 15178 Actual : Entity_Id; 15179 15180 begin 15181 Assoc1 := Generic_Associations (N1); 15182 15183 if Present (Assoc1) then 15184 Act1 := First (Assoc1); 15185 else 15186 Act1 := Empty; 15187 Set_Generic_Associations (N1, New_List); 15188 Assoc1 := Generic_Associations (N1); 15189 end if; 15190 15191 if Present (Assoc2) then 15192 Act2 := First (Assoc2); 15193 else 15194 return; 15195 end if; 15196 15197 while Present (Act1) and then Present (Act2) loop 15198 Next (Act1); 15199 Next (Act2); 15200 end loop; 15201 15202 -- Find the associations added for default subprograms 15203 15204 if Present (Act2) then 15205 while Nkind (Act2) /= N_Generic_Association 15206 or else No (Entity (Selector_Name (Act2))) 15207 or else not Is_Overloadable (Entity (Selector_Name (Act2))) 15208 loop 15209 Next (Act2); 15210 end loop; 15211 15212 -- Add a similar association if the default is global. The 15213 -- renaming declaration for the actual has been analyzed, and 15214 -- its alias is the program it renames. Link the actual in the 15215 -- original generic tree with the node in the analyzed tree. 15216 15217 while Present (Act2) loop 15218 Subp := Entity (Selector_Name (Act2)); 15219 Def := Explicit_Generic_Actual_Parameter (Act2); 15220 15221 -- Following test is defence against rubbish errors 15222 15223 if No (Alias (Subp)) then 15224 return; 15225 end if; 15226 15227 -- Retrieve the resolved actual from the renaming declaration 15228 -- created for the instantiated formal. 15229 15230 Actual := Entity (Name (Parent (Parent (Subp)))); 15231 Set_Entity (Def, Actual); 15232 Set_Etype (Def, Etype (Actual)); 15233 15234 if Is_Global (Actual) then 15235 Ndec := 15236 Make_Generic_Association (Loc, 15237 Selector_Name => 15238 New_Occurrence_Of (Subp, Loc), 15239 Explicit_Generic_Actual_Parameter => 15240 New_Occurrence_Of (Actual, Loc)); 15241 15242 Set_Associated_Node 15243 (Explicit_Generic_Actual_Parameter (Ndec), Def); 15244 15245 Append (Ndec, Assoc1); 15246 15247 -- If there are other defaults, add a dummy association in case 15248 -- there are other defaulted formals with the same name. 15249 15250 elsif Present (Next (Act2)) then 15251 Ndec := 15252 Make_Generic_Association (Loc, 15253 Selector_Name => 15254 New_Occurrence_Of (Subp, Loc), 15255 Explicit_Generic_Actual_Parameter => Empty); 15256 15257 Append (Ndec, Assoc1); 15258 end if; 15259 15260 Next (Act2); 15261 end loop; 15262 end if; 15263 15264 if Nkind (Name (N1)) = N_Identifier 15265 and then Is_Child_Unit (Gen_Id) 15266 and then Is_Global (Gen_Id) 15267 and then Is_Generic_Unit (Scope (Gen_Id)) 15268 and then In_Open_Scopes (Scope (Gen_Id)) 15269 then 15270 -- This is an instantiation of a child unit within a sibling, so 15271 -- that the generic parent is in scope. An eventual instance must 15272 -- occur within the scope of an instance of the parent. Make name 15273 -- in instance into an expanded name, to preserve the identifier 15274 -- of the parent, so it can be resolved subsequently. 15275 15276 Rewrite (Name (N2), 15277 Make_Expanded_Name (Loc, 15278 Chars => Chars (Gen_Id), 15279 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc), 15280 Selector_Name => New_Occurrence_Of (Gen_Id, Loc))); 15281 Set_Entity (Name (N2), Gen_Id); 15282 15283 Rewrite (Name (N1), 15284 Make_Expanded_Name (Loc, 15285 Chars => Chars (Gen_Id), 15286 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc), 15287 Selector_Name => New_Occurrence_Of (Gen_Id, Loc))); 15288 15289 Set_Associated_Node (Name (N1), Name (N2)); 15290 Set_Associated_Node (Prefix (Name (N1)), Empty); 15291 Set_Associated_Node 15292 (Selector_Name (Name (N1)), Selector_Name (Name (N2))); 15293 Set_Etype (Name (N1), Etype (Gen_Id)); 15294 end if; 15295 end Save_Global_Defaults; 15296 15297 ---------------------------- 15298 -- Save_Global_Descendant -- 15299 ---------------------------- 15300 15301 procedure Save_Global_Descendant (D : Union_Id) is 15302 N1 : Node_Id; 15303 15304 begin 15305 if D in Node_Range then 15306 if D = Union_Id (Empty) then 15307 null; 15308 15309 elsif Nkind (Node_Id (D)) /= N_Compilation_Unit then 15310 Save_References (Node_Id (D)); 15311 end if; 15312 15313 elsif D in List_Range then 15314 pragma Assert (D /= Union_Id (No_List)); 15315 -- Because No_List = Empty, which is in Node_Range above 15316 15317 if Is_Empty_List (List_Id (D)) then 15318 null; 15319 15320 else 15321 N1 := First (List_Id (D)); 15322 while Present (N1) loop 15323 Save_References (N1); 15324 Next (N1); 15325 end loop; 15326 end if; 15327 15328 -- Element list or other non-node field, nothing to do 15329 15330 else 15331 null; 15332 end if; 15333 end Save_Global_Descendant; 15334 15335 --------------------- 15336 -- Save_References -- 15337 --------------------- 15338 15339 -- This is the recursive procedure that does the work once the enclosing 15340 -- generic scope has been established. We have to treat specially a 15341 -- number of node rewritings that are required by semantic processing 15342 -- and which change the kind of nodes in the generic copy: typically 15343 -- constant-folding, replacing an operator node by a string literal, or 15344 -- a selected component by an expanded name. In each of those cases, the 15345 -- transformation is propagated to the generic unit. 15346 15347 procedure Save_References (N : Node_Id) is 15348 Loc : constant Source_Ptr := Sloc (N); 15349 15350 function Requires_Delayed_Save (Nod : Node_Id) return Boolean; 15351 -- Determine whether arbitrary node Nod requires delayed capture of 15352 -- global references within its aspect specifications. 15353 15354 procedure Save_References_In_Aggregate (N : Node_Id); 15355 -- Save all global references in [extension] aggregate node N 15356 15357 procedure Save_References_In_Char_Lit_Or_Op_Symbol (N : Node_Id); 15358 -- Save all global references in a character literal or operator 15359 -- symbol denoted by N. 15360 15361 procedure Save_References_In_Descendants (N : Node_Id); 15362 -- Save all global references in all descendants of node N 15363 15364 procedure Save_References_In_Identifier (N : Node_Id); 15365 -- Save all global references in identifier node N 15366 15367 procedure Save_References_In_Operator (N : Node_Id); 15368 -- Save all global references in operator node N 15369 15370 procedure Save_References_In_Pragma (Prag : Node_Id); 15371 -- Save all global references found within the expression of pragma 15372 -- Prag. 15373 15374 --------------------------- 15375 -- Requires_Delayed_Save -- 15376 --------------------------- 15377 15378 function Requires_Delayed_Save (Nod : Node_Id) return Boolean is 15379 begin 15380 -- Generic packages and subprograms require delayed capture of 15381 -- global references within their aspects due to the timing of 15382 -- annotation analysis. 15383 15384 if Nkind_In (Nod, N_Generic_Package_Declaration, 15385 N_Generic_Subprogram_Declaration, 15386 N_Package_Body, 15387 N_Package_Body_Stub, 15388 N_Subprogram_Body, 15389 N_Subprogram_Body_Stub) 15390 then 15391 -- Since the capture of global references is done on the 15392 -- unanalyzed generic template, there is no information around 15393 -- to infer the context. Use the Associated_Entity linkages to 15394 -- peek into the analyzed generic copy and determine what the 15395 -- template corresponds to. 15396 15397 if Nod = Templ then 15398 return 15399 Is_Generic_Declaration_Or_Body 15400 (Unit_Declaration_Node 15401 (Associated_Entity (Defining_Entity (Nod)))); 15402 15403 -- Otherwise the generic unit being processed is not the top 15404 -- level template. It is safe to capture of global references 15405 -- within the generic unit because at this point the top level 15406 -- copy is fully analyzed. 15407 15408 else 15409 return False; 15410 end if; 15411 15412 -- Otherwise capture the global references without interference 15413 15414 else 15415 return False; 15416 end if; 15417 end Requires_Delayed_Save; 15418 15419 ---------------------------------- 15420 -- Save_References_In_Aggregate -- 15421 ---------------------------------- 15422 15423 procedure Save_References_In_Aggregate (N : Node_Id) is 15424 Nam : Node_Id; 15425 Qual : Node_Id := Empty; 15426 Typ : Entity_Id := Empty; 15427 15428 use Atree.Unchecked_Access; 15429 -- This code section is part of implementing an untyped tree 15430 -- traversal, so it needs direct access to node fields. 15431 15432 begin 15433 N2 := Get_Associated_Node (N); 15434 15435 if Present (N2) then 15436 Typ := Etype (N2); 15437 15438 -- In an instance within a generic, use the name of the actual 15439 -- and not the original generic parameter. If the actual is 15440 -- global in the current generic it must be preserved for its 15441 -- instantiation. 15442 15443 if Nkind (Parent (Typ)) = N_Subtype_Declaration 15444 and then Present (Generic_Parent_Type (Parent (Typ))) 15445 then 15446 Typ := Base_Type (Typ); 15447 Set_Etype (N2, Typ); 15448 end if; 15449 end if; 15450 15451 if No (N2) or else No (Typ) or else not Is_Global (Typ) then 15452 Set_Associated_Node (N, Empty); 15453 15454 -- If the aggregate is an actual in a call, it has been 15455 -- resolved in the current context, to some local type. The 15456 -- enclosing call may have been disambiguated by the aggregate, 15457 -- and this disambiguation might fail at instantiation time 15458 -- because the type to which the aggregate did resolve is not 15459 -- preserved. In order to preserve some of this information, 15460 -- wrap the aggregate in a qualified expression, using the id 15461 -- of its type. For further disambiguation we qualify the type 15462 -- name with its scope (if visible and not hidden by a local 15463 -- homograph) because both id's will have corresponding 15464 -- entities in an instance. This resolves most of the problems 15465 -- with missing type information on aggregates in instances. 15466 15467 if Present (N2) 15468 and then Nkind (N2) = Nkind (N) 15469 and then Nkind (Parent (N2)) in N_Subprogram_Call 15470 and then Present (Typ) 15471 and then Comes_From_Source (Typ) 15472 then 15473 Nam := Make_Identifier (Loc, Chars (Typ)); 15474 15475 if Is_Immediately_Visible (Scope (Typ)) 15476 and then 15477 (not In_Open_Scopes (Scope (Typ)) 15478 or else Current_Entity (Scope (Typ)) = Scope (Typ)) 15479 then 15480 Nam := 15481 Make_Selected_Component (Loc, 15482 Prefix => 15483 Make_Identifier (Loc, Chars (Scope (Typ))), 15484 Selector_Name => Nam); 15485 end if; 15486 15487 Qual := 15488 Make_Qualified_Expression (Loc, 15489 Subtype_Mark => Nam, 15490 Expression => Relocate_Node (N)); 15491 end if; 15492 end if; 15493 15494 Save_Global_Descendant (Field1 (N)); 15495 Save_Global_Descendant (Field2 (N)); 15496 Save_Global_Descendant (Field3 (N)); 15497 Save_Global_Descendant (Field5 (N)); 15498 15499 if Present (Qual) then 15500 Rewrite (N, Qual); 15501 end if; 15502 end Save_References_In_Aggregate; 15503 15504 ---------------------------------------------- 15505 -- Save_References_In_Char_Lit_Or_Op_Symbol -- 15506 ---------------------------------------------- 15507 15508 procedure Save_References_In_Char_Lit_Or_Op_Symbol (N : Node_Id) is 15509 begin 15510 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 15511 Reset_Entity (N); 15512 15513 elsif Nkind (N) = N_Operator_Symbol 15514 and then Nkind (Get_Associated_Node (N)) = N_String_Literal 15515 then 15516 Change_Operator_Symbol_To_String_Literal (N); 15517 end if; 15518 end Save_References_In_Char_Lit_Or_Op_Symbol; 15519 15520 ------------------------------------ 15521 -- Save_References_In_Descendants -- 15522 ------------------------------------ 15523 15524 procedure Save_References_In_Descendants (N : Node_Id) is 15525 use Atree.Unchecked_Access; 15526 -- This code section is part of implementing an untyped tree 15527 -- traversal, so it needs direct access to node fields. 15528 15529 begin 15530 Save_Global_Descendant (Field1 (N)); 15531 Save_Global_Descendant (Field2 (N)); 15532 Save_Global_Descendant (Field3 (N)); 15533 Save_Global_Descendant (Field4 (N)); 15534 Save_Global_Descendant (Field5 (N)); 15535 end Save_References_In_Descendants; 15536 15537 ----------------------------------- 15538 -- Save_References_In_Identifier -- 15539 ----------------------------------- 15540 15541 procedure Save_References_In_Identifier (N : Node_Id) is 15542 begin 15543 -- The node did not undergo a transformation 15544 15545 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 15546 declare 15547 Aux_N2 : constant Node_Id := Get_Associated_Node (N); 15548 Orig_N2_Parent : constant Node_Id := 15549 Original_Node (Parent (Aux_N2)); 15550 begin 15551 -- The parent of this identifier is a selected component 15552 -- which denotes a named number that was constant folded. 15553 -- Preserve the original name for ASIS and link the parent 15554 -- with its expanded name. The constant folding will be 15555 -- repeated in the instance. 15556 15557 if Nkind (Parent (N)) = N_Selected_Component 15558 and then Nkind_In (Parent (Aux_N2), N_Integer_Literal, 15559 N_Real_Literal) 15560 and then Is_Entity_Name (Orig_N2_Parent) 15561 and then Ekind (Entity (Orig_N2_Parent)) in Named_Kind 15562 and then Is_Global (Entity (Orig_N2_Parent)) 15563 then 15564 N2 := Aux_N2; 15565 Set_Associated_Node 15566 (Parent (N), Original_Node (Parent (N2))); 15567 15568 -- Common case 15569 15570 else 15571 -- If this is a discriminant reference, always save it. 15572 -- It is used in the instance to find the corresponding 15573 -- discriminant positionally rather than by name. 15574 15575 Set_Original_Discriminant 15576 (N, Original_Discriminant (Get_Associated_Node (N))); 15577 end if; 15578 15579 Reset_Entity (N); 15580 end; 15581 15582 -- The analysis of the generic copy transformed the identifier 15583 -- into another construct. Propagate the changes to the template. 15584 15585 else 15586 N2 := Get_Associated_Node (N); 15587 15588 -- The identifier denotes a call to a parameterless function. 15589 -- Mark the node as resolved when the function is external. 15590 15591 if Nkind (N2) = N_Function_Call then 15592 E := Entity (Name (N2)); 15593 15594 if Present (E) and then Is_Global (E) then 15595 Set_Etype (N, Etype (N2)); 15596 else 15597 Set_Associated_Node (N, Empty); 15598 Set_Etype (N, Empty); 15599 end if; 15600 15601 -- The identifier denotes a named number that was constant 15602 -- folded. Preserve the original name for ASIS and undo the 15603 -- constant folding which will be repeated in the instance. 15604 15605 elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal) 15606 and then Is_Entity_Name (Original_Node (N2)) 15607 then 15608 Set_Associated_Node (N, Original_Node (N2)); 15609 Reset_Entity (N); 15610 15611 -- The identifier resolved to a string literal. Propagate this 15612 -- information to the generic template. 15613 15614 elsif Nkind (N2) = N_String_Literal then 15615 Rewrite (N, New_Copy (N2)); 15616 15617 -- The identifier is rewritten as a dereference if it is the 15618 -- prefix of an implicit dereference. Preserve the original 15619 -- tree as the analysis of the instance will expand the node 15620 -- again, but preserve the resolved entity if it is global. 15621 15622 elsif Nkind (N2) = N_Explicit_Dereference then 15623 if Is_Entity_Name (Prefix (N2)) 15624 and then Present (Entity (Prefix (N2))) 15625 and then Is_Global (Entity (Prefix (N2))) 15626 then 15627 Set_Associated_Node (N, Prefix (N2)); 15628 15629 elsif Nkind (Prefix (N2)) = N_Function_Call 15630 and then Present (Entity (Name (Prefix (N2)))) 15631 and then Is_Global (Entity (Name (Prefix (N2)))) 15632 then 15633 Rewrite (N, 15634 Make_Explicit_Dereference (Loc, 15635 Prefix => 15636 Make_Function_Call (Loc, 15637 Name => 15638 New_Occurrence_Of 15639 (Entity (Name (Prefix (N2))), Loc)))); 15640 15641 else 15642 Set_Associated_Node (N, Empty); 15643 Set_Etype (N, Empty); 15644 end if; 15645 15646 -- The subtype mark of a nominally unconstrained object is 15647 -- rewritten as a subtype indication using the bounds of the 15648 -- expression. Recover the original subtype mark. 15649 15650 elsif Nkind (N2) = N_Subtype_Indication 15651 and then Is_Entity_Name (Original_Node (N2)) 15652 then 15653 Set_Associated_Node (N, Original_Node (N2)); 15654 Reset_Entity (N); 15655 end if; 15656 end if; 15657 end Save_References_In_Identifier; 15658 15659 --------------------------------- 15660 -- Save_References_In_Operator -- 15661 --------------------------------- 15662 15663 procedure Save_References_In_Operator (N : Node_Id) is 15664 begin 15665 -- The node did not undergo a transformation 15666 15667 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 15668 if Nkind (N) = N_Op_Concat then 15669 Set_Is_Component_Left_Opnd (N, 15670 Is_Component_Left_Opnd (Get_Associated_Node (N))); 15671 15672 Set_Is_Component_Right_Opnd (N, 15673 Is_Component_Right_Opnd (Get_Associated_Node (N))); 15674 end if; 15675 15676 Reset_Entity (N); 15677 15678 -- The analysis of the generic copy transformed the operator into 15679 -- some other construct. Propagate the changes to the template if 15680 -- applicable. 15681 15682 else 15683 N2 := Get_Associated_Node (N); 15684 15685 -- The operator resoved to a function call 15686 15687 if Nkind (N2) = N_Function_Call then 15688 15689 -- Add explicit qualifications in the generic template for 15690 -- all operands of universal type. This aids resolution by 15691 -- preserving the actual type of a literal or an attribute 15692 -- that yields a universal result. 15693 15694 Qualify_Universal_Operands (N, N2); 15695 15696 E := Entity (Name (N2)); 15697 15698 if Present (E) and then Is_Global (E) then 15699 Set_Etype (N, Etype (N2)); 15700 else 15701 Set_Associated_Node (N, Empty); 15702 Set_Etype (N, Empty); 15703 end if; 15704 15705 -- The operator was folded into a literal 15706 15707 elsif Nkind_In (N2, N_Integer_Literal, 15708 N_Real_Literal, 15709 N_String_Literal) 15710 then 15711 if Present (Original_Node (N2)) 15712 and then Nkind (Original_Node (N2)) = Nkind (N) 15713 then 15714 -- Operation was constant-folded. Whenever possible, 15715 -- recover semantic information from unfolded node, 15716 -- for ASIS use. 15717 15718 Set_Associated_Node (N, Original_Node (N2)); 15719 15720 if Nkind (N) = N_Op_Concat then 15721 Set_Is_Component_Left_Opnd (N, 15722 Is_Component_Left_Opnd (Get_Associated_Node (N))); 15723 Set_Is_Component_Right_Opnd (N, 15724 Is_Component_Right_Opnd (Get_Associated_Node (N))); 15725 end if; 15726 15727 Reset_Entity (N); 15728 15729 -- Propagate the constant folding back to the template 15730 15731 else 15732 Rewrite (N, New_Copy (N2)); 15733 Set_Analyzed (N, False); 15734 end if; 15735 15736 -- The operator was folded into an enumeration literal. Retain 15737 -- the entity to avoid spurious ambiguities if it is overloaded 15738 -- at the point of instantiation or inlining. 15739 15740 elsif Nkind (N2) = N_Identifier 15741 and then Ekind (Entity (N2)) = E_Enumeration_Literal 15742 then 15743 Rewrite (N, New_Copy (N2)); 15744 Set_Analyzed (N, False); 15745 end if; 15746 end if; 15747 15748 -- Complete the operands check if node has not been constant 15749 -- folded. 15750 15751 if Nkind (N) in N_Op then 15752 Save_Entity_Descendants (N); 15753 end if; 15754 end Save_References_In_Operator; 15755 15756 ------------------------------- 15757 -- Save_References_In_Pragma -- 15758 ------------------------------- 15759 15760 procedure Save_References_In_Pragma (Prag : Node_Id) is 15761 Context : Node_Id; 15762 Do_Save : Boolean := True; 15763 15764 use Atree.Unchecked_Access; 15765 -- This code section is part of implementing an untyped tree 15766 -- traversal, so it needs direct access to node fields. 15767 15768 begin 15769 -- Do not save global references in pragmas generated from aspects 15770 -- because the pragmas will be regenerated at instantiation time. 15771 15772 if From_Aspect_Specification (Prag) then 15773 Do_Save := False; 15774 15775 -- The capture of global references within contract-related source 15776 -- pragmas associated with generic packages, subprograms or their 15777 -- respective bodies must be delayed due to timing of annotation 15778 -- analysis. Global references are still captured in routine 15779 -- Save_Global_References_In_Contract. 15780 15781 elsif Is_Generic_Contract_Pragma (Prag) and then Prag /= Templ then 15782 if Is_Package_Contract_Annotation (Prag) then 15783 Context := Find_Related_Package_Or_Body (Prag); 15784 else 15785 pragma Assert (Is_Subprogram_Contract_Annotation (Prag)); 15786 Context := Find_Related_Declaration_Or_Body (Prag); 15787 end if; 15788 15789 -- The use of Original_Node accounts for the case when the 15790 -- related context is generic template. 15791 15792 if Requires_Delayed_Save (Original_Node (Context)) then 15793 Do_Save := False; 15794 end if; 15795 end if; 15796 15797 -- For all other cases, save all global references within the 15798 -- descendants, but skip the following semantic fields: 15799 15800 -- Field1 - Next_Pragma 15801 -- Field3 - Corresponding_Aspect 15802 -- Field5 - Next_Rep_Item 15803 15804 if Do_Save then 15805 Save_Global_Descendant (Field2 (Prag)); 15806 Save_Global_Descendant (Field4 (Prag)); 15807 end if; 15808 end Save_References_In_Pragma; 15809 15810 -- Start of processing for Save_References 15811 15812 begin 15813 if N = Empty then 15814 null; 15815 15816 -- Aggregates 15817 15818 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 15819 Save_References_In_Aggregate (N); 15820 15821 -- Character literals, operator symbols 15822 15823 elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then 15824 Save_References_In_Char_Lit_Or_Op_Symbol (N); 15825 15826 -- Defining identifiers 15827 15828 elsif Nkind (N) in N_Entity then 15829 null; 15830 15831 -- Identifiers 15832 15833 elsif Nkind (N) = N_Identifier then 15834 Save_References_In_Identifier (N); 15835 15836 -- Operators 15837 15838 elsif Nkind (N) in N_Op then 15839 Save_References_In_Operator (N); 15840 15841 -- Pragmas 15842 15843 elsif Nkind (N) = N_Pragma then 15844 Save_References_In_Pragma (N); 15845 15846 else 15847 Save_References_In_Descendants (N); 15848 end if; 15849 15850 -- Save all global references found within the aspect specifications 15851 -- of the related node. 15852 15853 if Permits_Aspect_Specifications (N) and then Has_Aspects (N) then 15854 15855 -- The capture of global references within aspects associated with 15856 -- generic packages, subprograms or their bodies must be delayed 15857 -- due to timing of annotation analysis. Global references are 15858 -- still captured in routine Save_Global_References_In_Contract. 15859 15860 if Requires_Delayed_Save (N) then 15861 null; 15862 15863 -- Otherwise save all global references within the aspects 15864 15865 else 15866 Save_Global_References_In_Aspects (N); 15867 end if; 15868 end if; 15869 end Save_References; 15870 15871 -- Start of processing for Save_Global_References 15872 15873 begin 15874 Gen_Scope := Current_Scope; 15875 15876 -- If the generic unit is a child unit, references to entities in the 15877 -- parent are treated as local, because they will be resolved anew in 15878 -- the context of the instance of the parent. 15879 15880 while Is_Child_Unit (Gen_Scope) 15881 and then Ekind (Scope (Gen_Scope)) = E_Generic_Package 15882 loop 15883 Gen_Scope := Scope (Gen_Scope); 15884 end loop; 15885 15886 Save_References (Templ); 15887 end Save_Global_References; 15888 15889 --------------------------------------- 15890 -- Save_Global_References_In_Aspects -- 15891 --------------------------------------- 15892 15893 procedure Save_Global_References_In_Aspects (N : Node_Id) is 15894 Asp : Node_Id; 15895 Expr : Node_Id; 15896 15897 begin 15898 Asp := First (Aspect_Specifications (N)); 15899 while Present (Asp) loop 15900 Expr := Expression (Asp); 15901 15902 if Present (Expr) then 15903 Save_Global_References (Expr); 15904 end if; 15905 15906 Next (Asp); 15907 end loop; 15908 end Save_Global_References_In_Aspects; 15909 15910 ------------------------------------------ 15911 -- Set_Copied_Sloc_For_Inherited_Pragma -- 15912 ------------------------------------------ 15913 15914 procedure Set_Copied_Sloc_For_Inherited_Pragma 15915 (N : Node_Id; 15916 E : Entity_Id) 15917 is 15918 begin 15919 Create_Instantiation_Source (N, E, 15920 Inlined_Body => False, 15921 Inherited_Pragma => True, 15922 Factor => S_Adjustment); 15923 end Set_Copied_Sloc_For_Inherited_Pragma; 15924 15925 -------------------------------------- 15926 -- Set_Copied_Sloc_For_Inlined_Body -- 15927 -------------------------------------- 15928 15929 procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is 15930 begin 15931 Create_Instantiation_Source (N, E, 15932 Inlined_Body => True, 15933 Inherited_Pragma => False, 15934 Factor => S_Adjustment); 15935 end Set_Copied_Sloc_For_Inlined_Body; 15936 15937 --------------------- 15938 -- Set_Instance_Of -- 15939 --------------------- 15940 15941 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is 15942 begin 15943 Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null); 15944 Generic_Renamings_HTable.Set (Generic_Renamings.Last); 15945 Generic_Renamings.Increment_Last; 15946 end Set_Instance_Of; 15947 15948 -------------------- 15949 -- Set_Next_Assoc -- 15950 -------------------- 15951 15952 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr) is 15953 begin 15954 Generic_Renamings.Table (E).Next_In_HTable := Next; 15955 end Set_Next_Assoc; 15956 15957 ------------------- 15958 -- Start_Generic -- 15959 ------------------- 15960 15961 procedure Start_Generic is 15962 begin 15963 -- ??? More things could be factored out in this routine. 15964 -- Should probably be done at a later stage. 15965 15966 Generic_Flags.Append (Inside_A_Generic); 15967 Inside_A_Generic := True; 15968 15969 Expander_Mode_Save_And_Set (False); 15970 end Start_Generic; 15971 15972 ---------------------- 15973 -- Set_Instance_Env -- 15974 ---------------------- 15975 15976 -- WARNING: This routine manages SPARK regions 15977 15978 procedure Set_Instance_Env 15979 (Gen_Unit : Entity_Id; 15980 Act_Unit : Entity_Id) 15981 is 15982 Saved_AE : constant Boolean := Assertions_Enabled; 15983 Saved_CPL : constant Node_Id := Check_Policy_List; 15984 Saved_DEC : constant Boolean := Dynamic_Elaboration_Checks; 15985 Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; 15986 Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; 15987 15988 begin 15989 -- Regardless of the current mode, predefined units are analyzed in the 15990 -- most current Ada mode, and earlier version Ada checks do not apply 15991 -- to predefined units. Nothing needs to be done for non-internal units. 15992 -- These are always analyzed in the current mode. 15993 15994 if In_Internal_Unit (Gen_Unit) then 15995 15996 -- The following call resets all configuration attributes to default 15997 -- or the xxx_Config versions of the attributes when the current sem 15998 -- unit is the main unit. At the same time, internal units must also 15999 -- inherit certain configuration attributes from their context. It 16000 -- is unclear what these two sets are. 16001 16002 Set_Config_Switches (True, Current_Sem_Unit = Main_Unit); 16003 16004 -- Reinstall relevant configuration attributes of the context 16005 16006 Assertions_Enabled := Saved_AE; 16007 Check_Policy_List := Saved_CPL; 16008 Dynamic_Elaboration_Checks := Saved_DEC; 16009 16010 Install_SPARK_Mode (Saved_SM, Saved_SMP); 16011 end if; 16012 16013 Current_Instantiated_Parent := 16014 (Gen_Id => Gen_Unit, 16015 Act_Id => Act_Unit, 16016 Next_In_HTable => Assoc_Null); 16017 end Set_Instance_Env; 16018 16019 ----------------- 16020 -- Switch_View -- 16021 ----------------- 16022 16023 procedure Switch_View (T : Entity_Id) is 16024 BT : constant Entity_Id := Base_Type (T); 16025 Priv_Elmt : Elmt_Id := No_Elmt; 16026 Priv_Sub : Entity_Id; 16027 16028 begin 16029 -- T may be private but its base type may have been exchanged through 16030 -- some other occurrence, in which case there is nothing to switch 16031 -- besides T itself. Note that a private dependent subtype of a private 16032 -- type might not have been switched even if the base type has been, 16033 -- because of the last branch of Check_Private_View (see comment there). 16034 16035 if not Is_Private_Type (BT) then 16036 Prepend_Elmt (Full_View (T), Exchanged_Views); 16037 Exchange_Declarations (T); 16038 return; 16039 end if; 16040 16041 Priv_Elmt := First_Elmt (Private_Dependents (BT)); 16042 16043 if Present (Full_View (BT)) then 16044 Prepend_Elmt (Full_View (BT), Exchanged_Views); 16045 Exchange_Declarations (BT); 16046 end if; 16047 16048 while Present (Priv_Elmt) loop 16049 Priv_Sub := (Node (Priv_Elmt)); 16050 16051 -- We avoid flipping the subtype if the Etype of its full view is 16052 -- private because this would result in a malformed subtype. This 16053 -- occurs when the Etype of the subtype full view is the full view of 16054 -- the base type (and since the base types were just switched, the 16055 -- subtype is pointing to the wrong view). This is currently the case 16056 -- for tagged record types, access types (maybe more?) and needs to 16057 -- be resolved. ??? 16058 16059 if Present (Full_View (Priv_Sub)) 16060 and then not Is_Private_Type (Etype (Full_View (Priv_Sub))) 16061 then 16062 Prepend_Elmt (Full_View (Priv_Sub), Exchanged_Views); 16063 Exchange_Declarations (Priv_Sub); 16064 end if; 16065 16066 Next_Elmt (Priv_Elmt); 16067 end loop; 16068 end Switch_View; 16069 16070 ----------------- 16071 -- True_Parent -- 16072 ----------------- 16073 16074 function True_Parent (N : Node_Id) return Node_Id is 16075 begin 16076 if Nkind (Parent (N)) = N_Subunit then 16077 return Parent (Corresponding_Stub (Parent (N))); 16078 else 16079 return Parent (N); 16080 end if; 16081 end True_Parent; 16082 16083 ----------------------------- 16084 -- Valid_Default_Attribute -- 16085 ----------------------------- 16086 16087 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is 16088 Attr_Id : constant Attribute_Id := 16089 Get_Attribute_Id (Attribute_Name (Def)); 16090 T : constant Entity_Id := Entity (Prefix (Def)); 16091 Is_Fun : constant Boolean := (Ekind (Nam) = E_Function); 16092 F : Entity_Id; 16093 Num_F : Nat; 16094 OK : Boolean; 16095 16096 begin 16097 if No (T) or else T = Any_Id then 16098 return; 16099 end if; 16100 16101 Num_F := 0; 16102 F := First_Formal (Nam); 16103 while Present (F) loop 16104 Num_F := Num_F + 1; 16105 Next_Formal (F); 16106 end loop; 16107 16108 case Attr_Id is 16109 when Attribute_Adjacent 16110 | Attribute_Ceiling 16111 | Attribute_Copy_Sign 16112 | Attribute_Floor 16113 | Attribute_Fraction 16114 | Attribute_Machine 16115 | Attribute_Model 16116 | Attribute_Remainder 16117 | Attribute_Rounding 16118 | Attribute_Unbiased_Rounding 16119 => 16120 OK := Is_Fun 16121 and then Num_F = 1 16122 and then Is_Floating_Point_Type (T); 16123 16124 when Attribute_Image 16125 | Attribute_Pred 16126 | Attribute_Succ 16127 | Attribute_Value 16128 | Attribute_Wide_Image 16129 | Attribute_Wide_Value 16130 => 16131 OK := Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T); 16132 16133 when Attribute_Max 16134 | Attribute_Min 16135 => 16136 OK := Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T); 16137 16138 when Attribute_Input => 16139 OK := (Is_Fun and then Num_F = 1); 16140 16141 when Attribute_Output 16142 | Attribute_Read 16143 | Attribute_Write 16144 => 16145 OK := not Is_Fun and then Num_F = 2; 16146 16147 when others => 16148 OK := False; 16149 end case; 16150 16151 if not OK then 16152 Error_Msg_N 16153 ("attribute reference has wrong profile for subprogram", Def); 16154 end if; 16155 end Valid_Default_Attribute; 16156 16157end Sem_Ch12; 16158